Fix #4398: Fix arg order to calls to laptimes
[maxima.git] / lisp-utils / defsystem.lisp-clocc
blobe628c8202883c2c5e61e23bf579509900f971c08
1 ;;; -*- Mode: Lisp; Package: make -*-
2 ;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-
4 ;;; DEFSYSTEM 3.4 Interim 3.
6 ;;; defsystem.lisp --
8 ;;; ****************************************************************
9 ;;; MAKE -- A Portable Defsystem Implementation ********************
10 ;;; ****************************************************************
12 ;;; This is a portable system definition facility for Common Lisp.
13 ;;; Though home-grown, the syntax was inspired by fond memories of the
14 ;;; defsystem facility on Symbolics 3600's. The exhaustive lists of
15 ;;; filename extensions for various lisps and the idea to have one
16 ;;; "operate-on-system" function instead of separate "compile-system"
17 ;;; and "load-system" functions were taken from Xerox Corp.'s PCL
18 ;;; system.
20 ;;; This system improves on both PCL and Symbolics defsystem utilities
21 ;;; by performing a topological sort of the graph of file-dependency
22 ;;; constraints. Thus, the components of the system need not be listed
23 ;;; in any special order, because the defsystem command reorganizes them
24 ;;; based on their constraints. It includes all the standard bells and
25 ;;; whistles, such as not recompiling a binary file that is up to date
26 ;;; (unless the user specifies that all files should be recompiled).
28 ;;; Originally written by Mark Kantrowitz, School of Computer Science,
29 ;;; Carnegie Mellon University, October 1989.
31 ;;; MK:DEFSYSTEM 3.4 Interim 3
32 ;;;
33 ;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
34 ;;;               1999 - 2004 Mark Kantrowitz and Marco Antoniotti. All
35 ;;;                           rights reserved.
37 ;;; Use, copying, modification, merging, publishing, distribution
38 ;;; and/or sale of this software, source and/or binary files and
39 ;;; associated documentation files (the "Software") and of derivative
40 ;;; works based upon this Software are permitted, as long as the
41 ;;; following conditions are met:
43 ;;;    o this copyright notice is included intact and is prominently
44 ;;;      visible in the Software
45 ;;;    o if modifications have been made to the source code of the
46 ;;;      this package that have not been adopted for inclusion in the
47 ;;;      official version of the Software as maintained by the Copyright
48 ;;;      holders, then the modified package MUST CLEARLY identify that
49 ;;;      such package is a non-standard and non-official version of
50 ;;;      the Software.  Furthermore, it is strongly encouraged that any
51 ;;;      modifications made to the Software be sent via e-mail to the
52 ;;;      MK-DEFSYSTEM maintainers for consideration of inclusion in the
53 ;;;      official MK-DEFSYSTEM package.
55 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
56 ;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
57 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT.
58 ;;; IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY
59 ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
60 ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
61 ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
63 ;;; Except as contained in this notice, the names of M. Kantrowitz and
64 ;;; M. Antoniotti shall not be used in advertising or otherwise to promote
65 ;;; the sale, use or other dealings in this Software without prior written
66 ;;; authorization from M. Kantrowitz and M. Antoniotti.
69 ;;; Please send bug reports, comments and suggestions to <marcoxa@cons.org>.
71 ;;; ********************************
72 ;;; Change Log *********************
73 ;;; ********************************
74 ;;;
75 ;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in
76 ;;; September and October 1990, but not documented until January 1991.
77 ;;;
78 ;;; akd  = Abdel Kader Diagne <diagne@dfki.uni-sb.de>
79 ;;; as   = Andreas Stolcke <stolcke@ICSI.Berkeley.EDU>
80 ;;; bha  = Brian Anderson <bha@atc.boeing.com>
81 ;;; brad = Brad Miller <miller@cs.rochester.edu>
82 ;;; bw   = Robert Wilhelm <wilhelm@rpal.rockwell.com>
83 ;;; djc  = Daniel J. Clancy <clancy@cs.utexas.edu>
84 ;;; fdmm = Fernando D. Mato Mira <matomira@di.epfl.ch>
85 ;;; gc   = Guillaume Cartier <cartier@math.uqam.ca>
86 ;;; gi   = Gabriel Inaebnit <inaebnit@research.abb.ch>
87 ;;; gpw  = George Williams <george@hsvaic.boeing.com>
88 ;;; hkt  = Rick Taube <hkt@cm-next-8.stanford.edu>
89 ;;; ik   = Ik Su Yoo <ik@ctt.bellcore.com>
90 ;;; jk   = John_Kolojejchick@MORK.CIMDS.RI.CMU.EDU
91 ;;; kt   = Kevin Thompson <kthompso@ptolemy.arc.nasa.gov>
92 ;;; kc   = Kaelin Colclasure <kaelin@bridge.com>
93 ;;; kmr  = Kevin M. Rosenberg <kevin@rosenberg.net>
94 ;;; lmh  = Liam M. Healy <Liam.Healy@nrl.navy.mil>
95 ;;; mc   = Matthew Cornell <cornell@unix1.cs.umass.edu>
96 ;;; oc   = Oliver Christ <oli@adler.ims.uni-stuttgart.de>
97 ;;; rs   = Ralph P. Sobek <ralph@vega.laas.fr>
98 ;;; rs2  = Richard Segal <segal@cs.washington.edu>
99 ;;; sb   = Sean Boisen <sboisen@bbn.com>
100 ;;; ss   = Steve Strassman <straz@cambridge.apple.com>
101 ;;; tar  = Thomas A. Russ <tar@isi.edu>
102 ;;; toni = Anton Beschta <toni%l4@ztivax.siemens.com>
103 ;;; yc   = Yang Chen <yangchen%iris.usc.edu@usc.edu>
105 ;;; Thanks to Steve Strassmann <straz@media-lab.media.mit.edu> and
106 ;;; Sean Boisen <sboisen@BBN.COM> for detailed bug reports and
107 ;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit
108 ;;; <inaebnit@research.abb.ch> for help with VAXLisp bugs.
110 ;;; 05-NOV-90  hkt  Changed canonicalize-system-name to make system
111 ;;;                 names package independent. Interns them in the
112 ;;;                 keyword package. Thus either strings or symbols may
113 ;;;                 be used to name systems from the user's point of view.
114 ;;; 05-NOV-90  hkt  Added definition FIND-SYSTEM to allow OOS to
115 ;;;                 work on systems whose definition hasn't been loaded yet.
116 ;;; 05-NOV-90  hkt  Added definitions COMPILE-SYSTEM and LOAD-SYSTEM
117 ;;;                 as alternates to OOS for naive users.
118 ;;; 05-NOV-90  hkt  Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT]
119 ;;;                 into USER package instead of import.
120 ;;; 15-NOV-90  mk   Changed package name to "MAKE", eliminating "DEFSYSTEM"
121 ;;;                 to avoid conflicts with allegro, symbolics packages
122 ;;;                 named "DEFSYSTEM".
123 ;;; 30-JAN-91  mk   Modified append-directories to work with the
124 ;;;                 logical-pathnames system.
125 ;;; 30-JAN-91  mk   Append-directories now works with Sun CL4.0. Also, fixed
126 ;;;                 bug wrt Lucid 4.0's pathnames (which changed from lcl3.0
127 ;;;                 -- 4.0 uses a list for the directory slot, whereas
128 ;;;                 3.0 required a string). Possible fix to symbolics bug.
129 ;;; 30-JAN-91  mk   Defined NEW-REQUIRE to make redefinition of REQUIRE
130 ;;;                 cleaner. Replaced all calls to REQUIRE in this file with
131 ;;;                 calls to NEW-REQUIRE, which should avoid compiler warnings.
132 ;;; 30-JAN-91  mk   In VAXLisp, when we redefine lisp:require, the compiler
133 ;;;                 no longer automatically executes require forms when it
134 ;;;                 encounters them in a file. The user can always wrap an
135 ;;;                 (eval-when (compile load eval) ...) around the require
136 ;;;                 form. Alternately, see commented out code near the
137 ;;;                 redefinition of lisp:require which redefines it as a
138 ;;;                 macro instead.
139 ;;; 30-JAN-91  mk   Added parameter :version to operate-on-system. If it is
140 ;;;                 a number, that number is used as part of the binary
141 ;;;                 directory name as the place to store and load files.
142 ;;;                 If NIL (the default), uses regular binary directory.
143 ;;;                 If T, tries to find the most recent version of the
144 ;;;                 binary directory.
145 ;;; 30-JAN-91  mk   Added global variable *use-timeouts* (default: t), which
146 ;;;                 specifies whether timeouts should be used in
147 ;;;                 Y-OR-N-P-WAIT. This is provided for users whose lisps
148 ;;;                 don't handle read-char-no-hang properly, so that they
149 ;;;                 can set it to NIL to disable the timeouts. Usually the
150 ;;;                 reason for this is the lisp is run on top of UNIX,
151 ;;;                 which buffers input LINES (and provides input editing).
152 ;;;                 To get around this we could always turn CBREAK mode
153 ;;;                 on and off, but there's no way to do this in a portable
154 ;;;                 manner.
155 ;;; 30-JAN-91  mk   Fixed bug where in :test t mode it was actually providing
156 ;;;                 the system, instead of faking it.
157 ;;; 30-JAN-91  mk   Changed storage of system definitions to a hash table.
158 ;;;                 Changed canonicalize-system-name to coerce the system
159 ;;;                 names to uppercase strings. Since we're no longer using
160 ;;;                 get, there's no need to intern the names as symbols,
161 ;;;                 and strings don't have packages to cause problems.
162 ;;;                 Added UNDEFSYSTEM, DEFINED-SYSTEMS, and DESCRIBE-SYSTEM.
163 ;;;                 Added :delete-binaries command.
164 ;;; 31-JAN-91  mk   Franz Allegro CL has a defsystem in the USER package,
165 ;;;                 so we need to do a shadowing import to avoid name
166 ;;;                 conflicts.
167 ;;; 31-JAN-91  mk   Fixed bug in compile-and-load-operation where it was
168 ;;;                 only loading newly compiled files.
169 ;;; 31-JAN-91  mk   Added :load-time slot to components to record the
170 ;;;                 file-write-date of the binary/source file that was loaded.
171 ;;;                 Now knows "when" (which date version) the file was loaded.
172 ;;;                 Added keyword :minimal-load and global *minimal-load*
173 ;;;                 to enable defsystem to avoid reloading unmodified files.
174 ;;;                 Note that if B depends on A, but A is up to date and
175 ;;;                 loaded and the user specified :minimal-load T, then A
176 ;;;                 will not be loaded even if B needs to be compiled. So
177 ;;;                 if A is an initializations file, say, then the user should
178 ;;;                 not specify :minimal-load T.
179 ;;; 31-JAN-91  mk   Added :load-only slot to components. If this slot is
180 ;;;                 specified as non-NIL, skips over any attempts to compile
181 ;;;                 the files in the component. (Loading the file satisfies
182 ;;;                 the need to recompile.)
183 ;;; 31-JAN-91  mk   Eliminated use of set-alist-lookup and alist-lookup,
184 ;;;                 replacing it with hash tables. It was too much bother,
185 ;;;                 and rather brittle too.
186 ;;; 31-JAN-91  mk   Defined #@ macro character for use with AFS @sys
187 ;;;                 feature simulator. #@"directory" is then synonymous
188 ;;;                 with (afs-binary-directory "directory").
189 ;;; 31-JAN-91  mk   Added :private-file type of module. It is similar to
190 ;;;                 :file, but has an absolute pathname. This allows you
191 ;;;                 to specify a different version of a file in a system
192 ;;;                 (e.g., if you're working on the file in your home
193 ;;;                 directory) without completely rewriting the system
194 ;;;                 definition.
195 ;;; 31-JAN-91  mk   Operations on systems, such as :compile and :load,
196 ;;;                 now propagate to subsystems the system depends on
197 ;;;                 if *operations-propagate-to-subsystems* is T (the default)
198 ;;;                 and the systems were defined using either defsystem
199 ;;;                 or as a :system component of another system. Thus if
200 ;;;                 a system depends on another, it can now recompile the
201 ;;;                 other.
202 ;;; 01-FEB-91  mk   Added default definitions of PROVIDE/REQUIRE/*MODULES*
203 ;;;                 for lisps that have thrown away these definitions in
204 ;;;                 accordance with CLtL2.
205 ;;; 01-FEB-91  mk   Added :compile-only slot to components. Analogous to
206 ;;;                 :load-only. If :compile-only is T, will not load the
207 ;;;                 file on operation :compile. Either compiles or loads
208 ;;;                 the file, but not both. In other words, compiling the
209 ;;;                 file satisfies the demand to load it. This is useful
210 ;;;                 for PCL defmethod and defclass definitions, which wrap
211 ;;;                 an (eval-when (compile load eval) ...) around the body
212 ;;;                 of the definition -- we save time by not loading the
213 ;;;                 compiled code, since the eval-when forces it to be
214 ;;;                 loaded. Note that this may not be entirely safe, since
215 ;;;                 CLtL2 has added a :load keyword to compile-file, and
216 ;;;                 some lisps may maintain a separate environment for
217 ;;;                 the compiler. This feature is for the person who asked
218 ;;;                 that a :COMPILE-SATISFIES-LOAD keyword be added to
219 ;;;                 modules. It's named :COMPILE-ONLY instead to match
220 ;;;                 :LOAD-ONLY.
221 ;;; 11-FEB-91  mk   Now adds :mk-defsystem to features list, to allow
222 ;;;                 special cased loading of defsystem if not already
223 ;;;                 present.
224 ;;; 19-FEB-91  duff Added filename extension for hp9000/300's running Lucid.
225 ;;; 26-FEB-91  mk   Distinguish between toplevel systems (defined with
226 ;;;                 defsystem) and systems defined as a :system module
227 ;;;                 of a defsystem. The former can depend only on systems,
228 ;;;                 while the latter can depend on anything at the same
229 ;;;                 level.
230 ;;; 12-MAR-91  mk   Added :subsystem component type to be a system with
231 ;;;                 pathnames relative to its parent component.
232 ;;; 12-MAR-91  mk   Uncommented :device :absolute for CMU pathnames, so
233 ;;;                 that the leading slash is included.
234 ;;; 12-MAR-91  brad Patches for Allegro 4.0.1 on Sparc.
235 ;;; 12-MAR-91  mk   Changed definition of format-justified-string so that
236 ;;;                 it no longer depends on the ~<~> format directives,
237 ;;;                 because Allegro 4.0.1 has a bug which doesn't support
238 ;;;                 them. Anyway, the new definition is twice as fast
239 ;;;                 and conses half as much as FORMAT.
240 ;;; 12-MAR-91 toni  Remove nils from list in expand-component-components.
241 ;;; 12-MAR-91 bw    If the default-package and system have the same name,
242 ;;;                 and the package is not loaded, this could lead to
243 ;;;                 infinite loops, so we bomb out with an error.
244 ;;;                 Fixed bug in default packages.
245 ;;; 13-MAR-91 mk    Added global *providing-blocks-load-propagation* to
246 ;;;                 control whether system dependencies are loaded if they
247 ;;;                 have already been provided.
248 ;;; 13-MAR-91 brad  In-package is a macro in CLtL2 lisps, so we change
249 ;;;                 the package manually in operate-on-component.
250 ;;; 15-MAR-91 mk    Modified *central-registry* to be either a single
251 ;;;                 directory pathname, or a list of directory pathnames
252 ;;;                 to be checked in order.
253 ;;; 15-MAR-91 rs    Added afs-source-directory to handle versions when
254 ;;;                 compiling C code under lisp. Other minor changes to
255 ;;;                 translate-version and operate-on-system.
256 ;;; 21-MAR-91 gi    Fixed bug in defined-systems.
257 ;;; 22-MAR-91 mk    Replaced append-directories with new version that works
258 ;;;                 by actually appending the directories, after massaging
259 ;;;                 them into the proper format. This should work for all
260 ;;;                 CLtL2-compliant lisps.
261 ;;; 09-APR-91 djc   Missing package prefix for lp:pathname-host-type.
262 ;;;                 Modified component-full-pathname to work for logical
263 ;;;                 pathnames.
264 ;;; 09-APR-91 mk    Added *dont-redefine-require* to control whether
265 ;;;                 REQUIRE is redefined. Fixed minor bugs in redefinition
266 ;;;                 of require.
267 ;;; 12-APR-91 mk    (pathname-host nil) causes an error in MCL 2.0b1
268 ;;; 12-APR-91 mc    Ported to MCL2.0b1.
269 ;;; 16-APR-91 mk    Fixed bug in needs-loading where load-time and
270 ;;;                 file-write-date got swapped.
271 ;;; 16-APR-91 mk    If the component is load-only, defsystem shouldn't
272 ;;;                 tell you that there is no binary and ask you if you
273 ;;;                 want to load the source.
274 ;;; 17-APR-91 mc    Two additional operations for MCL.
275 ;;; 21-APR-91 mk    Added feature requested by ik. *files-missing-is-an-error*
276 ;;;                 new global variable which controls whether files (source
277 ;;;                 and binary) missing cause a continuable error or just a
278 ;;;                 warning.
279 ;;; 21-APR-91 mk    Modified load-file-operation to allow compilation of source
280 ;;;                 files during load if the binary files are old or
281 ;;;                 non-existent. This adds a :compile-during-load keyword to
282 ;;;                 oos, and load-system. Global *compile-during-load* sets
283 ;;;                 the default (currently :query).
284 ;;; 21-APR-91 mk    Modified find-system so that there is a preference for
285 ;;;                 loading system files from disk, even if the system is
286 ;;;                 already defined in the environment.
287 ;;; 25-APR-91 mk    Removed load-time slot from component defstruct and added
288 ;;;                 function COMPONENT-LOAD-TIME to store the load times in a
289 ;;;                 hash table. This is safer than the old definition because
290 ;;;                 it doesn't wipe out load times every time the system is
291 ;;;                 redefined.
292 ;;; 25-APR-91 mk    Completely rewrote load-file-operation. Fixed some bugs
293 ;;;                 in :compile-during-load and in the behavior of defsystem
294 ;;;                 when multiple users are compiling and loading a system
295 ;;;                 instead of just a single user.
296 ;;; 16-MAY-91 mk    Modified FIND-SYSTEM to do the right thing if the system
297 ;;;                 definition file cannot be found.
298 ;;; 16-MAY-91 mk    Added globals *source-pathname-default* and
299 ;;;                 *binary-pathname-default* to contain default values for
300 ;;;                 :source-pathname and :binary-pathname. For example, set
301 ;;;                 *source-pathname-default* to "" to avoid having to type
302 ;;;                 :source-pathname "" all the time.
303 ;;; 27-MAY-91 mk    Fixed bug in new-append-directories where directory
304 ;;;                 components of the form "foo4.0" would appear as "foo4",
305 ;;;                 since pathname-name truncates the type. Changed
306 ;;;                 pathname-name to file-namestring.
307 ;;;  3-JUN-91 gc    Small bug in new-append-directories; replace (when
308 ;;;                 abs-name) with (when (not (null-string abs-name)))
309 ;;;  4-JUN-91 mk    Additional small change to new-append-directories for
310 ;;;                 getting the device from the relative pname if the abs
311 ;;;                 pname is "". This is to fix a small behavior in CMU CL old
312 ;;;                 compiler. Also changed (when (not (null-string abs-name)))
313 ;;;                 to have an (and abs-name) in there.
314 ;;;  8-JAN-92 sb    Added filename extension for defsystem under Lucid Common
315 ;;;                 Lisp/SGO 3.0.1+.
316 ;;;  8-JAN-92 mk    Changed the definition of prompt-string to work around an
317 ;;;                 AKCL bug. Essentially, AKCL doesn't default the colinc to
318 ;;;                 1 if the colnum is provided, so we hard code it.
319 ;;;  8-JAN-92 rs    (pathname-directory (pathname "")) returns '(:relative) in
320 ;;;                 Lucid, instead of NIL. Changed new-append-directories and
321 ;;;                 test-new-append-directories to reflect this.
322 ;;;  8-JAN-92 mk    Fixed problem related to *load-source-if-no-binary*.
323 ;;;                 compile-and-load-source-if-no-binary wasn't checking for
324 ;;;                 the existence of the binary if this variable was true,
325 ;;;                 causing the file to not be compiled.
326 ;;;  8-JAN-92 mk    Fixed problem with null-string being called on a pathname
327 ;;;                 by returning NIL if the argument isn't a string.
328 ;;;  3-NOV-93 mk    In Allegro 4.2, pathname device is :unspecific by default.
329 ;;; 11-NOV-93 fdmm  Fixed package definition lock problem when redefining
330 ;;;                 REQUIRE on ACL.
331 ;;; 11-NOV-93 fdmm  Added machine and software types for SGI and IRIX. It is
332 ;;;                 important to distinguish the OS version and CPU type in
333 ;;;                 SGI+ACL, since ACL 4.1 on IRIX 4.x and ACL 4.2 on IRIX 5.x
334 ;;;                 have incompatible .fasl files.
335 ;;; 01-APR-94 fdmm  Fixed warning problem when redefining REQUIRE on LispWorks.
336 ;;; 01-NOV-94 fdmm  Replaced (software-type) call in ACL by code extracting
337 ;;;                 the interesting parts from (software-version) [deleted
338 ;;;                 machine name and id].
339 ;;; 03-NOV-94 fdmm  Added a hook (*compile-file-function*), that is funcalled
340 ;;;                 by compile-file-operation, so as to support other languages
341 ;;;                 running on top of Common Lisp.
342 ;;;                 The default is to compile  Common Lisp.
343 ;;; 03-NOV-94 fdmm  Added SCHEME-COMPILE-FILE, so that defsystem can now
344 ;;;                 compile Pseudoscheme files.
345 ;;; 04-NOV-94 fdmm  Added the exported generic function SET-LANGUAGE, to
346 ;;;                 have a clean, easy to extend  interface for telling
347 ;;;                 defsystem which language to assume for compilation.
348 ;;;                 Currently supported arguments: :common-lisp, :scheme.
349 ;;; 11-NOV-94 kc    Ported to Allegro CL for Windows 2.0 (ACLPC) and CLISP.
350 ;;; 18-NOV-94 fdmm  Changed the entry *filename-extensions* for LispWorks
351 ;;;                 to support any platform.
352 ;;;                 Added entries for :mcl and :clisp too.
353 ;;; 16-DEC-94 fdmm  Added and entry for CMU CL on SGI to *filename-extensions*.
354 ;;; 16-DEC-94 fdmm  Added OS version identification for CMU CL on SGI.
355 ;;; 16-DEC-94 fdmm  For CMU CL 17 : Bypassed make-pathnames call fix
356 ;;;                 in NEW-APPEND-DIRECTORIES.
357 ;;; 16-DEC-94 fdmm  Added HOME-SUBDIRECTORY to fix CMU's ignorance about `~'
358 ;;;                 when specifying registries.
359 ;;; 16-DEC-94 fdmm  For CMU CL 17 : Bypassed :device fix in make-pathnames call
360 ;;;                 in COMPONENT-FULL-PATHNAME. This fix was also reported
361 ;;;                 by kc on 12-NOV-94. CMU CL 17 now supports CLtL2 pathnames.
362 ;;; 16-DEC-94 fdmm  Removed a quote before the call to read in the readmacro
363 ;;;                 #@. This fixes a really annoying misfeature (couldn't do
364 ;;;                 #@(concatenate 'string "foo/" "bar"), for example).
365 ;;; 03-JAN-95 fdmm  Do not include :pcl in *features* if :clos is there.
366 ;;;  2-MAR-95 mk    Modified fdmm's *central-registry* change to use
367 ;;;                 user-homedir-pathname and to be a bit more generic in the
368 ;;;                 pathnames.
369 ;;;  2-MAR-95 mk    Modified fdmm's updates to *filename-extensions* to handle
370 ;;;                 any CMU CL binary extensions.
371 ;;;  2-MAR-95 mk    Make kc's port to ACLPC a little more generic.
372 ;;;  2-MAR-95 mk    djc reported a bug, in which GET-SYSTEM was not returning
373 ;;;                 a system despite the system's just having been loaded.
374 ;;;                 The system name specified in the :depends-on was a
375 ;;;                 lowercase string. I am assuming that the system name
376 ;;;                 in the defsystem form was a symbol (I haven't verified
377 ;;;                 that this was the case with djc, but it is the only
378 ;;;                 reasonable conclusion). So, CANONICALIZE-SYSTEM-NAME
379 ;;;                 was storing the system in the hash table as an
380 ;;;                 uppercase string, but attempting to retrieve it as a
381 ;;;                 lowercase string. This behavior actually isn't a bug,
382 ;;;                 but a user error. It was intended as a feature to
383 ;;;                 allow users to use strings for system names when
384 ;;;                 they wanted to distinguish between two different systems
385 ;;;                 named "foo.system" and "Foo.system". However, this
386 ;;;                 user error indicates that this was a bad design decision.
387 ;;;                 Accordingly, CANONICALIZE-SYSTEM-NAME now uppercases
388 ;;;                 even strings for retrieving systems, and the comparison
389 ;;;                 in *modules* is now case-insensitive. The result of
390 ;;;                 this change is if the user cannot have distinct
391 ;;;                 systems in "Foo.system" and "foo.system" named "Foo" and
392 ;;;                 "foo", because they will clobber each other. There is
393 ;;;                 still case-sensitivity on the filenames (i.e., if the
394 ;;;                 system file is named "Foo.system" and you use "foo" in
395 ;;;                 the :depends-on, it won't find it). We didn't take the
396 ;;;                 further step of requiring system filenames to be lowercase
397 ;;;                 because we actually find this kind of case-sensitivity
398 ;;;                 to be useful, when maintaining two different versions
399 ;;;                 of the same system.
400 ;;;  7-MAR-95 mk    Added simplistic handling of logical pathnames. Also
401 ;;;                 modified new-append-directories so that it'll try to
402 ;;;                 split up pathname directories that are strings into a
403 ;;;                 list of the directory components. Such directories aren't
404 ;;;                 ANSI CL, but some non-conforming implementations do it.
405 ;;;  7-MAR-95 mk    Added :proclamations to defsystem form, which can be used
406 ;;;                 to set the compiler optimization level before compilation.
407 ;;;                 For example,
408 ;;;                  :proclamations '(optimize (safety 3) (speed 3) (space 0))
409 ;;;  7-MAR-95 mk    Defsystem now tells the user when it reloads the system
410 ;;;                 definition.
411 ;;;  7-MAR-95 mk    Fixed problem pointed out by yc. If
412 ;;;                 *source-pathname-default* is "" and there is no explicit
413 ;;;                 :source-pathname specified for a file, the file could
414 ;;;                 wind up with an empty file name. In other words, this
415 ;;;                 global default shouldn't apply to :file components. Added
416 ;;;                 explicit test for null strings, and when present replaced
417 ;;;                 them with NIL (for binary as well as source, and also for
418 ;;;                 :private-file components).
419 ;;;  7-MAR-95 tar   Fixed defsystem to work on TI Explorers (TI CL).
420 ;;;  7-MAR-95 jk    Added machine-type-translation for Decstation 5000/200
421 ;;;                 under Allegro 3.1
422 ;;;  7-MAR-95 as    Fixed bug in AKCL-1-615 in which defsystem added a
423 ;;;                 subdirectory "RELATIVE" to all filenames.
424 ;;;  7-MAR-95 mk    Added new test to test-new-append-directories to catch the
425 ;;;                 error fixed by as. Essentially, this error occurs when the
426 ;;;                 absolute-pathname has no directory (i.e., it has a single
427 ;;;                 pathname component as in "foo" and not "foo/bar"). If
428 ;;;                 RELATIVE ever shows up in the Result, we now know to
429 ;;;                 add an extra conditionalization to prevent abs-keyword
430 ;;;                 from being set to :relative.
431 ;;;  7-MAR-95 ss    Miscellaneous fixes for MCL 2.0 final.
432 ;;;                 *compile-file-verbose* not in MCL, *version variables
433 ;;;                 need to occur before AFS-SOURCE-DIRECTORY definition,
434 ;;;                 and certain code needed to be in the CCL: package.
435 ;;;  8-MAR-95 mk    Y-OR-N-P-WAIT uses a busy-waiting. On Lisp systems where
436 ;;;                 the time functions cons, such as CMU CL, this can cause a
437 ;;;                 lot of ugly garbage collection messages. Modified the
438 ;;;                 waiting to include calls to SLEEP, which should reduce
439 ;;;                 some of the consing.
440 ;;;  8-MAR-95 mk    Replaced fdmm's SET-LANGUAGE enhancement with a more
441 ;;;                 general extension, along the lines suggested by akd.
442 ;;;                 Defsystem now allows components to specify a :language
443 ;;;                 slot, such as :language :lisp, :language :scheme. This
444 ;;;                 slot is inherited (with the default being :lisp), and is
445 ;;;                 used to obtain compilation and loading functions for
446 ;;;                 components, as well as source and binary extensions. The
447 ;;;                 compilation and loading functions can be overridden by
448 ;;;                 specifying a :compiler or :loader in the system
449 ;;;                 definition. Also added :documentation slot to the system
450 ;;;                 definition.
451 ;;;                    Where this comes in real handy is if one has a
452 ;;;                 compiler-compiler implemented in Lisp, and wants the
453 ;;;                 system to use the compiler-compiler to create a parser
454 ;;;                 from a grammar and then compile parser. To do this one
455 ;;;                 would create a module with components that looked
456 ;;;                 something like this:
457 ;;;               ((:module cc :components ("compiler-compiler"))
458 ;;;                (:module gr :compiler 'cc :loader #'ignore
459 ;;;                         :source-extension "gra"
460 ;;;                         :binary-extension "lisp"
461 ;;;                         :depends-on (cc)
462 ;;;                         :components ("sample-grammar"))
463 ;;;                (:module parser :depends-on (gr)
464 ;;;                         :components ("sample-grammar")))
465 ;;;                 Defsystem would then compile and load the compiler, use
466 ;;;                 it (the function cc) to compile the grammar into a parser,
467 ;;;                 and then compile the parser. The only tricky part is
468 ;;;                 cc is defined by the system, and one can't include #'cc
469 ;;;                 in the system definition. However, one could include
470 ;;;                 a call to mk:define-language in the compiler-compiler file,
471 ;;;                 and define :cc as a language. This is the prefered method.
472 ;;;  8-MAR-95 mk    New definition of topological-sort suggested by rs2. This
473 ;;;                 version avoids the call to SORT, but in practice isn't
474 ;;;                 much faster. However, it avoids the need to maintain a
475 ;;;                 TIME slot in the topsort-node structure.
476 ;;;  8-MAR-95 mk    rs2 also pointed out that the calls to MAKE-PATHNAME and
477 ;;;                 NAMESTRING in COMPONENT-FULL-PATHNAME are a major reason
478 ;;;                 why defsystem is slow. Accordingly, I've changed
479 ;;;                 COMPONENT-FULL-PATHNAME to include a call to NAMESTRING
480 ;;;                 (and removed all other calls to NAMESTRING), and also made
481 ;;;                 a few changes to minimize the number of calls to
482 ;;;                 COMPONENT-FULL-PATHNAME, such as memoizing it. See To Do
483 ;;;                 below for other related comments.
484 ;;;  8-MAR-95 mk    Added special hack requested by Steve Strassman, which
485 ;;;                 allows one to specify absolute pathnames in the shorthand
486 ;;;                 for a list of components, and have defsystem recognize
487 ;;;                 which are absolute and which are relative.
488 ;;;                 I actually think this would be a good idea, but I haven't
489 ;;;                 tested it, so it is disabled by default. Search for
490 ;;;                 *enable-straz-absolute-string-hack* to enable it.
491 ;;;  8-MAR-95 kt    Fixed problem with EXPORT in AKCL 1.603, in which it wasn't
492 ;;;                 properly exporting the value of the global export
493 ;;;                 variables.
494 ;;;  8-MAR-95 mk    Added UNMUNGE-LUCID to fix nasty problem with COMPILE-FILE
495 ;;;                 in Lucid. Lucid apparently tries to merge the :output-file
496 ;;;                 with the source file when the :output-file is a relative
497 ;;;                 pathname. Wierd, and definitely non-standard.
498 ;;;  9-MAR-95 mk    Changed ALLEGRO-MAKE-SYSTEM-FASL to also include the files
499 ;;;                 in any systems the system depends on, as per a
500 ;;;                 request of oc.
501 ;;;  9-MAR-95 mk    Some version of CMU CL couldn't hack a call to
502 ;;;                 MAKE-PATHNAME with :host NIL. I'm not sure which version
503 ;;;                 it is, but the current version doesn't have this problem.
504 ;;;                 If given :host nil, it defaults the host to
505 ;;;                 COMMON-LISP::*UNIX-HOST*. So I haven't "fixed" this
506 ;;;                 problem.
507 ;;;  9-MAR-95 mk    Integrated top-level commands for Allegro designed by bha
508 ;;;                 into the code, with slight modifications.
509 ;;;  9-MAR-95 mk    Instead of having COMPUTE-SYSTEM-PATH check the current
510 ;;;                 directory in a hard-coded fashion, include the current
511 ;;;                 directory in the *central-registry*, as suggested by
512 ;;;                 bha and others.
513 ;;;  9-MAR-95 bha   Support for Logical Pathnames in Allegro.
514 ;;;  9-MAR-95 mk    Added modified version of bha's DEFSYSPATH idea.
515 ;;; 13-MAR-95 mk    Added a macro for the simple serial case, where a system
516 ;;;                 (or module) is simple a list of files, each of which
517 ;;;                 depends on the previous one. If the value of :components
518 ;;;                 is a list beginning with :serial, it expands each
519 ;;;                 component and makes it depend on the previous component.
520 ;;;                 For example, (:serial "foo" "bar" "baz") would create a
521 ;;;                 set of components where "baz" depended on "bar" and "bar"
522 ;;;                 on "foo".
523 ;;; 13-MAR-95 mk    *** Now version 3.0. This version is a interim bug-fix and
524 ;;;                 update, since I do not have the time right now to complete
525 ;;;                 the complete overhaul and redesign.
526 ;;;                 Major changes in 3.0 include CMU CL 17, CLISP, ACLPC, TI,
527 ;;;                 LispWorks and ACL(SGI) support, bug fixes for ACL 4.1/4.2.
528 ;;; 14-MAR-95 fdmm  Finally added the bit of code to discriminate cleanly
529 ;;;                 among different lisps without relying on (software-version)
530 ;;;                 idiosyncracies.
531 ;;;                 You can now customize COMPILER-TYPE-TRANSLATION so that
532 ;;;                 AFS-BINARY-DIRECTORY can return a different value for
533 ;;;                 different lisps on the same platform.
534 ;;;                 If you use only one compiler, do not care about supporting
535 ;;;                 code for multiple versions of it, and want less verbose
536 ;;;                 directory names, just set *MULTIPLE-LISP-SUPPORT* to nil.
537 ;;; 17-MAR-95 lmh   Added EVAL-WHEN for one of the MAKE-PACKAGE calls.
538 ;;;                 CMU CL's RUN-PROGRAM is in the extensions package.
539 ;;;                 ABSOLUTE-FILE-NAMESTRING-P was missing :test keyword
540 ;;;                 Rearranged conditionalization in DIRECTORY-TO-LIST to
541 ;;;                 suppress compiler warnings in CMU CL.
542 ;;; 17-MAR-95 mk    Added conditionalizations to avoid certain CMU CL compiler
543 ;;;                 warnings reported by lmh.
544 ;;; 19990610  ma    Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed.
546 ;;; 19991211  ma    NEW VERSION 4.0 started.
547 ;;; 19991211  ma    Merged in changes requested by T. Russ of
548 ;;;                 ISI. Please refer to the special "ISI" comments to
549 ;;;                 understand these changes
550 ;;; 20000228 ma     The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM,
551 ;;;                 COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer
552 ;;;                 imported in the COMMON-LISP-USER package.
553 ;;;                 Cfr. the definitions of *EXPORTS* and
554 ;;;                 *SPECIAL-EXPORTS*.
555 ;;; 2000-07-21 rlt  Add COMPILER-OPTIONS to defstruct to allow user to
556 ;;;                 specify special compiler options for a particular
557 ;;;                 component.
558 ;;; 2002-01-08 kmr  Changed allegro symbols to lowercase to support
559 ;;;                 case-sensitive images
561 ;;;---------------------------------------------------------------------------
562 ;;; ISI Comments
564 ;;; 19991211 Marco Antoniotti
565 ;;; These comments come from the "ISI Branch".  I believe I did
566 ;;; include the :load-always extension correctly.  The other commets
567 ;;; seem superseded by other changes made to the system in the
568 ;;; following years.  Some others are now useless with newer systems
569 ;;; (e.g. filename truncation for new Windows based CL
570 ;;; implementations.)
572 ;;;  1-OCT-92 tar   Fixed problem with TI Lisp machines and append-directory.
573 ;;;  1-OCT-92 tar   Made major modifications to compile-file-operation and
574 ;;;                 load-file-operation to reduce the number of probe-file
575 ;;;                 and write-date inquiries.  This makes the system run much
576 ;;;                 faster through slow network connections.
577 ;;; 13-OCT-92 tar   Added :load-always slot to components. If this slot is
578 ;;;                 specified as non-NIL, always loads the component.
579 ;;;                 This does not trigger dependent compilation.
580 ;;;                 (This can be useful when macro definitions needed
581 ;;;                 during compilation are changed by later files.  In
582 ;;;                 this case, not reloading up-to-date files can
583 ;;;                 cause different results.)
584 ;;; 28-OCT-93 tar   Allegro 4.2 causes an error on (pathname-device nil)
585 ;;; 14-SEP-94 tar   Disable importing of symbols into (CL-)USER package
586 ;;;                 to minimize conflicts with other defsystem utilities.
587 ;;; 10-NOV-94 tar   Added filename truncation code to support Franz Allegro
588 ;;;                 PC with it's 8 character filename limitation.
589 ;;; 15-MAY-98 tar   Changed host attribute for pathnames to support LispWorks
590 ;;;                 (Windows) pathnames which reference other Drives.  Also
591 ;;;                 updated file name convention.
592 ;;;  9-NOV-98 tar   Updated new-append-directories for Lucid 5.0
596 ;;; ********************************
597 ;;; Ports **************************
598 ;;; ********************************
600 ;;;    DEFSYSTEM has been tested (successfully) in the following lisps:
601 ;;;       CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
602 ;;;       CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach)
603 ;;;       CMU Common Lisp 17f (Python 1.0)
604 ;;;       Franz Allegro Common Lisp 3.1.12 (ExCL 3/30/90)
605 ;;;       Franz Allegro Common Lisp 4.0/4.1/4.2
606 ;;;       Franz Allegro Common Lisp for Windows (2.0)
607 ;;;       Lucid Common Lisp (Version 2.1 6-DEC-87)
608 ;;;       Lucid Common Lisp (3.0 [SPARC,SUN3])
609 ;;;       Lucid Common Lisp (4.0 [SPARC,SUN3])
610 ;;;       VAXLisp (v2.2) [VAX/VMS]
611 ;;;       VAXLisp (v3.1)
612 ;;;       Harlequin LispWorks
613 ;;;       CLISP (CLISP3 [SPARC])
614 ;;;       Symbolics XL12000 (Genera 8.3)
615 ;;;       Scieneer Common Lisp (SCL) 1.1
616 ;;;       Macintosh Common Lisp
617 ;;;       ECL
619 ;;;    DEFSYSTEM needs to be tested in the following lisps:
620 ;;;       OpenMCL
621 ;;;       Symbolics Common Lisp (8.0)
622 ;;;       KCL (June 3, 1987 or later)
623 ;;;       AKCL (1.86, June 30, 1987 or later)
624 ;;;       TI (Release 4.1 or later)
625 ;;;       Ibuki Common Lisp (01/01, October 15, 1987)
626 ;;;       Golden Common Lisp (3.1 IBM-PC)
627 ;;;       HP Common Lisp (same as Lucid?)
628 ;;;       Procyon Common Lisp
630 ;;; ********************************
631 ;;; To Do **************************
632 ;;; ********************************
634 ;;; COMPONENT-FULL-PATHNAME is a major source of slowness in the system
635 ;;; because of all the calls to the expensive operations MAKE-PATHNAME
636 ;;; and NAMESTRING. To improve performance, DEFSYSTEM should be reworked
637 ;;; to avoid any need to call MAKE-PATHNAME and NAMESTRING, as the logical
638 ;;; pathnames package does. Unfortunately, I don't have the time to do this
639 ;;; right now. Instead, I installed a temporary improvement by memoizing
640 ;;; COMPONENT-FULL-PATHNAME to cache previous calls to the function on
641 ;;; a component by component and type by type basis. The cache is
642 ;;; cleared before each call to OOS, in case filename extensions change.
643 ;;; But DEFSYSTEM should really be reworked to avoid this problem and
644 ;;; ensure greater portability and to also handle logical pathnames.
646 ;;; Also, PROBE-FILE and FILE-WRITE-DATE are other sources of slowness.
647 ;;; Perhaps by also memoizing FILE-WRITE-DATE and reimplementing PROBE-FILE
648 ;;; in terms of FILE-WRITE-DATE, can achieve a further speed-up. This was
649 ;;; suggested by Steven Feist (feist@ils.nwu.edu).
651 ;;; True CLtL2 logical pathnames support -- can't do it, because CLtL2
652 ;;; doesn't have all the necessary primitives, and even in Allegro CL 4.2
653 ;;;   (namestring #l"foo:bar;baz.lisp")
654 ;;; does not work properly.
656 ;;; Create separate stand-alone documentation for defsystem, and also
657 ;;; a test suite.
659 ;;; Change SYSTEM to be a class instead of a struct, and make it a little
660 ;;; more generic, so that it permits alternate system definitions.
661 ;;; Replace OPERATE-ON-SYSTEM with MAP-SYSTEM (args: function, system-name,
662 ;;; &rest options)
664 ;;; Add a patch directory mechanism. Perhaps have several directories
665 ;;; with code in them, and the first one with the specified file wins?
666 ;;; LOAD-PATCHES function.
668 ;;; Need way to load old binaries even if source is newer.
670 ;;; Allow defpackage forms/package definitions in the defsystem? If
671 ;;; a package not defined, look for and load a file named package.pkg?
673 ;;; need to port for GNU CL (ala kcl)?
675 ;;; Someone asked whether one can have :file components at top-level. I believe
676 ;;; this is the case, but should double-check that it is possible (and if
677 ;;; not, make it so).
679 ;;; A common error/misconception seems to involve assuming that :system
680 ;;; components should include the name of the system file, and that
681 ;;; defsystem will automatically load the file containing the system
682 ;;; definition and propagate operations to it. Perhaps this would be a
683 ;;; nice feature to add.
685 ;;; If a module is :load-only t, then it should not execute its :finally-do
686 ;;; and :initially-do clauses during compilation operations, unless the
687 ;;; module's files happen to be loaded during the operation.
689 ;;; System Class. Customizable delimiters.
691 ;;; Load a system (while not loading anything already loaded)
692 ;;; and inform the user of out of date fasls with the choice
693 ;;; to load the old fasl or recompile and then load the new
694 ;;; fasl?
696 ;;; modify compile-file-operation to handle a query keyword....
698 ;;; Perhaps systems should keep around the file-write-date of the system
699 ;;; definition file, to prevent excessive reloading of the system definition?
701 ;;; load-file-operation needs to be completely reworked to simplify the
702 ;;; logic of when files get loaded or not.
704 ;;; Need to revamp output: Nesting and indenting verbose output doesn't
705 ;;; seem cool, especially when output overflows the 80-column margins.
707 ;;; Document various ways of writing a system. simple (short) form
708 ;;; (where :components is just a list of filenames) in addition to verbose.
709 ;;; Put documentation strings in code.
711 ;;; :load-time for modules and systems -- maybe record the time the system
712 ;;; was loaded/compiled here and print it in describe-system?
714 ;;; Make it easy to define new functions that operate on a system. For
715 ;;; example, a function that prints out a list of files that have changed,
716 ;;; hardcopy-system, edit-system, etc.
718 ;;; If a user wants to have identical systems for different lisps, do we
719 ;;; force the user to use logical pathnames? Or maybe we should write a
720 ;;; generic-pathnames package that parses any pathname format into a
721 ;;; uniform underlying format (i.e., pull the relevant code out of
722 ;;; logical-pathnames.lisp and clean it up a bit).
724 ;;;    Verify that Mac pathnames now work with append-directories.
726 ;;; A common human error is to violate the modularization by making a file
727 ;;; in one module depend on a file in another module, instead of making
728 ;;; one module depend on the other. This is caught because the dependency
729 ;;; isn't found. However, is there any way to provide a more informative
730 ;;; error message? Probably not, especially if the system has multiple
731 ;;; files of the same name.
733 ;;; For a module none of whose files needed to be compiled, have it print out
734 ;;; "no files need recompilation".
736 ;;; Write a system date/time to a file? (version information) I.e., if the
737 ;;; filesystem supports file version numbers, write an auxiliary file to
738 ;;; the system definition file that specifies versions of the system and
739 ;;; the version numbers of the associated files.
741 ;;; Add idea of a patch directory.
743 ;;; In verbose printout, have it log a date/time at start and end of
744 ;;; compilation:
745 ;;;     Compiling system "test" on 31-Jan-91 21:46:47
746 ;;;     by Defsystem version v2.0 01-FEB-91.
748 ;;; Define other :force options:
749 ;;;    :query    allows user to specify that a file not normally compiled
750 ;;;              should be. OR
751 ;;;    :confirm  allows user to specify that a file normally compiled
752 ;;;              shouldn't be. AND
754 ;;; We currently assume that compilation-load dependencies and if-changed
755 ;;; dependencies are identical. However, in some cases this might not be
756 ;;; true. For example, if we change a macro we have to recompile functions
757 ;;; that depend on it (except in lisps that automatically do this, such
758 ;;; as the new CMU Common Lisp), but not if we change a function. Splitting
759 ;;; these apart (with appropriate defaulting) would be nice, but not worth
760 ;;; doing immediately since it may save only a couple of file recompilations,
761 ;;; while making defsystem much more complex than it already is.
763 ;;; Current dependencies are limited to siblings. Maybe we should allow
764 ;;; nephews and uncles? So long as it is still a DAG, we can sort it.
765 ;;; Answer: No. The current setup enforces a structure on the modularity.
766 ;;; Otherwise, why should we have modules if we're going to ignore it?
768 ;;; Currently a file is recompiled more or less if the source is newer
769 ;;; than the binary or if the file depends on a file that has changed
770 ;;; (i.e., was recompiled in this session of a system operation).
771 ;;; Neil Goldman <goldman@isi.edu> has pointed out that whether a file
772 ;;; needs recompilation is really independent of the current session of
773 ;;; a system operation, and depends only on the file-write-dates of the
774 ;;; source and binary files for a system. Thus a file should require
775 ;;; recompilation in the following circumstances:
776 ;;;   1. If a file's source is newer than its binary, or
777 ;;;   2. If a file's source is not newer than its binary, but the file
778 ;;;      depends directly or indirectly on a module (or file) that is newer.
779 ;;;      For a regular file use the file-write-date (FWD) of the source or
780 ;;;      binary, whichever is more recent. For a load-only file, use the only
781 ;;;      available FWD. For a module, use the most recent (max) FWD of any of
782 ;;;      its components.
783 ;;; The impact of this is that instead of using a boolean CHANGED variable
784 ;;; throughout the code, we need to allow CHANGED to be NIL/T/<FWD> or
785 ;;; maybe just the FWD timestamp, and to use the value of CHANGED in
786 ;;; needs-compilation decisions. (Use of NIL/T as values is an optimization.
787 ;;; The FWD timestamp which indicates the most recent time of any changes
788 ;;; should be sufficient.) This will affect not just the
789 ;;; compile-file-operation, but also the load-file-operation because of
790 ;;; compilation during load. Also, since FWDs will be used more prevalently,
791 ;;; we probably should couple this change with the inclusion of load-times
792 ;;; in the component defstruct. This is a tricky and involved change, and
793 ;;; requires more thought, since there are subtle cases where it might not
794 ;;; be correct. For now, the change will have to wait until the DEFSYSTEM
795 ;;; redesign.
797 ;;; ********************************************************************
798 ;;; How to Use this System *********************************************
799 ;;; ********************************************************************
801 ;;; To use this system,
802 ;;; 1. If you want to have a central registry of system definitions,
803 ;;;    modify the value of the variable *central-registry* below.
804 ;;; 2. Load this file (defsystem.lisp) in either source or compiled form,
805 ;;; 3. Load the file containing the "defsystem" definition of your system,
806 ;;; 4. Use the function "operate-on-system" to do things to your system.
808 ;;; For more information, see the documentation and examples in
809 ;;; lisp-utilities.ps.
811 ;;; ********************************
812 ;;; Usage Comments *****************
813 ;;; ********************************
815 ;;; If you use symbols in the system definition file, they get interned in
816 ;;; the COMMON-LISP-USER package, which can lead to name conflicts when
817 ;;; the system itself seeks to export the same symbol to the COMMON-LISP-USER
818 ;;; package. The workaround is to use strings instead of symbols for the
819 ;;; names of components in the system definition file. In the major overhaul,
820 ;;; perhaps the user should be precluded from using symbols for such
821 ;;; identifiers.
823 ;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp",
824 ;;; file name expansion is much slower than if you use the full pathname,
825 ;;; as in "/user/USERID/lisp".
829 ;;; ****************************************************************
830 ;;; Lisp Code ******************************************************
831 ;;; ****************************************************************
833 ;;; ********************************
834 ;;; Massage CLtL2 onto *features* **
835 ;;; ********************************
836 ;;; Let's be smart about CLtL2 compatible Lisps:
837 (eval-when (compile load eval)
838   #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl)
839   (pushnew :cltl2 *features*))
841 ;;; ********************************
842 ;;; Provide/Require/*modules* ******
843 ;;; ********************************
845 ;;; Since CLtL2 has dropped require and provide from the language, some
846 ;;; lisps may not have the functions PROVIDE and REQUIRE and the
847 ;;; global *MODULES*. So if lisp::provide and user::provide are not
848 ;;; defined, we define our own.
850 ;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions
851 ;;; and variables not being declared or bound, apparently because it
852 ;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns
853 ;;; T, so it doesn't really bother when compiling the body of the unless.
854 ;;; The new compiler does this properly, so I'm not going to bother
855 ;;; working around this.
857 ;;; Some Lisp implementations return bogus warnings about assuming
858 ;;; *MODULE-FILES* and *LIBRARY* to be special, and CANONICALIZE-MODULE-NAME
859 ;;; and MODULE-FILES being undefined. Don't worry about them.
861 ;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code
862 ;;; necessary?
864 #-(or :CMU
865       :vms
866       :mcl
867       :lispworks
868       :clisp
869       :gcl
870       :sbcl
871       :cormanlisp
872       :scl
873       (and allegro-version>= (version>= 4 1)))
874 (eval-when #-(or :lucid)
875            (:compile-toplevel :load-toplevel :execute)
876            #+(or :lucid)
877            (compile load eval)
879   (unless (or (fboundp 'lisp::require)
880               (fboundp 'user::require)
882               #+(and :excl (and allegro-version>= (version>= 4 0)))
883               (fboundp 'cltl1::require)
885               #+:lispworks
886               (fboundp 'system::require))
888     #-:lispworks
889     (in-package "LISP")
890     #+:lispworks
891     (in-package "SYSTEM")
893     (export '(*modules* provide require))
895     ;; Documentation strings taken almost literally from CLtL1.
897     (defvar *modules* ()
898       "List of names of the modules that have been loaded into Lisp so far.
899      It is used by PROVIDE and REQUIRE.")
901     ;; We provide two different ways to define modules. The default way
902     ;; is to put either a source or binary file with the same name
903     ;; as the module in the library directory. The other way is to define
904     ;; the list of files in the module with defmodule.
906     ;; The directory listed in *library* is implementation dependent,
907     ;; and is intended to be used by Lisp manufacturers as a place to
908     ;; store their implementation dependent packages.
909     ;; Lisp users should use systems and *central-registry* to store
910     ;; their packages -- it is intended that *central-registry* is
911     ;; set by the user, while *library* is set by the lisp.
913     (defvar *library* nil               ; "/usr/local/lisp/Modules/"
914       "Directory within the file system containing files, where the name
915      of a file is the same as the name of the module it contains.")
917     (defvar *module-files* (make-hash-table :test #'equal)
918       "Hash table mapping from module names to list of files for the
919      module. REQUIRE loads these files in order.")
921     (defun canonicalize-module-name (name)
922       ;; if symbol, string-downcase the printrep to make nicer filenames.
923       (if (stringp name) name (string-downcase (string name))))
925     (defmacro defmodule (name &rest files)
926       "Defines a module NAME to load the specified FILES in order."
927       `(setf (gethash (canonicalize-module-name ,name) *module-files*)
928              ',files))
929     (defun module-files (name)
930       (gethash name *module-files*))
932     (defun provide (name)
933       "Adds a new module name to the list of modules maintained in the
934      variable *modules*, thereby indicating that the module has been
935      loaded. Name may be a string or symbol -- strings are case-senstive,
936      while symbols are treated like lowercase strings. Returns T if
937      NAME was not already present, NIL otherwise."
938       (let ((module (canonicalize-module-name name)))
939         (unless (find module *modules* :test #'string=)
940           ;; Module not present. Add it and return T to signify that it
941           ;; was added.
942           (push module *modules*)
943           t)))
945     (defun require (name &optional pathname)
946       "Tests whether a module is already present. If the module is not
947      present, loads the appropriate file or set of files. The pathname
948      argument, if present, is a single pathname or list of pathnames
949      whose files are to be loaded in order, left to right. If the
950      pathname is nil, the system first checks if a module was defined
951      using defmodule and uses the pathnames so defined. If that fails,
952      it looks in the library directory for a file with name the same
953      as that of the module. Returns T if it loads the module."
954       (let ((module (canonicalize-module-name name)))
955         (unless (find module *modules* :test #'string=)
956           ;; Module is not already present.
957           (when (and pathname (not (listp pathname)))
958             ;; If there's a pathname or pathnames, ensure that it's a list.
959             (setf pathname (list pathname)))
960           (unless pathname
961             ;; If there's no pathname, try for a defmodule definition.
962             (setf pathname (module-files module)))
963           (unless pathname
964             ;; If there's still no pathname, try the library directory.
965             (when *library*
966               (setf pathname (concatenate 'string *library* module))
967               ;; Test if the file exists.
968               ;; We assume that the lisp will default the file type
969               ;; appropriately. If it doesn't, use #+".fasl" or some
970               ;; such in the concatenate form above.
971               (if (probe-file pathname)
972                   ;; If it exists, ensure we've got a list
973                   (setf pathname (list pathname))
974                   ;; If the library file doesn't exist, we don't want
975                   ;; a load error.
976                   (setf pathname nil))))
977           ;; Now that we've got the list of pathnames, let's load them.
978           (dolist (pname pathname t)
979             (load pname :verbose nil))))))
980   ) ; eval-when
982 ;;; ********************************
983 ;;; Set up Package *****************
984 ;;; ********************************
987 ;;; Unfortunately, lots of lisps have their own defsystems, some more
988 ;;; primitive than others, all uncompatible, and all in the DEFSYSTEM
989 ;;; package. To avoid name conflicts, we've decided to name this the
990 ;;; MAKE package. A nice side-effect is that the short nickname
991 ;;; MK is my initials.
993 #+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
994 (defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
996 #-(or :sbcl :cltl2 :lispworks :ecl :scl)
997 (in-package "MAKE" :nicknames '("MK"))
999 ;;; For CLtL2 compatible lisps...
1000 #+(and :excl :allegro-v4.0 :cltl2)
1001 (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
1002             (:import-from cltl1 *modules* provide require))
1004 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1005 ;;; In Allegro 4.1, 'provide' and 'require' are not external in
1006 ;;; 'CLTL1'.  However they are in 'COMMON-LISP'.  Hence the change.
1007 #+(and :excl :allegro-v4.1 :cltl2)
1008 (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) )
1010 #+(and :excl :allegro-version>= (version>= 4 2))
1011 (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp))
1013 #+:lispworks
1014 (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1015             (:import-from system *modules* provide require)
1016             (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
1017                      "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
1019 #+:mcl
1020 (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1021   (:import-from ccl *modules* provide require))
1023 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
1024 ;;; The code below, is originally executed also for CMUCL. However I
1025 ;;; believe this is wrong, since CMUCL comes with its own defpackage.
1026 ;;; I added the extra :CMU in the 'or'.
1027 #+(and :cltl2 (not (or :cmu :clisp :sbcl
1028                        (and :excl (or :allegro-v4.0 :allegro-v4.1))
1029                        :mcl)))
1030 (eval-when (compile load eval)
1031   (unless (find-package "MAKE")
1032     (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))
1034 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
1035 ;;; Here I add the proper defpackage for CMU
1036 #+:CMU
1037 (defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
1038   (:nicknames "MK"))
1040 #+:sbcl
1041 (defpackage "MAKE" (:use "COMMON-LISP")
1042   (:nicknames "MK"))
1044 #+:scl
1045 (defpackage :make (:use :common-lisp)
1046   (:nicknames :mk))
1048 #+(or :cltl2 :lispworks :scl)
1049 (eval-when (compile load eval)
1050   (in-package "MAKE"))
1052 #+ecl
1053 (in-package "MAKE")
1055 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1056 ;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
1057 #+(and :excl :allegro-v4.0 :cltl2)
1058 (cltl1:provide 'make)
1059 #+(and :excl :allegro-v4.0 :cltl2)
1060 (provide 'make)
1062 #+:openmcl
1063 (cl:provide 'make)
1065 #+(and :mcl (not :openmcl))
1066 (ccl:provide 'make)
1068 #+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)))
1069 (provide 'make)
1071 #+:lispworks
1072 (provide 'make)
1074 #-(or :cltl2 :lispworks)
1075 (provide 'make)
1077 (pushnew :mk-defsystem *features*)
1079 ;;; Some compatibility issues.  Mostly for CormanLisp.
1080 ;;; 2002-02-20 Marco Antoniotti
1082 #+cormanlisp
1083 (defun compile-file-pathname (pathname-designator)
1084  (merge-pathnames (make-pathname :type "fasl")
1085                   (etypecase pathname-designator
1086                     (pathname pathname-designator)
1087                     (string (parse-namestring pathname-designator))
1088                     ;; We need FILE-STREAM here as well.
1089                     )))
1091 #+cormanlisp
1092 (defun file-namestring (pathname-designator)
1093   (let ((p (etypecase pathname-designator
1094              (pathname pathname-designator)
1095              (string (parse-namestring pathname-designator))
1096              ;; We need FILE-STREAM here as well.
1097              )))
1098     (namestring (make-pathname :directory ()
1099                                :name (pathname-name p)
1100                                :type (pathname-type p)
1101                                :version (pathname-version p)))))
1103 ;;; The external interface consists of *exports* and *other-exports*.
1105 ;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in
1106 ;;; the compile form, so that you can't use a defvar with a default value and
1107 ;;; then a succeeding export as well.
1109 (eval-when (compile load eval)
1110    (defvar *special-exports* nil)
1111    (defvar *exports* nil)
1112    (defvar *other-exports* nil)
1114    (export (setq *exports*
1115                  '(operate-on-system
1116                    oos
1117                    afs-binary-directory afs-source-directory
1118                    files-in-system)))
1119    (export (setq *special-exports*
1120                  '()))
1121    (export (setq *other-exports*
1122                  '(*central-registry*
1123                    *bin-subdir*
1125                    add-registry-location
1126                    find-system
1127                    defsystem compile-system load-system hardcopy-system
1129                    system-definition-pathname
1131                    missing-component
1132                    missing-component-name
1133                    missing-component-component
1134                    missing-module
1135                    missing-system
1137                    register-foreign-system
1139                    machine-type-translation
1140                    software-type-translation
1141                    compiler-type-translation
1142                    ;; require
1143                    define-language
1144                    allegro-make-system-fasl
1145                    files-which-need-compilation
1146                    undefsystem
1147                    defined-systems
1148                    describe-system clean-system edit-system ;hardcopy-system
1149                    system-source-size make-system-tag-table
1150                    *defsystem-version*
1151                    *compile-during-load*
1152                    *minimal-load*
1153                    *dont-redefine-require*
1154                    *files-missing-is-an-error*
1155                    *reload-systems-from-disk*
1156                    *source-pathname-default*
1157                    *binary-pathname-default*
1158                    *multiple-lisp-support*
1159                    ))))
1162 ;;; We import these symbols into the USER package to make them
1163 ;;; easier to use. Since some lisps have already defined defsystem
1164 ;;; in the user package, we may have to shadowing-import it.
1166 #-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
1167 (eval-when (compile load eval)
1168   (import *exports* #-(or :cltl2 :lispworks) "USER"
1169                     #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
1170   (import *special-exports* #-(or :cltl2 :lispworks) "USER"
1171                             #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
1172 #+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
1173 (eval-when (compile load eval)
1174   (import *exports* #-(or :cltl2 :lispworks) "USER"
1175                     #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
1176   (shadowing-import *special-exports*
1177                     #-(or :cltl2 :lispworks) "USER"
1178                     #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
1181 #-(or :PCL :CLOS :scl)
1182 (when (find-package "PCL")
1183   (pushnew :pcl *modules*)
1184   (pushnew :pcl *features*))
1186 ;;; ********************************
1187 ;;; Defsystem Version **************
1188 ;;; ********************************
1189 (defparameter *defsystem-version* "3.4 Interim 3, 2004-06-10"
1190   "Current version number/date for MK:DEFSYSTEM.")
1192 ;;; ********************************
1193 ;;; Customizable System Parameters *
1194 ;;; ********************************
1196 (defvar *dont-redefine-require*
1197   #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil)
1198   #+(or clisp sbcl) t
1199   #+allegro t
1200   #-(or cmu sbcl clisp allegro) nil
1201   "If T, prevents the redefinition of REQUIRE. This is useful for
1202    lisps that treat REQUIRE specially in the compiler.")
1204 (defvar *multiple-lisp-support* t
1205   "If T, afs-binary-directory will try to return a name dependent
1206    on the particular lisp compiler version being used.")
1208 ;;; home-subdirectory --
1209 ;;; HOME-SUBDIRECTORY is used only in *central-registry* below.
1210 ;;; Note that CMU CL 17e does not understand the ~/ shorthand for home
1211 ;;; directories.
1213 ;;; Note:
1214 ;;; 20020220 Marco Antoniotti
1215 ;;; The #-cormanlisp version is the original one, which is broken anyway, since
1216 ;;; it is UNIX dependent.
1217 ;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing
1218 ;;; the ANSI USER-HOMEDIR-PATHNAME function.
1219 #-cormanlisp
1220 (defun home-subdirectory (directory)
1221   (concatenate 'string
1222         #+(or :sbcl :cmu :scl)
1223         "home:"
1224         #-(or :sbcl :cmu :scl)
1225         (let ((homedir (user-homedir-pathname)))
1226           (or (and homedir (namestring homedir))
1227               "~/"))
1228         directory))
1230 #+cormanlisp
1231 (defun home-subdirectory (directory)
1232   (declare (type string directory))
1233   (concatenate 'string "C:\\" directory))
1235 ;;; The following function is available for users to add
1236 ;;;   (setq mk:*central-registry* (defsys-env-search-path))
1237 ;;; to Lisp init files in order to use the value of the DEFSYSPATH
1238 ;;; instead of directly coding it in the file.
1239 #+:allegro
1240 (defun defsys-env-search-path ()
1241   "This function grabs the value of the DEFSYSPATH environment variable
1242    and breaks the search path into a list of paths."
1243   (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
1244                      :test #'string-equal))
1246 ;;; Change this variable to set up the location of a central
1247 ;;; repository for system definitions if you want one.
1248 ;;; This is a defvar to allow users to change the value in their
1249 ;;; lisp init files without worrying about it reverting if they
1250 ;;; reload defsystem for some reason.
1252 ;;; Note that if a form is included in the registry list, it will be evaluated
1253 ;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check.
1255 (defvar *central-registry*
1256   `(;; Current directory
1257     "./"
1258     #+:LUCID     (working-directory)
1259     #+ACLPC      (current-directory)
1260     #+:allegro   (excl:current-directory)
1261     #+:sbcl      (progn *default-pathname-defaults*)
1262     #+(or :cmu :scl)       (ext:default-directory)
1263     ;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu>
1264     ;; Somehow it is better to qualify default-directory in CMU with
1265     ;; the appropriate package (i.e. "EXTENSIONS".)
1266     ;; Same for Allegro.
1267     #+(and :lispworks (not :lispworks4))
1268     ,(multiple-value-bind (major minor)
1269                           #-:lispworks-personal-edition
1270                           (system::lispworks-version)
1271                           #+:lispworks-personal-edition
1272                           (values system::*major-version-number*
1273                                   system::*minor-version-number*)
1274        (if (or (> major 3)
1275                (and (= major 3) (> minor 2))
1276                (and (= major 3) (= minor 2)
1277                     (equal (lisp-implementation-version) "3.2.1")))
1278            `(make-pathname :directory
1279                            ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
1280                                          (find-package "SYSTEM")))
1281            (find-symbol "*CURRENT-WORKING-DIRECTORY*"
1282                         (find-package "LW"))))
1283     #+:lispworks4
1284     (hcl:get-working-directory)
1285     ;; Home directory
1286     #-sbcl
1287     (mk::home-subdirectory "lisp/systems/")
1289     ;; Global registry
1290     "/usr/local/lisp/Registry/")
1291   "Central directory of system definitions. May be either a single
1292    directory pathname, or a list of directory pathnames to be checked
1293    after the local directory.")
1296 (defun add-registry-location (pathname)
1297   "Adds a path to the central registry."
1298   (pushnew pathname *central-registry* :test #'equal))
1300 (defvar *bin-subdir* ".bin/"
1301   "The subdirectory of an AFS directory where the binaries are really kept.")
1303 ;;; These variables set up defaults for operate-on-system, and are used
1304 ;;; for communication in lieu of parameter passing. Yes, this is bad,
1305 ;;; but it keeps the interface small. Also, in the case of the -if-no-binary
1306 ;;; variables, parameter passing would require multiple value returns
1307 ;;; from some functions. Why make life complicated?
1308 (defvar *tell-user-when-done* nil
1309   "If T, system will print ...DONE at the end of an operation")
1310 (defvar *oos-verbose* nil
1311   "Operate on System Verbose Mode")
1312 (defvar *oos-test* nil
1313   "Operate on System Test Mode")
1314 (defvar *load-source-if-no-binary* nil
1315   "If T, system will try loading the source if the binary is missing")
1316 (defvar *bother-user-if-no-binary* t
1317   "If T, the system will ask the user whether to load the source if
1318    the binary is missing")
1319 (defvar *load-source-instead-of-binary* nil
1320   "If T, the system will load the source file instead of the binary.")
1321 (defvar *compile-during-load* :query
1322   "If T, the system will compile source files during load if the
1323    binary file is missing. If :query, it will ask the user for
1324    permission first.")
1325 (defvar *minimal-load* nil
1326   "If T, the system tries to avoid reloading files that were already loaded
1327    and up to date.")
1329 (defvar *files-missing-is-an-error* t
1330   "If both the source and binary files are missing, signal a continuable
1331    error instead of just a warning.")
1333 (defvar *operations-propagate-to-subsystems* t
1334   "If T, operations like :COMPILE and :LOAD propagate to subsystems
1335    of a system that are defined either using a component-type of :system
1336    or by another defsystem form.")
1338 ;;; Particular to CMULisp
1339 (defvar *compile-error-file-type* "err"
1340   "File type of compilation error file in cmulisp")
1341 (defvar *cmu-errors-to-terminal* t
1342   "Argument to :errors-to-terminal in compile-file in cmulisp")
1343 (defvar *cmu-errors-to-file* t
1344   "If T, cmulisp will write an error file during compilation")
1346 ;;; ********************************
1347 ;;; Global Variables ***************
1348 ;;; ********************************
1350 ;;; Massage people's *features* into better shape.
1351 (eval-when (compile load eval)
1352   (dolist (feature *features*)
1353     (when (and (symbolp feature)   ; 3600
1354                (equal (symbol-name feature) "CMU"))
1355       (pushnew :CMU *features*)))
1357   #+Lucid
1358   (when (search "IBM RT PC" (machine-type))
1359     (pushnew :ibm-rt-pc *features*))
1360   )
1362 ;;; *filename-extensions* is a cons of the source and binary extensions.
1363 (defvar *filename-extensions*
1364   (car `(#+(and Symbolics Lispm)              ("lisp" . "bin")
1365          #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
1366          #+(and dec common vax ultrix)        ("lsp"  . "fas")
1367          #+ACLPC                              ("lsp"  . "fsl")
1368          #+CLISP                              ("lisp" . "fas")
1369          #+KCL                                ("lsp"  . "o")
1370          #+ECL                                ("lsp"  . "so")
1371          #+IBCL                               ("lsp"  . "o")
1372          #+Xerox                              ("lisp" . "dfasl")
1373          ;; Lucid on Silicon Graphics
1374          #+(and Lucid MIPS)                   ("lisp" . "mbin")
1375          ;; the entry for (and lucid hp300) must precede
1376          ;; that of (and lucid mc68000) for hp9000/300's running lucid,
1377          ;; since *features* on hp9000/300's also include the :mc68000
1378          ;; feature.
1379          #+(and lucid hp300)                  ("lisp" . "6bin")
1380          #+(and Lucid MC68000)                ("lisp" . "lbin")
1381          #+(and Lucid Vax)                    ("lisp" . "vbin")
1382          #+(and Lucid Prime)                  ("lisp" . "pbin")
1383          #+(and Lucid SUNRise)                ("lisp" . "sbin")
1384          #+(and Lucid SPARC)                  ("lisp" . "sbin")
1385          #+(and Lucid :IBM-RT-PC)             ("lisp" . "bbin")
1386          ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
1387          #+(and Lucid PA)                     ("lisp" . "hbin")
1388          #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
1389          #+(or :cmu :scl)  ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
1390 ;        #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
1391 ;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
1392 ;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
1393          #+PRIME                              ("lisp" . "pbin")
1394          #+HP                                 ("l"    . "b")
1395          #+TI ("lisp" . #.(string (si::local-binary-file-type)))
1396          #+:gclisp                            ("LSP"  . "F2S")
1397          #+pyramid                            ("clisp" . "o")
1399          ;; Harlequin LispWorks
1400          #+:lispworks         ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
1401 ;        #+(and :sun4 :lispworks)             ("lisp" . "wfasl")
1402 ;        #+(and :mips :lispworks)             ("lisp" . "mfasl")
1403          #+:mcl                               ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
1404          #+:coral                             ("lisp" . "fasl")
1406          ;; Otherwise,
1407          ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
1408   "Filename extensions for Common Lisp. A cons of the form
1409    (Source-Extension . Binary-Extension). If the system is
1410    unknown (as in *features* not known), defaults to lisp and fasl.")
1412 (defvar *system-extension*
1413   ;; MS-DOS systems can only handle three character extensions.
1414   #-ACLPC "system"
1415   #+ACLPC "sys"
1416   "The filename extension to use with systems.")
1418 ;;; The above variables and code should be extended to allow a list of
1419 ;;; valid extensions for each lisp implementation, instead of a single
1420 ;;; extension. When writing a file, the first extension should be used.
1421 ;;; But when searching for a file, every extension in the list should
1422 ;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and
1423 ;;; "lsp" (*load-source-types*) as source code extensions, and
1424 ;;; (c:backend-fasl-file-type c:*backend*)
1425 ;;; (c:backend-byte-fasl-file-type c:*backend*)
1426 ;;; and "fasl" as binary (object) file extensions (*load-object-types*).
1428 ;;; Note that the above code is used below in the LANGUAGE defstruct.
1430 ;;; There is no real support for this variable being nil, so don't change it.
1431 ;;; Note that in any event, the toplevel system (defined with defsystem)
1432 ;;; will have its dependencies delayed. Not having dependencies delayed
1433 ;;; might be useful if we define several systems within one defsystem.
1434 (defvar *system-dependencies-delayed* t
1435   "If T, system dependencies are expanded at run time")
1437 ;;; Replace this with consp, dammit!
1438 (defun non-empty-listp (list)
1439   (and list (listp list)))
1441 ;;; ********************************
1442 ;;; Component Operation Definition *
1443 ;;; ********************************
1444 (eval-when (:compile-toplevel :load-toplevel :execute)
1445 (defvar *version-dir* nil
1446   "The version subdir. bound in operate-on-system.")
1447 (defvar *version-replace* nil
1448   "The version replace. bound in operate-on-system.")
1449 (defvar *version* nil
1450   "Default version."))
1452 (defvar *component-operations* (make-hash-table :test #'equal)
1453   "Hash table of (operation-name function) pairs.")
1454 (defun component-operation (name &optional operation)
1455   (if operation
1456       (setf (gethash name *component-operations*) operation)
1457       (gethash name *component-operations*)))
1459 ;;; ********************************
1460 ;;; AFS @sys immitator *************
1461 ;;; ********************************
1463 ;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.
1464 #-:mcl
1465 (eval-when (compile load eval)
1466   ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo").
1467   ;; For example,
1468   ;;    <cl> #@"foo"
1469   ;;    "foo/.bin/rt_mach/"
1470   (set-dispatch-macro-character
1471    #\# #\@
1472    #'(lambda (stream char arg)
1473        (declare (ignore char arg))
1474        `(afs-binary-directory ,(read stream t nil t)))))
1476 (defvar *find-irix-version-script*
1477     "\"1,4 d\\
1478 s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
1479 /./,$ d\\
1480 \"")
1482 (defun operating-system-version ()
1483   #+(and :sgi :excl)
1484   (let* ((full-version (software-version))
1485          (blank-pos (search " " full-version))
1486          (os (subseq full-version 0 blank-pos))
1487          (version-rest (subseq full-version
1488                                (1+ blank-pos)))
1489          os-version)
1490     (setq blank-pos (search " " version-rest))
1491     (setq version-rest (subseq version-rest
1492                                (1+ blank-pos)))
1493     (setq blank-pos (search " " version-rest))
1494     (setq os-version (subseq version-rest 0 blank-pos))
1495     (setq version-rest (subseq version-rest
1496                                (1+ blank-pos)))
1497     (setq blank-pos (search " " version-rest))
1498     (setq version-rest (subseq version-rest
1499                                (1+ blank-pos)))
1500     (concatenate 'string
1501       os " " os-version))      ; " " version-rest
1502   #+(and :sgi :cmu :sbcl)
1503   (concatenate 'string
1504     (software-type)
1505     (software-version))
1506   #+(and :lispworks :irix)
1507   (let ((soft-type (software-type)))
1508     (if (equalp soft-type "IRIX5")
1509         (progn
1510           (foreign:call-system
1511             (format nil "versions ~A | sed -e ~A > ~A"
1512                          "eoe1"
1513                          *find-irix-version-script*
1514                          "irix-version")
1515             "/bin/csh")
1516           (with-open-file (s "irix-version")
1517                           (format nil "IRIX ~S"
1518                                   (read s))))
1519       soft-type))
1520   #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
1521   (software-type))
1523 (defun compiler-version ()
1524   #+:lispworks (concatenate 'string
1525                 "lispworks" " " (lisp-implementation-version))
1526   #+excl      (concatenate 'string
1527                 "excl" " " excl::*common-lisp-version-number*)
1528   #+sbcl      (concatenate 'string
1529                            "sbcl" " " (lisp-implementation-version))
1530   #+cmu       (concatenate 'string
1531                 "cmu" " " (lisp-implementation-version))
1532   #+scl       (concatenate 'string
1533                 "scl" " " (lisp-implementation-version))
1535   #+kcl       "kcl"
1536   #+IBCL      "ibcl"
1537   #+akcl      "akcl"
1538   #+gcl       "gcl"
1539   #+ecl       "ecl"
1540   #+lucid     "lucid"
1541   #+ACLPC     "aclpc"
1542   #+CLISP     "clisp"
1543   #+Xerox     "xerox"
1544   #+symbolics "symbolics"
1545   #+mcl       "mcl"
1546   #+coral     "coral"
1547   #+gclisp    "gclisp"
1548   )
1550 (defun afs-binary-directory (root-directory)
1551   ;; Function for obtaining the directory AFS's @sys feature would have
1552   ;; chosen when we're not in AFS. This function is useful as the argument
1553   ;; to :binary-pathname in defsystem. For example,
1554   ;; :binary-pathname (afs-binary-directory "scanner/")
1555   (let ((machine (machine-type-translation
1556                   #-(and :sgi :allegro-version>= (version>= 4 2))
1557                   (machine-type)
1558                   #+(and :sgi :allegro-version>= (version>= 4 2))
1559                   (machine-version)))
1560         (software (software-type-translation
1561                    #-(and :sgi (or :cmu :sbcl :scl
1562                                    (and :allegro-version>= (version>= 4 2))))
1563                    (software-type)
1564                    #+(and :sgi (or :cmu :sbcl :scl
1565                                    (and :allegro-version>= (version>= 4 2))))
1566                    (operating-system-version)))
1567         (lisp (compiler-type-translation (compiler-version))))
1568     ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
1569     (setq root-directory (namestring root-directory))
1570     (setq root-directory (ensure-trailing-slash root-directory))
1571     (format nil "~A~@[~A~]~@[~A/~]"
1572             root-directory
1573             *bin-subdir*
1574             (if *multiple-lisp-support*
1575                 (afs-component machine software lisp)
1576               (afs-component machine software)))))
1578 (defun afs-source-directory (root-directory &optional version-flag)
1579   ;; Function for obtaining the directory AFS's @sys feature would have
1580   ;; chosen when we're not in AFS. This function is useful as the argument
1581   ;; to :source-pathname in defsystem.
1582   (setq root-directory (namestring root-directory))
1583   (setq root-directory (ensure-trailing-slash root-directory))
1584   (format nil "~A~@[~A/~]"
1585           root-directory
1586           (and version-flag (translate-version *version*))))
1588 (defun null-string (s)
1589   (when (stringp s)
1590     (string-equal s "")))
1592 (defun ensure-trailing-slash (dir)
1593   (if (and dir
1594            (not (null-string dir))
1595            (not (char= (char dir
1596                              (1- (length dir)))
1597                        #\/))
1598            (not (char= (char dir
1599                              (1- (length dir)))
1600                        #\\))
1601            )
1602       (concatenate 'string dir "/")
1603       dir))
1605 (defun afs-component (machine software &optional lisp)
1606   (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
1607             machine
1608             (or software "mach")
1609             lisp))
1611 (defvar *machine-type-alist* (make-hash-table :test #'equal)
1612   "Hash table for retrieving the machine-type")
1613 (defun machine-type-translation (name &optional operation)
1614   (if operation
1615       (setf (gethash (string-upcase name) *machine-type-alist*) operation)
1616       (gethash (string-upcase name) *machine-type-alist*)))
1618 (machine-type-translation "IBM RT PC"                        "rt")
1619 (machine-type-translation "DEC 3100"                         "pmax")
1620 (machine-type-translation "DEC VAX-11"                       "vax")
1621 (machine-type-translation "DECstation"                       "pmax")
1622 (machine-type-translation "Sun3"                             "sun3")
1623 (machine-type-translation "Sun-4"                            "sun4")
1624 (machine-type-translation "MIPS Risc"                        "mips")
1625 (machine-type-translation "SGI"                              "sgi")
1626 (machine-type-translation "Silicon Graphics Iris 4D"         "sgi")
1627 (machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi")
1628 (machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi")
1629 (machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi")
1630 (machine-type-translation "IP22"                             "sgi")
1631 ;;; MIPS R4000 Processor Chip Revision: 3.0
1632 ;;; MIPS R4400 Processor Chip Revision: 5.0
1633 ;;; MIPS R4600 Processor Chip Revision: 1.0
1634 (machine-type-translation "IP20"                             "sgi")
1635 ;;; MIPS R4000 Processor Chip Revision: 3.0
1636 (machine-type-translation "IP17"                             "sgi")
1637 ;;; MIPS R4000 Processor Chip Revision: 2.2
1638 (machine-type-translation "IP12"                             "sgi")
1639 ;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
1640 (machine-type-translation "IP7"                              "sgi")
1641 ;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
1643 (machine-type-translation "x86"                              "x86")
1644 ;;; ACL
1645 (machine-type-translation "IBM PC Compatible"                "x86")
1646 ;;; LW
1647 (machine-type-translation "I686"                             "x86")
1648 ;;; LW
1649 (machine-type-translation "PC/386"                           "x86")
1650 ;;; CLisp Win32
1652 #+(and :lucid :sun :mc68000)
1653 (machine-type-translation "unknown"     "sun3")
1656 (defvar *software-type-alist* (make-hash-table :test #'equal)
1657   "Hash table for retrieving the software-type")
1658 (defun software-type-translation (name &optional operation)
1659   (if operation
1660       (setf (gethash (string-upcase name) *software-type-alist*) operation)
1661       (gethash (string-upcase name) *software-type-alist*)))
1663 (software-type-translation "BSD UNIX"      "mach") ; "unix"
1664 (software-type-translation "Ultrix"        "mach") ; "ultrix"
1665 (software-type-translation "SunOS"         "SunOS")
1666 (software-type-translation "MACH/4.3BSD"   "mach")
1667 (software-type-translation "IRIX System V" "irix") ; (software-type)
1668 (software-type-translation "IRIX5"         "irix5")
1669 ;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version)
1671 (software-type-translation "IRIX 5.2" "irix5")
1672 (software-type-translation "IRIX 5.3" "irix5")
1673 (software-type-translation "IRIX5.2"  "irix5")
1674 (software-type-translation "IRIX5.3"  "irix5")
1676 (software-type-translation "Linux" "linux") ; Lispworks for Linux
1677 (software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL
1678 (software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32")
1679 (software-type-translation "Windows NT" "win32") ; LW for Windows
1680 (software-type-translation "ANSI C program" "ansi-c") ; CLISP
1681 (software-type-translation "C compiler" "ansi-c") ; CLISP for Win32
1683 (software-type-translation nil             "")
1685 #+:lucid
1686 (software-type-translation "Unix"
1687                            #+:lcl4.0 "4.0"
1688                            #+(and :lcl3.0 (not :lcl4.0)) "3.0")
1690 (defvar *compiler-type-alist* (make-hash-table :test #'equal)
1691   "Hash table for retrieving the Common Lisp type")
1692 (defun compiler-type-translation (name &optional operation)
1693   (if operation
1694       (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
1695     (gethash (string-upcase name) *compiler-type-alist*)))
1697 (compiler-type-translation "lispworks 3.2.1"         "lispworks")
1698 (compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
1699 (compiler-type-translation "lispworks 4.2.0"         "lispworks")
1701 #+allegro
1702 (eval-when (:compile-toplevel :load-toplevel :execute)
1703   (unless (or (find :case-sensitive common-lisp:*features*)
1704               (find :case-insensitive common-lisp:*features*))
1705     (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
1706             (eq excl:*current-case-mode* :case-sensitive-upper))
1707         (push :case-sensitive common-lisp:*features*)
1708       (push :case-insensitive common-lisp:*features*))))
1711 #+(and allegro case-sensitive ics)
1712 (compiler-type-translation "excl 6.1" "excl-m")
1713 #+(and allegro case-sensitive (not ics))
1714 (compiler-type-translation "excl 6.1" "excl-m8")
1716 #+(and allegro case-insensitive ics)
1717 (compiler-type-translation "excl 6.1" "excl-a")
1718 #+(and allegro case-insensitive (not ics))
1719 (compiler-type-translation "excl 6.1" "excl-a8")
1721 (compiler-type-translation "excl 4.2" "excl")
1722 (compiler-type-translation "excl 4.1" "excl")
1723 (compiler-type-translation "cmu 17f" "cmu")
1724 (compiler-type-translation "cmu 17e" "cmu")
1725 (compiler-type-translation "cmu 17d" "cmu")
1727 ;;; ********************************
1728 ;;; System Names *******************
1729 ;;; ********************************
1731 ;;; If you use strings for system names, be sure to use the same case
1732 ;;; as it appears on disk, if the filesystem is case sensitive.
1733 (defun canonicalize-system-name (name)
1734   ;; Originally we were storing systems using GET. This meant that the
1735   ;; name of a system had to be a symbol, so we interned the symbols
1736   ;; in the keyword package to avoid package dependencies. Now that we're
1737   ;; storing the systems in a hash table, we've switched to using strings.
1738   ;; Since the hash table is case sensitive, we use uppercase strings.
1739   ;; (Names of modules and files may be symbols or strings.)
1740   #||(if (keywordp name)
1741       name
1742       (intern (string-upcase (string name)) "KEYWORD"))||#
1743   (if (stringp name) (string-upcase name) (string-upcase (string name))))
1745 (defvar *defined-systems* (make-hash-table :test #'equal)
1746   "Hash table containing the definitions of all known systems.")
1748 (defun get-system (name)
1749   "Returns the definition of the system named NAME."
1750   (gethash (canonicalize-system-name name) *defined-systems*))
1752 (defsetf get-system (name) (value)
1753   `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))
1755 (defun undefsystem (name)
1756   "Removes the definition of the system named NAME."
1757   (setf (get-system name) nil))
1759 (defun defined-systems ()
1760   "Returns a list of defined systems."
1761   (let ((result nil))
1762     (maphash #'(lambda (key value)
1763                  (declare (ignore key))
1764                  (push value result))
1765              *defined-systems*)
1766     result))
1768 ;;; ********************************
1769 ;;; Directory Pathname Hacking *****
1770 ;;; ********************************
1772 ;;; Unix example: An absolute directory starts with / while a
1773 ;;; relative directory doesn't. A directory ends with /, while
1774 ;;; a file's pathname doesn't. This is important 'cause
1775 ;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".
1777 ;;; I haven't been able to test the fix to the problem with symbolics
1778 ;;; hosts. Essentially, append-directories seems to have been tacking
1779 ;;; the default host onto the front of the pathname (e.g., mk::source-pathname
1780 ;;; gets a "B:" on front) and this overrides the :host specified in the
1781 ;;; component. The value of :host should override that specified in
1782 ;;; the :source-pathname and the default file server. If this doesn't
1783 ;;; fix things, specifying the host in the root pathname "F:>root-dir>"
1784 ;;; may be a good workaround.
1786 ;;; Need to verify that merging of pathnames where modules are located
1787 ;;; on different devices (in VMS-based VAXLisp) now works.
1789 ;;; Merge-pathnames works for VMS systems. In VMS systems, the directory
1790 ;;; part is enclosed in square brackets, e.g.,
1791 ;;;     "[root.child.child_child]" or "[root.][child.][child_child]"
1792 ;;; To concatenate directories merge-pathnames works as follows:
1793 ;;;     (merge-pathnames "" "[root]")               ==> "[root]"
1794 ;;;     (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
1795 ;;;     (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
1796 ;;;     (merge-pathnames "[root]file.ext" "[son]")  ==> "[root]file.ext"
1797 ;;; Thus the problem with the #-VMS code was that it was merging x y into
1798 ;;; [[x]][y] instead of [x][y] or [x]y.
1800 ;;; Miscellaneous notes:
1801 ;;;   On GCLisp, the following are equivalent:
1802 ;;;       "\\root\\subdir\\BAZ"
1803 ;;;       "/root/subdir/BAZ"
1804 ;;;   On VAXLisp, the following are equivalent:
1805 ;;;       "[root.subdir]BAZ"
1806 ;;;       "[root.][subdir]BAZ"
1807 ;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2
1809 (defun new-append-directories (absolute-dir relative-dir)
1810   ;; Version of append-directories for CLtL2-compliant lisps. In particular,
1811   ;; they must conform to section 23.1.3 "Structured Directories". We are
1812   ;; willing to fix minor aberations in this function, but not major ones.
1813   ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
1814   ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
1815   (setf absolute-dir (or absolute-dir "")
1816         relative-dir (or relative-dir ""))
1817   (let* ((abs-dir (pathname absolute-dir))
1818          (rel-dir (pathname relative-dir))
1819          (host (pathname-host abs-dir))
1820          (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
1821                      (pathname-device rel-dir)
1822                    (pathname-device abs-dir)))
1823          (abs-directory (directory-to-list (pathname-directory abs-dir)))
1824          (abs-keyword (when (keywordp (car abs-directory))
1825                         (pop abs-directory)))
1826          ;; Stig (July 2001):
1827          ;; Somehow CLISP dies on the next line, but NIL is ok.
1828          (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
1829          (rel-directory (directory-to-list (pathname-directory rel-dir)))
1830          (rel-keyword (when (keywordp (car rel-directory))
1831                         (pop rel-directory)))
1832          #-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir))
1833          ;; Stig (July 2001);
1834          ;; These values seems to help clisp as well
1835          #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir))
1836          #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir))
1837          (directory nil))
1839     ;; TI Common Lisp pathnames can return garbage for file names because
1840     ;; of bizarreness in the merging of defaults.  The following code makes
1841     ;; sure that the name is a valid name by comparing it with the
1842     ;; pathname-name.  It also strips TI specific extensions and handles
1843     ;; the necessary case conversion.  TI maps upper back into lower case
1844     ;; for unix files!
1845     #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal)
1846              (setf abs-name (string-right-trim ".\x17" (string-upcase abs-name)))
1847              (setf abs-name nil))
1848     #+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal)
1849              (setf rel-file (string-right-trim ".\x17" (string-upcase rel-file)))
1850              (setf rel-file nil))
1851     ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
1852     ;; and filename "foo". The namestring of a pathname with
1853     ;; directory '(:absolute :root "foo") ignores everything after the
1854     ;; :root.
1855     #+(and allegro-version>= (version>= 4 0))
1856     (when (eq (car abs-directory) :root) (pop abs-directory))
1857     #+(and allegro-version>= (version>= 4 0))
1858     (when (eq (car rel-directory) :root) (pop rel-directory))
1860     (when (and abs-name (not (null-string abs-name))) ; was abs-name
1861       (cond ((and (null abs-directory) (null abs-keyword))
1862              #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
1863              (setf abs-directory (list abs-name)))
1864             (t
1865              (setf abs-directory (append abs-directory (list abs-name))))))
1866     (when (and (null abs-directory)
1867                (or (null abs-keyword)
1868                    ;; In Lucid, an abs-dir of nil gets a keyword of
1869                    ;; :relative since (pathname-directory (pathname ""))
1870                    ;; returns (:relative) instead of nil.
1871                    #+:lucid (eq abs-keyword :relative))
1872                rel-keyword)
1873       ;; The following feature switches seem necessary in CMUCL
1874       ;; Marco Antoniotti 19990707
1875       #+(or :sbcl :CMU)
1876       (if (typep abs-dir 'logical-pathname)
1877           (setf abs-keyword :absolute)
1878           (setf abs-keyword rel-keyword))
1879       #-(or :sbcl :CMU)
1880       (setf abs-keyword rel-keyword))
1881     (setf directory (append abs-directory rel-directory))
1882     (when abs-keyword (setf directory (cons abs-keyword directory)))
1883     (namestring
1884      (make-pathname :host host
1885                     :device device
1886                     :directory
1887                     directory
1888                     :name
1889                     #-(or :sbcl :MCL :clisp) rel-file
1890                     #+(or :sbcl :MCL :clisp) rel-name
1892                     #+(or :sbcl :MCL :clisp) :type
1893                     #+(or :sbcl :MCL :clisp) rel-type
1894                     ))))
1896 (defun directory-to-list (directory)
1897   ;; The directory should be a list, but nonstandard implementations have
1898   ;; been known to use a vector or even a string.
1899   (cond ((listp directory)
1900          directory)
1901         ((stringp directory)
1902          (cond ((find #\; directory)
1903                 ;; It's probably a logical pathname, so split at the
1904                 ;; semicolons:
1905                 (split-string directory :item #\;))
1906                #+MCL
1907                ((and (find #\: directory)
1908                      (not (find #\/ directory)))
1909                 ;; It's probably a MCL pathname, so split at the colons.
1910                 (split-string directory :item #\:))
1911                (t
1912                 ;; It's probably a unix pathname, so split at the slash.
1913                 (split-string directory :item #\/))))
1914         (t
1915          (coerce directory 'list))))
1918 (defparameter *append-dirs-tests*
1919   '("~/foo/" "baz/bar.lisp"
1920      "~/foo" "baz/bar.lisp"
1921      "/foo/bar/" "baz/barf.lisp"
1922      "/foo/bar/" "/baz/barf.lisp"
1923      "foo/bar/" "baz/barf.lisp"
1924      "foo/bar" "baz/barf.lisp"
1925      "foo/bar" "/baz/barf.lisp"
1926      "foo/bar/" "/baz/barf.lisp"
1927      "/foo/bar/" nil
1928      "foo/bar/" nil
1929      "foo/bar" nil
1930      "foo" nil
1931      "foo" ""
1932      nil "baz/barf.lisp"
1933      nil "/baz/barf.lisp"
1934      nil nil))
1936 (defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
1937   (do* ((dir-list test-dirs (cddr dir-list))
1938         (abs-dir (car dir-list) (car dir-list))
1939         (rel-dir (cadr dir-list) (cadr dir-list)))
1940       ((null dir-list) (values))
1941     (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
1942             abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
1945 <cl> (test-new-append-directories)
1947 ABS: "~/foo/"     REL: "baz/bar.lisp"    Result: "/usr0/mkant/foo/baz/bar.lisp"
1948 ABS: "~/foo"      REL: "baz/bar.lisp"    Result: "/usr0/mkant/foo/baz/bar.lisp"
1949 ABS: "/foo/bar/"  REL: "baz/barf.lisp"   Result: "/foo/bar/baz/barf.lisp"
1950 ABS: "/foo/bar/"  REL: "/baz/barf.lisp"  Result: "/foo/bar/baz/barf.lisp"
1951 ABS: "foo/bar/"   REL: "baz/barf.lisp"   Result: "foo/bar/baz/barf.lisp"
1952 ABS: "foo/bar"    REL: "baz/barf.lisp"   Result: "foo/bar/baz/barf.lisp"
1953 ABS: "foo/bar"    REL: "/baz/barf.lisp"  Result: "foo/bar/baz/barf.lisp"
1954 ABS: "foo/bar/"   REL: "/baz/barf.lisp"  Result: "foo/bar/baz/barf.lisp"
1955 ABS: "/foo/bar/"  REL: NIL               Result: "/foo/bar/"
1956 ABS: "foo/bar/"   REL: NIL               Result: "foo/bar/"
1957 ABS: "foo/bar"    REL: NIL               Result: "foo/bar/"
1958 ABS: "foo"        REL: NIL               Result: "foo/"
1959 ABS: "foo"        REL: ""                Result: "foo/"
1960 ABS: NIL          REL: "baz/barf.lisp"   Result: "baz/barf.lisp"
1961 ABS: NIL          REL: "/baz/barf.lisp"  Result: "/baz/barf.lisp"
1962 ABS: NIL          REL: NIL               Result: ""
1967 (defun append-directories (absolute-directory relative-directory)
1968   "There is no CL primitive for tacking a subdirectory onto a directory.
1969    We need such a function because defsystem has both absolute and
1970    relative pathnames in the modules. This is a somewhat ugly hack which
1971    seems to work most of the time. We assume that ABSOLUTE-DIRECTORY
1972    is a directory, with no filename stuck on the end. Relative-directory,
1973    however, may have a filename stuck on the end."
1974   (when (or absolute-directory relative-directory)
1975     (cond
1976      ;; KMR commented out because: when appending two logical pathnames,
1977      ;; using this code translates the first logical pathname then appends
1978      ;; the second logical pathname -- an error.
1979      #|
1980       ;; We need a reliable way to determine if a pathname is logical.
1981       ;; Allegro 4.1 does not recognize the syntax of a logical pathname
1982       ;;  as being logical unless its logical host is already defined.
1984       #+(or (and allegro-version>= (version>= 4 1))
1985             :logical-pathnames-mk)
1986       ((and absolute-directory
1987             (logical-pathname-p absolute-directory)
1988             relative-directory)
1989        ;; For use with logical pathnames package.
1990        (append-logical-directories-mk absolute-directory relative-directory))
1991      |#
1992       ((namestring-probably-logical absolute-directory)
1993        ;; A simplistic stab at handling logical pathnames
1994        (append-logical-pnames absolute-directory relative-directory))
1995       (t
1996        ;; In VMS, merge-pathnames actually does what we want!!!
1997        #+:VMS
1998        (namestring (merge-pathnames (or absolute-directory "")
1999                                     (or relative-directory "")))
2000        #+:macl1.3.2
2001        (namestring (make-pathname :directory absolute-directory
2002                                   :name relative-directory))
2003        ;; Cross your fingers and pray.
2004        #-(or :VMS :macl1.3.2)
2005        (new-append-directories absolute-directory relative-directory)))))
2007 #+:logical-pathnames-mk
2008 (defun append-logical-directories-mk (absolute-dir relative-dir)
2009   (lp:append-logical-directories absolute-dir relative-dir))
2012 ;;; append-logical-pathnames-mk --
2013 ;;; The following is probably still bogus and it does not solve the
2014 ;;; problem of appending two logical pathnames.
2015 ;;; Anyway, as per suggetsion by KMR, the function is not called
2016 ;;; anymore.
2017 ;;; Hopefully this will not cause problems for ACL.
2019 #+(and (and allegro-version>= (version>= 4 1))
2020        (not :logical-pathnames-mk))
2021 (defun append-logical-directories-mk (absolute-dir relative-dir)
2022   ;; We know absolute-dir and relative-dir are non nil.  Moreover
2023   ;; absolute-dir is a logical pathname.
2024   (setq absolute-dir (logical-pathname absolute-dir))
2025   (etypecase relative-dir
2026     (string (setq relative-dir (parse-namestring relative-dir)))
2027     (pathname #| do nothing |#))
2029   (translate-logical-pathname
2030    (merge-pathnames relative-dir absolute-dir)))
2032 #| Old version 2002-03-02
2033 #+(and (and allegro-version>= (version>= 4 1))
2034        (not :logical-pathnames-mk))
2035 (defun append-logical-directories-mk (absolute-dir relative-dir)
2036   ;; We know absolute-dir and relative-dir are non nil.  Moreover
2037   ;; absolute-dir is a logical pathname.
2038   (setq absolute-dir (logical-pathname absolute-dir))
2039   (etypecase relative-dir
2040     (string (setq relative-dir (parse-namestring relative-dir)))
2041     (pathname #| do nothing |#))
2043   (translate-logical-pathname
2044    (make-pathname
2045     :host (or (pathname-host absolute-dir)
2046               (pathname-host relative-dir))
2047     :directory (append (pathname-directory absolute-dir)
2048                        (cdr (pathname-directory relative-dir)))
2049     :name (or (pathname-name absolute-dir)
2050               (pathname-name relative-dir))
2051     :type (or (pathname-type absolute-dir)
2052               (pathname-type relative-dir))
2053     :version (or (pathname-version absolute-dir)
2054                  (pathname-version relative-dir)))))
2056 ;; Old version
2057 #+(and (and allegro-version>= (version>= 4 1))
2058        (not :logical-pathnames-mk))
2059 (defun append-logical-directories-mk (absolute-dir relative-dir)
2060   (when (or absolute-dir relative-dir)
2061     (setq absolute-dir (logical-pathname (or absolute-dir ""))
2062           relative-dir (logical-pathname (or relative-dir "")))
2063     (translate-logical-pathname
2064      (make-pathname
2065       :host (or (pathname-host absolute-dir)
2066                 (pathname-host relative-dir))
2067       :directory (append (pathname-directory absolute-dir)
2068                          (cdr (pathname-directory relative-dir)))
2069       :name (or (pathname-name absolute-dir)
2070                 (pathname-name relative-dir))
2071       :type (or (pathname-type absolute-dir)
2072                 (pathname-type relative-dir))
2073       :version (or (pathname-version absolute-dir)
2074                    (pathname-version relative-dir))))))
2077 ;;; determines if string or pathname object is logical
2078 #+:logical-pathnames-mk
2079 (defun logical-pathname-p (thing)
2080   (eq (lp:pathname-host-type thing) :logical))
2082 ;;; From Kevin Layer for 4.1final.
2083 #+(and (and allegro-version>= (version>= 4 1))
2084        (not :logical-pathnames-mk))
2085 (defun logical-pathname-p (thing)
2086   (typep (parse-namestring thing) 'logical-pathname))
2088 (defun pathname-logical-p (thing)
2089   (typecase thing
2090     (logical-pathname t)
2091     #+clisp ; CLisp has non conformant Logical Pathnames.
2092     (pathname (pathname-logical-p (namestring thing)))
2093     (string (and (= 1 (count #\: thing)) ; Shortcut.
2094                  (ignore-errors (translate-logical-pathname thing))
2095                  t))
2096     (t nil)))
2098 ;;; This affects only one thing.
2099 ;;; 19990707 Marco Antoniotti
2100 ;;; old version
2102 (defun namestring-probably-logical (namestring)
2103   (and (stringp namestring)
2104        ;; unix pathnames don't have embedded semicolons
2105        (find #\; namestring)))
2107 ;;; New version
2108 (defun namestring-probably-logical (namestring)
2109   (and (stringp namestring)
2110        (typep (parse-namestring namestring) 'logical-pathname)))
2113 ;;; New new version
2114 ;;; 20000321 Marco Antoniotti
2115 (defun namestring-probably-logical (namestring)
2116   (pathname-logical-p namestring))
2120 #|| This is incorrect, as it strives to keep strings around, when it
2121     shouldn't.  MERGE-PATHNAMES already DTRT.
2122 (defun append-logical-pnames (absolute relative)
2123   (declare (type (or null string pathname) absolute relative))
2124   (let ((abs (if absolute
2125                  #-clisp (namestring absolute)
2126                  #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
2127                  ""))
2128         (rel (if relative (namestring relative) ""))
2129         )
2130     ;; Make sure the absolute directory ends with a semicolon unless
2131     ;; the pieces are null strings
2132     (unless (or (null-string abs) (null-string rel)
2133                 (char= (char abs (1- (length abs)))
2134                        #\;))
2135       (setq abs (concatenate 'string abs ";")))
2136     ;; Return the concatenate pathnames
2137     (concatenate 'string abs rel)))
2141 (defun append-logical-pnames (absolute relative)
2142   (declare (type (or null string pathname) absolute relative))
2143   (let ((abs (if absolute
2144                  (pathname absolute)
2145                  (make-pathname :directory (list :absolute)
2146                                 :name nil
2147                                 :type nil)
2148                  ))
2149         (rel (if relative
2150                  (pathname relative)
2151                  (make-pathname :directory (list :relative)
2152                                 :name nil
2153                                 :type nil)
2154                  ))
2155         )
2156     ;; The following is messed up because CMUCL and LW use different
2157     ;; defaults for host (in particular LW uses NIL).  Thus
2158     ;; MERGE-PATHNAMES has legitimate different behaviors on both
2159     ;; implementations. Of course this is disgusting, but that is the
2160     ;; way it is and the rest tries to circumvent this crap.
2161     (etypecase abs
2162       (logical-pathname
2163        (etypecase rel
2164          (logical-pathname
2165           (namestring (merge-pathnames rel abs)))
2166          (pathname
2167           ;; The following potentially translates the logical pathname
2168           ;; very early, but we cannot avoid it.
2169           (namestring (merge-pathnames rel (translate-logical-pathname abs))))
2170          ))
2171       (pathname
2172        (namestring (merge-pathnames rel abs)))
2173       )))
2176 ;;; This was a try at appending a subdirectory onto a directory.
2177 ;;; It failed. We're keeping this around to prevent future mistakes
2178 ;;; of a similar sort.
2179 (defun merge-directories (absolute-directory relative-directory)
2180   ;; replace concatenate with something more intelligent
2181   ;; i.e., concatenation won't work with some directories.
2182   ;; it should also behave well if the parent directory
2183   ;; has a filename at the end, or if the relative-directory ain't relative
2184   (when absolute-directory
2185     (setq absolute-directory (pathname-directory absolute-directory)))
2186   (concatenate 'string
2187                (or absolute-directory "")
2188                (or relative-directory "")))
2192 <cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
2195 <cl> (d "~/foo/" "baz/bar.lisp")
2196 "/usr0/mkant/foo/baz/bar.lisp"
2198 <cl> (d "~/foo" "baz/bar.lisp")
2199 "/usr0/mkant/foo/baz/bar.lisp"
2201 <cl> (d "/foo/bar/" "baz/barf.lisp")
2202 "/foo/bar/baz/barf.lisp"
2204 <cl> (d "foo/bar/" "baz/barf.lisp")
2205 "foo/bar/baz/barf.lisp"
2207 <cl> (d "foo/bar" "baz/barf.lisp")
2208 "foo/bar/baz/barf.lisp"
2210 <cl> (d "foo/bar" "/baz/barf.lisp")
2211 "foo/bar//baz/barf.lisp"
2213 <cl> (d "foo/bar" nil)
2214 "foo/bar/"
2216 <cl> (d nil "baz/barf.lisp")
2217 "baz/barf.lisp"
2219 <cl> (d nil nil)
2224 ;;; The following is a change proposed by DTC for SCL.
2225 ;;; Maybe it could be used all the time.
2227 #-scl
2228 (defun new-file-type (pathname type)
2229   ;; why not (make-pathname :type type :defaults pathname)?
2230   (make-pathname
2231    :host (pathname-host pathname)
2232    :device (pathname-device pathname)
2233    :directory (pathname-directory pathname)
2234    :name (pathname-name pathname)
2235    :type type
2236    :version (pathname-version pathname)))
2239 #+scl
2240 (defun new-file-type (pathname type)
2241   ;; why not (make-pathname :type type :defaults pathname)?
2242   (make-pathname
2243    :host (pathname-host pathname :case :common)
2244    :device (pathname-device pathname :case :common)
2245    :directory (pathname-directory pathname :case :common)
2246    :name (pathname-name pathname :case :common)
2247    :type (string-upcase type)
2248    :version (pathname-version pathname :case :common)))
2252 ;;; ********************************
2253 ;;; Component Defstruct ************
2254 ;;; ********************************
2255 (defvar *source-pathname-default* nil
2256   "Default value of :source-pathname keyword in DEFSYSTEM. Set this to
2257    \"\" to avoid having to type :source-pathname \"\" all the time.")
2259 (defvar *binary-pathname-default* nil
2260   "Default value of :binary-pathname keyword in DEFSYSTEM.")
2262 ;;; Removed TIME slot, which has been made unnecessary by the new definition
2263 ;;; of topological-sort.
2265 (defstruct (topological-sort-node (:conc-name topsort-))
2266   (color :white :type (member :gray :black :white))
2267   ;; time
2268   )
2270 (defstruct (component (:include topological-sort-node)
2271                       (:print-function print-component))
2272   (type :file     ; to pacify the CMUCL compiler (:type is alway supplied)
2273         :type (member :defsystem
2274                       :system
2275                       :subsystem
2276                       :module
2277                       :file
2278                       :private-file
2279                       ))
2280   (name nil :type (or symbol string))
2281   (indent 0 :type (mod 1024))           ; Number of characters of indent in
2282                                         ; verbose output to the user.
2283   host                                  ; The pathname host (i.e., "/../a").
2284   device                                ; The pathname device.
2285   source-root-dir                       ; Relative or absolute (starts
2286                                         ; with "/"), directory or file
2287                                         ; (ends with "/").
2288   (source-pathname *source-pathname-default*)
2289   source-extension                      ; A string, e.g., "lisp"
2290                                         ; if NIL, inherit
2291   (binary-pathname *binary-pathname-default*)
2292   binary-root-dir
2293   binary-extension                      ; A string, e.g., "fasl". If
2294                                         ; NIL, uses default for
2295                                         ; machine-type.
2296   package                               ; Package for use-package.
2298   ;; The following three slots are used to provide for alternate compilation
2299   ;; and loading functions for the files contained within a component. If
2300   ;; a component has a compiler or a loader specified, those functions are
2301   ;; used. Otherwise the functions are derived from the language. If no
2302   ;; language is specified, it defaults to Common Lisp (:lisp). Other current
2303   ;; possible languages include :scheme (PseudoScheme) and :c, but the user
2304   ;; can define additional language mappings. Compilation functions should
2305   ;; accept a pathname argument and a :output-file keyword; loading functions
2306   ;; just a pathname argument. The default functions are #'compile-file and
2307   ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to
2308   ;; mix languages.
2309   (language nil :type (or null symbol))
2310   (compiler nil :type (or null symbol function))
2311   (loader   nil :type (or null symbol function))
2312   (compiler-options nil :type list)     ; A list of compiler options to
2313                                         ; use for compiling this
2314                                         ; component.  These must be
2315                                         ; keyword options supported by
2316                                         ; the compiler.
2318   (components () :type list)            ; A list of components
2319                                         ; comprising this component's
2320                                         ; definition.
2321   (depends-on () :type list)            ; A list of the components
2322                                         ; this one depends on. may
2323                                         ; refer only to the components
2324                                         ; at the same level as this
2325                                         ; one.
2326   proclamations                         ; Compiler options, such as
2327                                         ; '(optimize (safety 3)).
2328   initially-do                          ; Form to evaluate before the
2329                                         ; operation.
2330   finally-do                            ; Form to evaluate after the operation.
2331   compile-form                          ; For foreign libraries.
2332   load-form                             ; For foreign libraries.
2334   ;; load-time                          ; The file-write-date of the
2335                                         ; binary/source file loaded.
2337   ;; If load-only is T, will not compile the file on operation :compile.
2338   ;; In other words, for files which are :load-only T, loading the file
2339   ;; satisfies any demand to recompile.
2340   load-only                             ; If T, will not compile this
2341                                         ; file on operation :compile.
2342   ;; If compile-only is T, will not load the file on operation :compile.
2343   ;; Either compiles or loads the file, but not both. In other words,
2344   ;; compiling the file satisfies the demand to load it. This is useful
2345   ;; for PCL defmethod and defclass definitions, which wrap a
2346   ;; (eval-when (compile load eval) ...) around the body of the definition.
2347   ;; This saves time in some lisps.
2348   compile-only                          ; If T, will not load this
2349                                         ; file on operation :compile.
2350   #|| ISI Extension ||#
2351   load-always                           ; If T, will force loading
2352                                         ; even if file has not
2353                                         ; changed.
2354   ;; PVE: add banner
2355   (banner nil :type (or null string))
2357   (documentation nil :type (or null string)) ; Optional documentation slot
2358   )
2361 ;;; To allow dependencies from "foreign systems" like ASDF or one of
2362 ;;; the proprietary ones like ACL or LW.
2364 (defstruct (foreign-system (:include component (type :system)))
2365   kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...)
2366   object ; The actual foreign system object.
2367   )
2370 (defun register-foreign-system (name &key representation kind)
2371   (declare (type (or symbol string) name))
2372   (let ((fs (make-foreign-system :name name
2373                                  :kind kind
2374                                  :object representation)))
2375     (setf (get-system name) fs)))
2379 (define-condition missing-component (simple-condition)
2380   ((name :reader missing-component-name
2381          :initarg :name)
2382    (component :reader missing-component-component
2383               :initarg :component)
2384    )
2385   (:default-initargs :component nil)
2386   (:report (lambda (mmc stream)
2387              (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
2388                      (missing-component-name mmc)
2389                      (missing-component-component mmc))))
2390   )
2392 (define-condition missing-module (missing-component)
2393   ()
2394   (:report (lambda (mmc stream)
2395              (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
2396                      (missing-component-name mmc)
2397                      (missing-component-component mmc))))
2398   )
2400 (define-condition missing-system (missing-module)
2401   ()
2402   (:report (lambda (msc stream)
2403              (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
2404                      (missing-component-name msc)
2405                      (missing-component-component msc))))
2406   )
2410 (defvar *file-load-time-table* (make-hash-table :test #'equal)
2411   "Hash table of file-write-dates for the system definitions and
2412    files in the system definitions.")
2413 (defun component-load-time (component)
2414   (when component
2415     (etypecase component
2416       (string    (gethash component *file-load-time-table*))
2417       (pathname (gethash (namestring component) *file-load-time-table*))
2418       (component
2419        (ecase (component-type component)
2420          (:defsystem
2421           (let* ((name (component-name component))
2422                  (path (when name (compute-system-path name nil))))
2423             (declare (type (or string pathname null) path))
2424             (when path
2425               (gethash (namestring path) *file-load-time-table*))))
2426          ((:file :private-file)
2427           ;; Use only :source pathname to identify component's
2428           ;; load time.
2429           (let ((path (component-full-pathname component :source)))
2430             (when path
2431               (gethash path *file-load-time-table*)))))))))
2433 #-(or :cmu)
2434 (defsetf component-load-time (component) (value)
2435   `(when ,component
2436     (etypecase ,component
2437       (string   (setf (gethash ,component *file-load-time-table*) ,value))
2438       (pathname (setf (gethash (namestring (the pathname ,component))
2439                                *file-load-time-table*)
2440                       ,value))
2441       (component
2442        (ecase (component-type ,component)
2443          (:defsystem
2444           (let* ((name (component-name ,component))
2445                  (path (when name (compute-system-path name nil))))
2446             (declare (type (or string pathname null) path))
2447             (when path
2448               (setf (gethash (namestring path) *file-load-time-table*)
2449                     ,value))))
2450          ((:file :private-file)
2451           ;; Use only :source pathname to identify file.
2452           (let ((path (component-full-pathname ,component :source)))
2453             (when path
2454               (setf (gethash path *file-load-time-table*)
2455                     ,value)))))))
2456     ,value))
2458 #+(or :cmu)
2459 (defun (setf component-load-time) (value component)
2460   (declare
2461    (type (or null string pathname component) component)
2462    (type (or unsigned-byte null) value))
2463   (when component
2464     (etypecase component
2465       (string   (setf (gethash component *file-load-time-table*) value))
2466       (pathname (setf (gethash (namestring (the pathname component))
2467                                *file-load-time-table*)
2468                       value))
2469       (component
2470        (ecase (component-type component)
2471          (:defsystem
2472              (let* ((name (component-name component))
2473                     (path (when name (compute-system-path name nil))))
2474                (declare (type (or string pathname null) path))
2475                (when path
2476                  (setf (gethash (namestring path) *file-load-time-table*)
2477                        value))))
2478          ((:file :private-file)
2479           ;; Use only :source pathname to identify file.
2480           (let ((path (component-full-pathname component :source)))
2481             (when path
2482               (setf (gethash path *file-load-time-table*)
2483                     value)))))))
2484     value))
2487 ;;; compute-system-path --
2489 (defun compute-system-path (module-name definition-pname)
2490   (let* ((module-string-name
2491           (etypecase module-name
2492             (symbol (string-downcase
2493                      (string module-name)))
2494             (string module-name)))
2496          (file-pathname
2497           (make-pathname :name module-string-name
2498                          :type *system-extension*))
2500          (lib-file-pathname
2501           (make-pathname :directory (list :relative module-string-name)
2502                          :name module-string-name
2503                          :type *system-extension*))
2504          )
2505     (or (when definition-pname          ; given pathname for system def
2506           (probe-file definition-pname))
2507         ;; Then the central registry. Note that we also check the current
2508         ;; directory in the registry, but the above check is hard-coded.
2509         (cond (*central-registry*
2510                (if (listp *central-registry*)
2511                    (dolist (registry *central-registry*)
2512                      (let ((file (or (probe-file
2513                                       (append-directories (if (consp registry)
2514                                                               (eval registry)
2515                                                               registry)
2516                                                           file-pathname))
2517                                      (probe-file
2518                                       (append-directories (if (consp registry)
2519                                                               (eval registry)
2520                                                               registry)
2521                                                           lib-file-pathname))
2522                                      ))
2523                            )
2524                        (when file (return file))))
2525                    (or (probe-file (append-directories *central-registry*
2526                                                        file-pathname))
2527                        (probe-file (append-directories *central-registry*
2528                                                        lib-file-pathname))
2529                        ))
2530                )
2531               (t
2532                ;; No central registry. Assume current working directory.
2533                ;; Maybe this should be an error?
2534                (or (probe-file file-pathname)
2535                    (probe-file lib-file-pathname)))))
2536     ))
2539 (defun system-definition-pathname (system-name)
2540   (let ((system (ignore-errors (find-system system-name :error))))
2541     (if system
2542         (let ((system-def-pathname
2543                (make-pathname :type "system"
2544                               :defaults (pathname (component-full-pathname system :source))))
2545               )
2546           (values system-def-pathname
2547                   (probe-file system-def-pathname)))
2548         (values nil nil))))
2555 (defun compute-system-path (module-name definition-pname)
2556   (let* ((filename (format nil "~A.~A"
2557                            (if (symbolp module-name)
2558                                (string-downcase (string module-name))
2559                              module-name)
2560                            *system-extension*)))
2561     (or (when definition-pname          ; given pathname for system def
2562           (probe-file definition-pname))
2563         ;; Then the central registry. Note that we also check the current
2564         ;; directory in the registry, but the above check is hard-coded.
2565         (cond (*central-registry*
2566                (if (listp *central-registry*)
2567                    (dolist (registry *central-registry*)
2568                      (let ((file (probe-file
2569                                   (append-directories (if (consp registry)
2570                                                           (eval registry)
2571                                                         registry)
2572                                                       filename))))
2573                        (when file (return file))))
2574                  (probe-file (append-directories *central-registry*
2575                                                  filename))))
2576               (t
2577                ;; No central registry. Assume current working directory.
2578                ;; Maybe this should be an error?
2579                (probe-file filename))))))
2583 (defvar *reload-systems-from-disk* t
2584   "If T, always tries to reload newer system definitions from disk.
2585    Otherwise first tries to find the system definition in the current
2586    environment.")
2588 (defun find-system (system-name &optional (mode :ask) definition-pname)
2589   "Returns the system named SYSTEM-NAME.
2590 If not already loaded, loads it, depending on the value of
2591 *RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK,
2592 :ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default.
2593 This allows OPERATE-ON-SYSTEM to work on non-loaded as well as
2594 loaded system definitions. DEFINITION-PNAME is the pathname for
2595 the system definition, if provided."
2596   (ecase mode
2597     (:ask
2598      (or (get-system system-name)
2599          (when (y-or-n-p-wait
2600                 #\y 20
2601                 "System ~A not loaded. Shall I try loading it? "
2602                 system-name)
2603            (find-system system-name :load definition-pname))))
2604     (:error
2605      (or (get-system system-name)
2606          (error 'missing-system :name system-name)))
2607     (:load-or-nil
2608      (let ((system (get-system system-name)))
2609        (or (unless *reload-systems-from-disk* system)
2610            ;; If SYSTEM-NAME is a symbol, it will lowercase the
2611            ;; symbol's string.
2612            ;; If SYSTEM-NAME is a string, it doesn't change the case of the
2613            ;; string. So if case matters in the filename, use strings, not
2614            ;; symbols, wherever the system is named.
2615            (when (foreign-system-p system)
2616              (warn "Foreing system ~S cannot be reloaded by MK:DEFSYSTEM.")
2617              (return-from find-system nil))
2618            (let ((path (compute-system-path system-name definition-pname)))
2619              (when (and path
2620                         (or (null system)
2621                             (null (component-load-time path))
2622                             (< (component-load-time path)
2623                                (file-write-date path))))
2624                (tell-user-generic
2625                 (format nil "Loading system ~A from file ~A"
2626                         system-name
2627                         path))
2628                (load path)
2629                (setf system (get-system system-name))
2630                (when system
2631                  (setf (component-load-time path)
2632                        (file-write-date path))))
2633              system)
2634            system)))
2635     (:load
2636      (or (unless *reload-systems-from-disk* (get-system system-name))
2637          (when (foreign-system-p (get-system system-name))
2638            (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM.")
2639            (return-from find-system nil))
2640          (or (find-system system-name :load-or-nil definition-pname)
2641              (error "Can't find system named ~s." system-name))))))
2644 (defun print-component (component stream depth)
2645   (declare (ignore depth))
2646   (format stream "#<~:@(~A~): ~A>"
2647           (component-type component)
2648           (component-name component)))
2651 (defun describe-system (name &optional (stream *standard-output*))
2652   "Prints a description of the system to the stream. If NAME is the
2653    name of a system, gets it and prints a description of the system.
2654    If NAME is a component, prints a description of the component."
2655   (let ((system (if (typep name 'component) name (find-system name :load))))
2656     (format stream "~&~A ~A: ~
2657                     ~@[~&   Host: ~A~]~
2658                     ~@[~&   Device: ~A~]~
2659                     ~@[~&   Package: ~A~]~
2660                     ~&   Source: ~@[~A~] ~@[~A~] ~@[~A~]~
2661                     ~&   Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
2662                     ~@[~&   Depends On: ~A ~]~&   Components:~{~15T~A~&~}"
2663             (component-type system)
2664             (component-name system)
2665             (component-host system)
2666             (component-device system)
2667             (component-package system)
2668             (component-root-dir system :source)
2669             (component-pathname system :source)
2670             (component-extension system :source)
2671             (component-root-dir system :binary)
2672             (component-pathname system :binary)
2673             (component-extension system :binary)
2674             (component-depends-on system)
2675             (component-components system))
2676     #||(when recursive
2677       (dolist (component (component-components system))
2678         (describe-system component stream recursive)))||#
2679     system))
2681 (defun canonicalize-component-name (component)
2682   ;; Within the component, the name is a string.
2683   (if (typep (component-name component) 'string)
2684       ;; Unnecessary to change it, so just return it, same case
2685       (component-name component)
2686     ;; Otherwise, make it a downcase string -- important since file
2687     ;; names are often constructed from component names, and unix
2688     ;; prefers lowercase as a default.
2689     (setf (component-name component)
2690           (string-downcase (string (component-name component))))))
2692 (defun component-pathname (component type)
2693   (when component
2694     (ecase type
2695       (:source (component-source-pathname component))
2696       (:binary (component-binary-pathname component))
2697       (:error  (component-error-pathname component)))))
2698 (defun component-error-pathname (component)
2699   (let ((binary (component-pathname component :binary)))
2700     (new-file-type binary *compile-error-file-type*)))
2701 (defsetf component-pathname (component type) (value)
2702   `(when ,component
2703      (ecase ,type
2704        (:source (setf (component-source-pathname ,component) ,value))
2705        (:binary (setf (component-binary-pathname ,component) ,value)))))
2707 (defun component-root-dir (component type)
2708   (when component
2709     (ecase type
2710       (:source (component-source-root-dir component))
2711       ((:binary :error) (component-binary-root-dir component))
2712       )))
2713 (defsetf component-root-dir (component type) (value)
2714   `(when ,component
2715      (ecase ,type
2716        (:source (setf (component-source-root-dir ,component) ,value))
2717        (:binary (setf (component-binary-root-dir ,component) ,value)))))
2719 (defvar *source-pathnames-table* (make-hash-table :test #'equal)
2720   "Table which maps from components to full source pathnames.")
2721 (defvar *binary-pathnames-table* (make-hash-table :test #'equal)
2722   "Table which maps from components to full binary pathnames.")
2723 (defparameter *reset-full-pathname-table* t
2724   "If T, clears the full-pathname tables before each call to
2725    OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance
2726    after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could
2727    result in changes to system and language definitions to not take
2728    effect, and so should be used with caution.")
2729 (defun clear-full-pathname-tables ()
2730   (clrhash *source-pathnames-table*)
2731   (clrhash *binary-pathnames-table*))
2733 (defun component-full-pathname (component type &optional (version *version*))
2734   (when component
2735     (case type
2736       (:source
2737        (let ((old (gethash component *source-pathnames-table*)))
2738          (or old
2739              (let ((new (component-full-pathname-i component type version)))
2740                (setf (gethash component *source-pathnames-table*) new)
2741                new))))
2742       (:binary
2743         (let ((old (gethash component *binary-pathnames-table*)))
2744          (or old
2745              (let ((new (component-full-pathname-i component type version)))
2746                (setf (gethash component *binary-pathnames-table*) new)
2747                new))))
2748       (otherwise
2749        (component-full-pathname-i component type version)))))
2751 (defun component-full-pathname-i (component type
2752                                             &optional (version *version*)
2753                                             &aux version-dir version-replace)
2754   ;; If the pathname-type is :binary and the root pathname is null,
2755   ;; distribute the binaries among the sources (= use :source pathname).
2756   ;; This assumes that the component's :source pathname has been set
2757   ;; before the :binary one.
2758   (if version
2759       (multiple-value-setq (version-dir version-replace)
2760         (translate-version version))
2761       (setq version-dir *version-dir* version-replace *version-replace*))
2762   ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace)
2763   (let ((pathname
2764          (append-directories
2765           (if version-replace
2766               version-dir
2767               (append-directories (component-root-dir component type)
2768                                   version-dir))
2769           (component-pathname component type))))
2771     ;; When a logical pathname is used, it must first be translated to
2772     ;; a physical pathname. This isn't strictly correct. What should happen
2773     ;; is we fill in the appropriate slots of the logical pathname, and
2774     ;; then return the logical pathname for use by compile-file & friends.
2775     ;; But calling translate-logical-pathname to return the actual pathname
2776     ;; should do for now.
2778     ;; (format t "pathname = ~A~%" pathname)
2779     ;; (format t "type = ~S~%" (component-extension component type))
2781     ;; 20000303 Marco Antoniotti
2782     ;; Changed the following according to suggestion by Ray Toy.  I
2783     ;; just collapsed the tests for "logical-pathname-ness" into a
2784     ;; single test (heavy, but probably very portable) and added the
2785     ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES
2786     ;; beacuse of possible null names (e.g. :defsystem components)
2787     ;; causing problems with the subsequenct call to NAMESTRING.
2788     ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname)
2789     (cond ((pathname-logical-p pathname) ; See definition of test above.
2790            (setf pathname
2791                  (merge-pathnames pathname
2792                                   (make-pathname
2793                                    :name (component-name component)
2794                                    :type (component-extension component
2795                                                               type))))
2796            ;;(format t "new path = ~A~%" pathname)
2797            (namestring (translate-logical-pathname pathname)))
2798           (t
2799            (namestring
2800             (make-pathname :host (when (component-host component)
2801                                    ;; MCL2.0b1 and ACLPC cause an error on
2802                                    ;; (pathname-host nil)
2803                                    (pathname-host (component-host component)
2804                                                   #+scl :case #+scl :common
2805                                                   ))
2806                            :directory (pathname-directory pathname
2807                                                   #+scl :case #+scl :common
2808                                                   )
2809                            ;; Use :directory instead of :defaults
2810                            :name (pathname-name pathname
2811                                                   #+scl :case #+scl :common
2812                                                   )
2813                            :type #-scl (component-extension component type)
2814                                  #+scl (string-upcase
2815                                         (component-extension component type))
2816                            :device
2817                            #+sbcl
2818                            :unspecific
2819                            #-(or :sbcl)
2820                            (let ((dev (component-device component)))
2821                              (if dev
2822                                  (pathname-device dev
2823                                                   #+scl :case #+scl :common
2824                                                   )
2825                                  (pathname-device pathname
2826                                                   #+scl :case #+scl :common
2827                                                   )))
2828                            ;; :version :newest
2829                            ))))))
2831 ;;; What about CMU17 :device :unspecific in the above?
2833 #-lispworks
2834 (defun translate-version (version)
2835   ;; Value returns the version directory and whether it replaces
2836   ;; the entire root (t) or is a subdirectory.
2837   ;; Version may be nil to signify no subdirectory,
2838   ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
2839   ;; specifies a subdirectory of the root, or
2840   ;; a string, which replaces the root.
2841   (cond ((null version)
2842          (values "" nil))
2843         ((symbolp version)
2844          (values (let ((sversion (string version)))
2845                    (if (find-if #'lower-case-p sversion)
2846                        sversion
2847                        (string-downcase sversion)))
2848                  nil))
2849         ((stringp version)
2850          (values version t))
2851         (t (error "~&; Illegal version ~S" version))))
2854 ;;; Looks like LW has a bug in MERGE-PATHNAMES.
2856 ;;;  (merge-pathnames "" "LP:foo;bar;") ==> "LP:"
2858 ;;; Which is incorrect.
2859 ;;; The change here ensures that the result of TRANSLATE-VERSION is
2860 ;;; appropriate.
2862 #+lispworks
2863 (defun translate-version (version)
2864   ;; Value returns the version directory and whether it replaces
2865   ;; the entire root (t) or is a subdirectory.
2866   ;; Version may be nil to signify no subdirectory,
2867   ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
2868   ;; specifies a subdirectory of the root, or
2869   ;; a string, which replaces the root.
2870   (cond ((null version)
2871          (values (pathname "") nil))
2872         ((symbolp version)
2873          (values (let ((sversion (string version)))
2874                    (if (find-if #'lower-case-p sversion)
2875                        (pathname sversion)
2876                        (pathname (string-downcase sversion))))
2877                  nil))
2878         ((stringp version)
2879          (values (pathname version) t))
2880         (t (error "~&; Illegal version ~S" version))))
2885 (defun component-extension (component type &key local)
2886   (ecase type
2887     (:source (or (component-source-extension component)
2888                  (unless local
2889                    (default-source-extension component)) ; system default
2890                  ;; (and (component-language component))
2891                  ))
2892     (:binary (or (component-binary-extension component)
2893                  (unless local
2894                    (default-binary-extension component)) ; system default
2895                  ;; (and (component-language component))
2896                  ))
2897     (:error  *compile-error-file-type*)))
2900 (defsetf component-extension (component type) (value)
2901   `(ecase ,type
2902      (:source (setf (component-source-extension ,component) ,value))
2903      (:binary (setf (component-binary-extension ,component) ,value))
2904      (:error  (setf *compile-error-file-type* ,value))))
2906 ;;; ********************************
2907 ;;; System Definition **************
2908 ;;; ********************************
2909 (defun create-component (type name definition-body &optional parent (indent 0))
2910   (let ((component (apply #'make-component
2911                           :type type
2912                           :name name
2913                           :indent indent
2914                           definition-body)))
2915     ;; Set up :load-only attribute
2916     (unless (find :load-only definition-body)
2917       ;; If the :load-only attribute wasn't specified,
2918       ;; inherit it from the parent. If no parent, default it to nil.
2919       (setf (component-load-only component)
2920             (when parent
2921               (component-load-only parent))))
2922     ;; Set up :compile-only attribute
2923     (unless (find :compile-only definition-body)
2924       ;; If the :compile-only attribute wasn't specified,
2925       ;; inherit it from the parent. If no parent, default it to nil.
2926       (setf (component-compile-only component)
2927             (when parent
2928               (component-compile-only parent))))
2930     ;; Set up :compiler-options attribute
2931     (unless (find :compiler-options definition-body)
2932       ;; If the :compiler-option attribute wasn't specified,
2933       ;; inherit it from the parent.  If no parent, default it to NIL.
2934       (setf (component-compiler-options component)
2935             (when parent
2936               (component-compiler-options parent))))
2938     #|| ISI Extension ||#
2939     ;; Set up :load-always attribute
2940     (unless (find :load-always definition-body)
2941       ;; If the :load-always attribute wasn't specified,
2942       ;; inherit it from the parent. If no parent, default it to nil.
2943       (setf (component-load-always component)
2944             (when parent
2945               (component-load-always parent))))
2947     ;; Initializations/after makes
2948     (canonicalize-component-name component)
2950     ;; Inherit package from parent if not specified.
2951     (setf (component-package component)
2952           (or (component-package component)
2953               (when parent (component-package parent))))
2955     ;; Type specific setup:
2956     (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
2957       (setf (get-system name) component)
2958       #|(unless (component-language component)
2959         (setf (component-language component) :lisp))|#)
2961     ;; Set up the component's pathname
2962     (create-component-pathnames component parent)
2964     ;; If there are any components of the component, expand them too.
2965     (expand-component-components component (+ indent 2))
2967     ;; Make depends-on refer to structs instead of names.
2968     (link-component-depends-on (component-components component))
2970     ;; Design Decision: Topologically sort the dependency graph at
2971     ;; time of definition instead of at time of use. Probably saves a
2972     ;; little bit of time for the user.
2974     ;; Topological Sort the components at this level.
2975     (setf (component-components component)
2976           (topological-sort (component-components component)))
2978     ;; Return the component.
2979     component))
2982 ;;; defsystem --
2983 ;;; The main macro.
2985 ;;; 2002-11-22 Marco Antoniotti
2986 ;;; Added code to achieve a first cut "pathname less" operation,
2987 ;;; following the ideas in ASDF.  If the DEFSYSTEM form is loaded from
2988 ;;; a file, then the location of the file (intended as a directory) is
2989 ;;; computed from *LOAD-PATHNAME* and stored as the :SOURCE-PATHNAME
2990 ;;; of the system.
2992 (defmacro defsystem (name &rest definition-body)
2993   (unless (find :source-pathname definition-body)
2994     (setf definition-body
2995           (list* :source-pathname
2996                  '(when *load-pathname*
2997                         (make-pathname :name nil
2998                                        :type nil
2999                                        :defaults *load-pathname*))
3000                  definition-body)))
3001   `(create-component :defsystem ',name ',definition-body nil 0))
3003 (defun create-component-pathnames (component parent)
3004   ;; Set up language-specific defaults
3006   (setf (component-language component)
3007         (or (component-language component) ; for local defaulting
3008             (when parent                ; parent's default
3009               (component-language parent))))
3011   (setf (component-compiler component)
3012         (or (component-compiler component) ; for local defaulting
3013             (when parent                ; parent's default
3014               (component-compiler parent))))
3015   (setf (component-loader component)
3016         (or (component-loader component) ; for local defaulting
3017             (when parent                ; parent's default
3018               (component-loader parent))))
3020   ;; Evaluate the root dir arg
3021   (setf (component-root-dir component :source)
3022         (eval (component-root-dir component :source)))
3023   (setf (component-root-dir component :binary)
3024         (eval (component-root-dir component :binary)))
3026   ;; Evaluate the pathname arg
3027   (setf (component-pathname component :source)
3028         (eval (component-pathname component :source)))
3029   (setf (component-pathname component :binary)
3030         (eval (component-pathname component :binary)))
3032   ;; Pass along the host and devices
3033   (setf (component-host component)
3034         (or (component-host component)
3035             (when parent (component-host parent))
3036             (pathname-host *default-pathname-defaults*)))
3037   (setf (component-device component)
3038         (or (component-device component)
3039             (when parent (component-device parent))))
3041   ;; Set up extension defaults
3042   (setf (component-extension component :source)
3043         (or (component-extension component :source
3044                                  :local #| (component-language component) |#
3045                                  t
3046                                  ) ; local default
3047             (when (component-language component)
3048               (default-source-extension component))
3049             (when parent                ; parent's default
3050               (component-extension parent :source))))
3051   (setf (component-extension component :binary)
3052         (or (component-extension component :binary
3053                                  :local #| (component-language component) |#
3054                                  t
3055                                  ) ; local default
3056             (when (component-language component)
3057               (default-binary-extension component))
3058             (when parent                ; parent's default
3059               (component-extension parent :binary))))
3061   ;; Set up pathname defaults -- expand with parent
3062   ;; We must set up the source pathname before the binary pathname
3063   ;; to allow distribution of binaries among the sources to work.
3064   (generate-component-pathname component parent :source)
3065   (generate-component-pathname component parent :binary))
3068 ;; maybe file's inheriting of pathnames should be moved elsewhere?
3069 (defun generate-component-pathname (component parent pathname-type)
3070   ;; Pieces together a pathname for the component based on its component-type.
3071   ;; Assumes source defined first.
3072   ;; Null binary pathnames inherit from source instead of the component's
3073   ;; name. This allows binaries to be distributed among the source if
3074   ;; binary pathnames are not specified. Or if the root directory is
3075   ;; specified for binaries, but no module directories, it inherits
3076   ;; parallel directory structure.
3077   (case (component-type component)
3078     ((:defsystem :system)               ; Absolute Pathname
3079      ;; Set the root-dir to be the absolute pathname
3080      (setf (component-root-dir component pathname-type)
3081            (or (component-pathname component pathname-type)
3082                (when (eq pathname-type :binary)
3083                  ;; When the binary root is nil, use source.
3084                  (component-root-dir component :source))) )
3085      ;; Set the relative pathname to be nil
3086      (setf (component-pathname component pathname-type)
3087            nil));; should this be "" instead?
3088     ;; If the name of the component-pathname is nil, it
3089     ;; defaults to the name of the component. Use "" to
3090     ;; avoid this defaulting.
3091     (:private-file                      ; Absolute Pathname
3092      ;; Root-dir is the directory part of the pathname
3093      (setf (component-root-dir component pathname-type)
3094            ""
3095            #+ignore(or (when (component-pathname component pathname-type)
3096                          (pathname-directory
3097                           (component-pathname component pathname-type)))
3098                        (when (eq pathname-type :binary)
3099                          ;; When the binary root is nil, use source.
3100                          (component-root-dir component :source)))
3101            )
3102      ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
3103      ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
3104      ;; wind up being "", which is wrong for :file components. So replace
3105      ;; them with NIL.
3106      (when (null-string (component-pathname component pathname-type))
3107        (setf (component-pathname component pathname-type) nil))
3108      ;; The relative pathname is the name part
3109      (setf (component-pathname component pathname-type)
3110            (or (when (and (eq pathname-type :binary)
3111                           (null (component-pathname component :binary)))
3112                  ;; When the binary-pathname is nil use source.
3113                  (component-pathname component :source))
3114                (or (when (component-pathname component pathname-type)
3115 ;                    (pathname-name )
3116                      (component-pathname component pathname-type))
3117                    (component-name component)))))
3118     ((:module :subsystem)                       ; Pathname relative to parent.
3119      ;; Inherit root-dir from parent
3120      (setf (component-root-dir component pathname-type)
3121            (component-root-dir parent pathname-type))
3122      ;; Tack the relative-dir onto the pathname
3123      (setf (component-pathname component pathname-type)
3124            (or (when (and (eq pathname-type :binary)
3125                           (null (component-pathname component :binary)))
3126                  ;; When the binary-pathname is nil use source.
3127                  (component-pathname component :source))
3128                (append-directories
3129                 (component-pathname parent pathname-type)
3130                 (or (component-pathname component pathname-type)
3131                     (component-name component))))))
3132     (:file                              ; Pathname relative to parent.
3133      ;; Inherit root-dir from parent
3134      (setf (component-root-dir component pathname-type)
3135            (component-root-dir parent pathname-type))
3136      ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
3137      ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
3138      ;; wind up being "", which is wrong for :file components. So replace
3139      ;; them with NIL.
3140      (when (null-string (component-pathname component pathname-type))
3141        (setf (component-pathname component pathname-type) nil))
3142      ;; Tack the relative-dir onto the pathname
3143      (setf (component-pathname component pathname-type)
3144            (or (append-directories
3145                 (component-pathname parent pathname-type)
3146                 (or (component-pathname component pathname-type)
3147                     (component-name component)
3148                     (when (eq pathname-type :binary)
3149                       ;; When the binary-pathname is nil use source.
3150                       (component-pathname component :source)))))))
3151     ))
3153 #|| ;; old version
3154 (defun expand-component-components (component &optional (indent 0))
3155   (let ((definitions (component-components component)))
3156     (setf (component-components component)
3157           (remove-if #'null
3158                      (mapcar #'(lambda (definition)
3159                                  (expand-component-definition definition
3160                                                               component
3161                                                               indent))
3162                              definitions)))))
3164 ;; new version
3165 (defun expand-component-components (component &optional (indent 0))
3166   (let ((definitions (component-components component)))
3167     (if (eq (car definitions) :serial)
3168         (setf (component-components component)
3169               (expand-serial-component-chain (cdr definitions)
3170                                              component indent))
3171         (setf (component-components component)
3172               (expand-component-definitions definitions component indent)))))
3174 (defun expand-component-definitions (definitions parent &optional (indent 0))
3175   (let ((components nil))
3176     (dolist (definition definitions)
3177       (let ((new (expand-component-definition definition parent indent)))
3178         (when new (push new components))))
3179     (nreverse components)))
3181 (defun expand-serial-component-chain (definitions parent &optional (indent 0))
3182   (let ((previous nil)
3183         (components nil))
3184     (dolist (definition definitions)
3185       (let ((new (expand-component-definition definition parent indent)))
3186         (when new
3187           ;; Make this component depend on the previous one. Since
3188           ;; we don't know the form of the definition, we have to
3189           ;; expand it first.
3190           (when previous (pushnew previous (component-depends-on new)))
3191           ;; The dependencies will be linked later, so we use the name
3192           ;; instead of the actual component.
3193           (setq previous (component-name new))
3194           ;; Save the new component.
3195           (push new components))))
3196     ;; Return the list of expanded components, in appropriate order.
3197     (nreverse components)))
3200 (defparameter *enable-straz-absolute-string-hack* nil
3201   "Special hack requested by Steve Strassman, where the shorthand
3202    that specifies a list of components as a list of strings also
3203    recognizes absolute pathnames and treats them as files of type
3204    :private-file instead of type :file. Defaults to NIL, because I
3205    haven't tested this.")
3206 (defun absolute-file-namestring-p (string)
3207   ;; If a FILE namestring starts with a slash, or is a logical pathname
3208   ;; as implied by the existence of a colon in the filename, assume it
3209   ;; represents an absolute pathname.
3210   (or (find #\: string :test #'char=)
3211       (and (not (null-string string))
3212            (char= (char string 0) #\/))))
3214 (defun expand-component-definition (definition parent &optional (indent 0))
3215   ;; Should do some checking for malformed definitions here.
3216   (cond ((null definition) nil)
3217         ((stringp definition)
3218          ;; Strings are assumed to be of type :file
3219          (if (and *enable-straz-absolute-string-hack*
3220                   (absolute-file-namestring-p definition))
3221              ;; Special hack for Straz
3222              (create-component :private-file definition nil parent indent)
3223            ;; Normal behavior
3224            (create-component :file definition nil parent indent)))
3225         ((and (listp definition)
3226               (not (member (car definition)
3227                            '(:defsystem :system :subsystem
3228                              :module :file :private-file))))
3229          ;; Lists whose first element is not a component type
3230          ;; are assumed to be of type :file
3231          (create-component :file
3232                            (car definition)
3233                            (cdr definition)
3234                            parent
3235                            indent))
3236         ((listp definition)
3237          ;; Otherwise, it is (we hope) a normal form definition
3238          (create-component (car definition)   ; type
3239                            (cadr definition)  ; name
3240                            (cddr definition)  ; definition body
3241                            parent             ; parent
3242                            indent)            ; indent
3243          )))
3245 (defun link-component-depends-on (components)
3246   (dolist (component components)
3247     (unless (and *system-dependencies-delayed*
3248                  (eq (component-type component) :defsystem))
3249       (setf (component-depends-on component)
3250             (mapcar #'(lambda (dependency)
3251                         (let ((parent (find (string dependency) components
3252                                             :key #'component-name
3253                                             :test #'string-equal)))
3254                           (cond (parent parent)
3255                                 ;; make it more intelligent about the following
3256                                 (t (warn "Dependency ~S of component ~S not found."
3257                                          dependency component)))))
3259                     (component-depends-on component))))))
3261 ;;; ********************************
3262 ;;; Topological Sort the Graph *****
3263 ;;; ********************************
3265 ;;; New version of topological sort suggested by rs2. Even though
3266 ;;; this version avoids the call to sort, in practice it isn't faster. It
3267 ;;; does, however, eliminate the need to have a TIME slot in the
3268 ;;; topological-sort-node defstruct.
3269 (defun topological-sort (list &aux (sorted-list nil))
3270   (labels ((dfs-visit (znode)
3271               (setf (topsort-color znode) :gray)
3272               (unless (and *system-dependencies-delayed*
3273                            (eq (component-type znode) :system))
3274                 (dolist (child (component-depends-on znode))
3275                   (cond ((eq (topsort-color child) :white)
3276                          (dfs-visit child))
3277                         ((eq (topsort-color child) :gray)
3278                          (format t "~&Detected cycle containing ~A" child)))))
3279               (setf (topsort-color znode) :black)
3280               (push znode sorted-list)))
3281     (dolist (znode list)
3282       (setf (topsort-color znode) :white))
3283     (dolist (znode list)
3284       (when (eq (topsort-color znode) :white)
3285         (dfs-visit znode)))
3286     (nreverse sorted-list)))
3289 ;;; Older version of topological sort.
3290 (defun topological-sort (list &aux (time 0))
3291   ;; The algorithm works by calling depth-first-search to compute the
3292   ;; blackening times for each vertex, and then sorts the vertices into
3293   ;; reverse order by blackening time.
3294   (labels ((dfs-visit (node)
3295               (setf (topsort-color node) 'gray)
3296               (unless (and *system-dependencies-delayed*
3297                            (eq (component-type node) :defsystem))
3298                 (dolist (child (component-depends-on node))
3299                   (cond ((eq (topsort-color child) 'white)
3300                          (dfs-visit child))
3301                         ((eq (topsort-color child) 'gray)
3302                          (format t "~&Detected cycle containing ~A" child)))))
3303                       (setf (topsort-color node) 'black)
3304                       (setf (topsort-time node) time)
3305                       (incf time)))
3306     (dolist (node list)
3307       (setf (topsort-color node) 'white))
3308     (dolist (node list)
3309       (when (eq (topsort-color node) 'white)
3310         (dfs-visit node)))
3311     (sort list #'< :key #'topsort-time)))
3314 ;;; ********************************
3315 ;;; Output to User *****************
3316 ;;; ********************************
3317 ;;; All output to the user is via the tell-user functions.
3319 (defun split-string (string &key (item #\space) (test #'char=))
3320   ;; Splits the string into substrings at spaces.
3321   (let ((len (length string))
3322         (index 0) result)
3323     (dotimes (i len
3324                 (progn (unless (= index len)
3325                          (push (subseq string index) result))
3326                        (reverse result)))
3327       (when (funcall test (char string i) item)
3328         (unless (= index i);; two spaces in a row
3329           (push (subseq string index i) result))
3330         (setf index (1+ i))))))
3332 ;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it
3333 ;; because of an AKCL bug.
3334 ;; KGK suggests using an 8 instead, but 1 does nicely.
3335 (defun prompt-string (component)
3336   (format nil "; ~:[~;TEST:~]~V,1@T "
3337           *oos-test*
3338           (component-indent component)))
3341 (defun format-justified-string (prompt contents)
3342   (format t (concatenate 'string
3343                          "~%"
3344                          prompt
3345                          "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
3346           (split-string contents))
3347   (finish-output *standard-output*))
3350 (defun format-justified-string (prompt contents &optional (width 80)
3351                                        (stream *standard-output*))
3352   (let ((prompt-length (+ 2 (length prompt))))
3353     (cond ((< (+ prompt-length (length contents)) width)
3354            (format stream "~%~A- ~A" prompt contents))
3355           (t
3356            (format stream "~%~A-" prompt)
3357            (do* ((cursor prompt-length)
3358                  (contents (split-string contents) (cdr contents))
3359                  (content (car contents) (car contents))
3360                  (content-length (1+ (length content)) (1+ (length content))))
3361                ((null contents))
3362              (cond ((< (+ cursor content-length) width)
3363                     (incf cursor content-length)
3364                     (format stream " ~A" content))
3365                    (t
3366                     (setf cursor (+ prompt-length content-length))
3367                     (format stream "~%~A  ~A" prompt content)))))))
3368   (finish-output stream))
3370 (defun tell-user (what component &optional type no-dots force)
3371   (when (or *oos-verbose* force)
3372     (format-justified-string (prompt-string component)
3373      (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]"
3374              ;; To have better messages, wrap the following around the
3375              ;; case statement:
3376              ;;(if (find (component-type component)
3377              ;;    '(:defsystem :system :subsystem :module))
3378              ;;  "Checking"
3379              ;;  (case ...))
3380              ;; This gets around the problem of DEFSYSTEM reporting
3381              ;; that it's loading a module, when it eventually never
3382              ;; loads any of the files of the module.
3383              (case what
3384                ((compile :compile)
3385                 (if (component-load-only component)
3386                     ;; If it is :load-only t, we're loading.
3387                     "Loading"
3388                     ;; Otherwise we're compiling.
3389                     "Compiling"))
3390                ((load :load) "Loading")
3391                (otherwise what))
3392              (component-type component)
3393              (or (when type
3394                    (component-full-pathname component type))
3395                  (component-name component))
3396              (and *tell-user-when-done*
3397                   (not no-dots))))))
3399 (defun tell-user-done (component &optional force no-dots)
3400   ;; test is no longer really used, but we're leaving it in.
3401   (when (and *tell-user-when-done*
3402              (or *oos-verbose* force))
3403     (format t "~&~A~:[~;...~] Done."
3404             (prompt-string component) (not no-dots))
3405     (finish-output *standard-output*)))
3407 (defmacro with-tell-user ((what component &optional type no-dots force) &body body)
3408   `(progn
3409      (tell-user ,what ,component ,type ,no-dots ,force)
3410      ,@body
3411      (tell-user-done ,component ,force ,no-dots)))
3413 (defun tell-user-no-files (component &optional force)
3414   (when (or *oos-verbose* force)
3415     (format-justified-string (prompt-string component)
3416       (format nil "Source file ~A ~
3417              ~:[and binary file ~A ~;~]not found, not loading."
3418               (component-full-pathname component :source)
3419               (or *load-source-if-no-binary* *load-source-instead-of-binary*)
3420               (component-full-pathname component :binary)))))
3422 (defun tell-user-require-system (name parent)
3423   (when *oos-verbose*
3424     (format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
3425             *oos-test* (component-name parent) name)
3426     (finish-output *standard-output*)))
3428 (defun tell-user-generic (string)
3429   (when *oos-verbose*
3430     (format t "~&; ~:[~;TEST:~] - ~A"
3431             *oos-test* string)
3432     (finish-output *standard-output*)))
3434 ;;; ********************************
3435 ;;; Y-OR-N-P-WAIT ******************
3436 ;;; ********************************
3437 ;;; Y-OR-N-P-WAIT is like Y-OR-N-P, but will timeout after a specified
3438 ;;; number of seconds. I should really replace this with a call to
3439 ;;; the Y-OR-N-P-WAIT defined in the query.cl package and include that
3440 ;;; instead.
3442 (defparameter *use-timeouts* t
3443   "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves
3444    like Y-OR-N-P. This is provided for users whose lisps don't handle
3445    read-char-no-hang properly.")
3447 (defparameter *clear-input-before-query* t
3448   "If T, y-or-n-p-wait will clear the input before printing the prompt
3449    and asking the user for input.")
3451 ;;; The higher *sleep-amount* is, the less consing, but the lower the
3452 ;;; responsiveness.
3453 (defparameter *sleep-amount* #-CMU 0.1 #+CMU 1.0
3454     "Amount of time to sleep between checking query-io. In multiprocessing
3455      Lisps, this allows other processes to continue while we busy-wait. If
3456      0, skips call to SLEEP.")
3458 (defun internal-real-time-in-seconds ()
3459   (get-universal-time))
3461 (defun read-char-wait (&optional (timeout 20) input-stream
3462                                  (eof-error-p t) eof-value
3463                                  &aux peek)
3464   (do ((start (internal-real-time-in-seconds)))
3465       ((or (setq peek (listen input-stream))
3466            (< (+ start timeout) (internal-real-time-in-seconds)))
3467        (when peek
3468          ;; was read-char-no-hang
3469          (read-char input-stream eof-error-p eof-value)))
3470     (unless (zerop *sleep-amount*)
3471       (sleep *sleep-amount*))))
3473 ;;; Lots of lisps, especially those that run on top of UNIX, do not get
3474 ;;; their input one character at a time, but a whole line at a time because
3475 ;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait
3476 ;;; to not always work as expected.
3478 ;;; I wish lisp did all its own buffering (turning off UNIX input line
3479 ;;; buffering by putting the UNIX into CBREAK mode). Of course, this means
3480 ;;; that we lose input editing, but why can't the lisp implement this?
3482 (defun y-or-n-p-wait (&optional (default #\y) (timeout 20)
3483                                 format-string &rest args)
3484   "Y-OR-N-P-WAIT prints the message, if any, and reads characters from
3485    *QUERY-IO* until the user enters y, Y or space as an affirmative, or either
3486    n or N as a negative answer, or the timeout occurs. It asks again if
3487    you enter any other characters."
3488   (when *clear-input-before-query* (clear-input *query-io*))
3489   (when format-string
3490     (fresh-line *query-io*)
3491     (apply #'format *query-io* format-string args)
3492     ;; FINISH-OUTPUT needed for CMU and other places which don't handle
3493     ;; output streams nicely. This prevents it from continuing and
3494     ;; reading the query until the prompt has been printed.
3495     (finish-output *query-io*))
3496   (loop
3497    (let* ((read-char (if *use-timeouts*
3498                          (read-char-wait timeout *query-io* nil nil)
3499                          (read-char *query-io*)))
3500           (char (or read-char default)))
3501      ;; We need to ignore #\newline because otherwise the bugs in
3502      ;; clear-input will cause y-or-n-p-wait to print the "Type ..."
3503      ;; message every time... *sigh*
3504      ;; Anyway, we might want to use this to ignore whitespace once
3505      ;; clear-input is fixed.
3506      (unless (find char '(#\tab #\newline #\return))
3507        (when (null read-char)
3508          (format *query-io* "~@[~A~]" default)
3509          (finish-output *query-io*))
3510        (cond ((null char) (return t))
3511              ((find char '(#\y #\Y #\space) :test #'char=) (return t))
3512              ((find char '(#\n #\N) :test #'char=) (return nil))
3513              (t
3514               (when *clear-input-before-query* (clear-input *query-io*))
3515               (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ")
3516               (when format-string
3517                 (fresh-line *query-io*)
3518                 (apply #'format *query-io* format-string args))
3519               (finish-output *query-io*)))))))
3522 (y-or-n-p-wait #\y 20 "What? ")
3523 (progn (format t "~&hi") (finish-output)
3524        (y-or-n-p-wait #\y 10 "1? ")
3525        (y-or-n-p-wait #\n 10 "2? "))
3527 ;;; ********************************
3528 ;;; Operate on System **************
3529 ;;; ********************************
3530 ;;; Operate-on-system
3531 ;;; Operation is :compile, 'compile, :load or 'load
3532 ;;; Force is :all or :new-source or :new-source-and-dependents or a list of
3533 ;;; specific modules.
3534 ;;;    :all (or T) forces a recompilation of every file in the system
3535 ;;;    :new-source-and-dependents compiles only those files whose
3536 ;;;          sources have changed or who depend on recompiled files.
3537 ;;;    :new-source compiles only those files whose sources have changed
3538 ;;;    A list of modules means that only those modules and their
3539 ;;;    dependents are recompiled.
3540 ;;; Test is T to print out what it would do without actually doing it.
3541 ;;;      Note: it automatically sets verbose to T if test is T.
3542 ;;; Verbose is T to print out what it is doing (compiling, loading of
3543 ;;;      modules and files) as it does it.
3544 ;;; Dribble should be the pathname of the dribble file if you want to
3545 ;;; dribble the compilation.
3546 ;;; Load-source-instead-of-binary is T to load .lisp instead of binary files.
3547 ;;; Version may be nil to signify no subdirectory,
3548 ;;; a symbol, such as alpha, beta, omega, :alpha, mark, which
3549 ;;; specifies a subdirectory of the root, or
3550 ;;; a string, which replaces the root.
3552 (defun operate-on-system (name operation
3553                                &key
3554                                force
3555                                (version *version*)
3556                                (test *oos-test*) (verbose *oos-verbose*)
3557                                (load-source-instead-of-binary
3558                                 *load-source-instead-of-binary*)
3559                                (load-source-if-no-binary
3560                                 *load-source-if-no-binary*)
3561                                (bother-user-if-no-binary
3562                                 *bother-user-if-no-binary*)
3563                                (compile-during-load *compile-during-load*)
3564                                dribble
3565                                (minimal-load *minimal-load*)
3566                                (override-compilation-unit t)
3567                                )
3568   (declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit))
3569   (unwind-protect
3570       ;; Protect the undribble.
3571       (#+(or :cltl2 :ansi-cl) with-compilation-unit
3572          #+(or :cltl2 :ansi-cl) (:override override-compilation-unit)
3573          #-(or :cltl2 :ansi-cl) progn
3574         (when *reset-full-pathname-table* (clear-full-pathname-tables))
3575         (when dribble (dribble dribble))
3576         (when test (setq verbose t))
3577         (when (null force)              ; defaults
3578           (case operation
3579             ((load :load) (setq force :all))
3580             ((compile :compile) (setq force :new-source-and-dependents))
3581             (t (setq force :all))))
3582         ;; Some CL implementations have a variable called *compile-verbose*
3583         ;; or *compile-file-verbose*.
3584         (multiple-value-bind (*version-dir* *version-replace*)
3585             (translate-version version)
3586           ;; CL implementations may uniformly default this to nil
3587           (let ((*load-verbose* #-common-lisp-controller t
3588                                 #+common-lisp-controller nil) ; nil
3589                 #-(or MCL CMU CLISP ECL :sbcl lispworks scl)
3590                 (*compile-file-verbose* t) ; nil
3591                 #+common-lisp-controller
3592                 (*compile-print* nil)
3593                 #+(and common-lisp-controller cmu)
3594                 (ext:*compile-progress* nil)
3595                 #+(and common-lisp-controller cmu)
3596                 (ext:*require-verbose* nil)
3597                 #+(and common-lisp-controller cmu)
3598                 (ext:*gc-verbose* nil)
3600                 (*compile-verbose* #-common-lisp-controller t
3601                                    #+common-lisp-controller nil) ; nil
3602                 (*version* version)
3603                 (*oos-verbose* verbose)
3604                 (*oos-test* test)
3605                 (*load-source-if-no-binary* load-source-if-no-binary)
3606                 (*compile-during-load* compile-during-load)
3607                 (*bother-user-if-no-binary* bother-user-if-no-binary)
3608                 (*load-source-instead-of-binary* load-source-instead-of-binary)
3609                 (*minimal-load* minimal-load)
3610                 (system (if (and (component-p name)
3611                                  (member (component-type name)
3612                                          '(:system :defsystem :subsystem)))
3613                             name
3614                             (find-system name :load))))
3615             #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
3616             (declare (special *compile-verbose* #-MCL *compile-file-verbose*)
3617                      #-openmcl (ignore *compile-verbose*
3618                                        #-MCL *compile-file-verbose*)
3619                      #-openmcl (optimize (inhibit-warnings 3)))
3620             (unless (component-operation operation)
3621               (error "Operation ~A undefined." operation))
3623             (operate-on-component system operation force))))
3624     (when dribble (dribble))))
3627 (defun compile-system (name &key force
3628                             (version *version*)
3629                             (test *oos-test*) (verbose *oos-verbose*)
3630                             (load-source-instead-of-binary
3631                              *load-source-instead-of-binary*)
3632                             (load-source-if-no-binary
3633                              *load-source-if-no-binary*)
3634                             (bother-user-if-no-binary
3635                              *bother-user-if-no-binary*)
3636                             (compile-during-load *compile-during-load*)
3637                             dribble
3638                             (minimal-load *minimal-load*))
3639   ;; For users who are confused by OOS.
3640   (operate-on-system
3641    name :compile
3642    :force force
3643    :version version
3644    :test test
3645    :verbose verbose
3646    :load-source-instead-of-binary load-source-instead-of-binary
3647    :load-source-if-no-binary load-source-if-no-binary
3648    :bother-user-if-no-binary bother-user-if-no-binary
3649    :compile-during-load compile-during-load
3650    :dribble dribble
3651    :minimal-load minimal-load))
3653 (defun load-system (name &key force
3654                          (version *version*)
3655                          (test *oos-test*) (verbose *oos-verbose*)
3656                          (load-source-instead-of-binary
3657                           *load-source-instead-of-binary*)
3658                          (load-source-if-no-binary *load-source-if-no-binary*)
3659                          (bother-user-if-no-binary *bother-user-if-no-binary*)
3660                          (compile-during-load *compile-during-load*)
3661                          dribble
3662                          (minimal-load *minimal-load*))
3663   ;; For users who are confused by OOS.
3664   (operate-on-system
3665    name :load
3666    :force force
3667    :version version
3668    :test test
3669    :verbose verbose
3670    :load-source-instead-of-binary load-source-instead-of-binary
3671    :load-source-if-no-binary load-source-if-no-binary
3672    :bother-user-if-no-binary bother-user-if-no-binary
3673    :compile-during-load compile-during-load
3674    :dribble dribble
3675    :minimal-load minimal-load))
3677 (defun clean-system (name &key (force :all)
3678                          (version *version*)
3679                          (test *oos-test*) (verbose *oos-verbose*)
3680                          dribble)
3681   "Deletes all the binaries in the system."
3682   ;; For users who are confused by OOS.
3683   (operate-on-system
3684    name :delete-binaries
3685    :force force
3686    :version version
3687    :test test
3688    :verbose verbose
3689    :dribble dribble))
3691 (defun edit-system
3692     (name &key force
3693                (version *version*)
3694                (test *oos-test*)
3695                (verbose *oos-verbose*)
3696                dribble)
3698   (operate-on-system
3699    name :edit
3700    :force force
3701    :version version
3702    :test test
3703    :verbose verbose
3704    :dribble dribble))
3706 (defun hardcopy-system
3707     (name &key force
3708                (version *version*)
3709                (test *oos-test*)
3710                (verbose *oos-verbose*)
3711                dribble)
3713   (operate-on-system
3714    name :hardcopy
3715    :force force
3716    :version version
3717    :test test
3718    :verbose verbose
3719    :dribble dribble))
3722 ;;; ensure-external-system-def-loaded component --
3723 ;;; Let's treat definition clauses of the form
3725 ;;;     (:system "name")
3726 ;;; i.e.
3728 ;;;     (:system "name" :components nil)
3730 ;;; in a special way.
3731 ;;; When encountered, MK:DEFSYSTEM tries to FIND-SYSTEM
3732 ;;; the system named "name" (by forcing a reload from disk).
3733 ;;; This may be more "natural".
3735 (defun ensure-external-system-def-loaded (component)
3736   (assert (member (component-type component)
3737                   '(:subsystem :system)))
3738   (when (null (component-components component))
3739     (let ((cname (component-name component)))
3740       ;; First we ensure that we reload the system definition.
3741       (undefsystem cname)
3742       (let* ((*reload-systems-from-disk* t)
3743              (system-component
3744               (find-system (component-name component)
3745                            :load
3747                            ;; Let's not supply the def-pname
3748                            ;; yet.
3749                            #+not-yet
3750                            (merge-pathname
3751                             (make-pathname :name cname
3752                                            :type "system"
3753                                            :directory ())
3754                             (component-full-pathname component
3755                                                      :source))
3758                            ))
3759              )
3760         ;; Now we have a problem.
3761         ;; We have just ensured that a system definition is
3762         ;; loaded, however, the COMPONENT at hand is different
3763         ;; from SYSTEM-COMPONENT.
3764         ;; To fix this problem we just use the following
3765         ;; kludge.  This should prevent re-entering in this
3766         ;; code branch, while actually preparing the COMPONENT
3767         ;; for operation.
3768         (setf (component-components component)
3769               (list system-component))
3770         ))))
3773 (defun operate-on-component (component operation force &aux changed)
3774   ;; Returns T if something changed and had to be compiled.
3775   (let ((type (component-type component))
3776         (old-package (package-name *package*)))
3778     (unwind-protect
3779         ;; Protect old-package.
3780         (progn
3781           ;; Use the correct package.
3782           (when (component-package component)
3783             (tell-user-generic (format nil "Using package ~A"
3784                                        (component-package component)))
3785             (unless *oos-test*
3786               (unless (find-package (component-package component))
3787                 ;; If the package name is the same as the name of the system,
3788                 ;; and the package is not defined, this would lead to an
3789                 ;; infinite loop, so bomb out with an error.
3790                 (when (string-equal (string (component-package component))
3791                                     (component-name component))
3792                   (format t "~%Component ~A not loaded:~%"
3793                           (component-name component))
3794                   (error  "  Package ~A is not defined"
3795                           (component-package component)))
3796                 ;; If package not found, try using REQUIRE to load it.
3797                 (new-require (component-package component)))
3798               ;; This was USE-PACKAGE, but should be IN-PACKAGE.
3799               ;; Actually, CLtL2 lisps define in-package as a macro,
3800               ;; so we'll set the package manually.
3801               ;; (in-package (component-package component))
3802               (let ((package (find-package (component-package component))))
3803                 (when package
3804                   (setf *package* package)))))
3806           ;; Marco Antoniotti 20040609
3807           ;; New feature.  Try to FIND-SYSTEM :system components if
3808           ;; they have no local :components definition.
3809           ;; OPERATE-ON-SYSTEM-DEPENDENCIES should still work as
3810           ;; advertised, given the small change made there.
3812           (when (or (eq type :system) (eq type :subsystem))
3813             (ensure-external-system-def-loaded component))
3815           (when (or (eq type :defsystem) (eq type :system))
3816             (operate-on-system-dependencies component operation force))
3818           ;; Do any compiler proclamations
3819           (when (component-proclamations component)
3820             (tell-user-generic (format nil "Doing proclamations for ~A"
3821                                        (component-name component)))
3822             (or *oos-test*
3823                 (proclaim (component-proclamations component))))
3825           ;; Do any initial actions
3826           (when (component-initially-do component)
3827             (tell-user-generic (format nil "Doing initializations for ~A"
3828                                        (component-name component)))
3829             (or *oos-test*
3830                 (eval (component-initially-do component))))
3832           ;; If operation is :compile and load-only is T, this would change
3833           ;; the operation to load. Only, this would mean that a module would
3834           ;; be considered to have changed if it was :load-only and had to be
3835           ;; loaded, and then dependents would be recompiled -- this doesn't
3836           ;; seem right. So instead, we propagate the :load-only attribute
3837           ;; to the components, and modify compile-file-operation so that
3838           ;; it won't compile the files (and modify tell-user to say "Loading"
3839           ;; instead of "Compiling" for load-only modules).
3840           #||
3841           (when (and (find operation '(:compile compile))
3842                      (component-load-only component))
3843             (setf operation :load))
3844           ||#
3846           ;; Do operation and set changed flag if necessary.
3847           (setq changed
3848                 (case type
3849                   ((:file :private-file)
3850                    (funcall (component-operation operation) component force))
3851                   ((:module :system :subsystem :defsystem)
3852                    (operate-on-components component operation force changed))))
3854           ;; Do any final actions
3855           (when (component-finally-do component)
3856             (tell-user-generic (format nil "Doing finalizations for ~A"
3857                                        (component-name component)))
3858             (or *oos-test*
3859                 (eval (component-finally-do component))))
3861           ;; add the banner if needed
3862           #+(or cmu scl)
3863           (when (component-banner component)
3864             (unless (stringp (component-banner component))
3865               (error "The banner should be a string, it is: ~S"
3866                      (component-banner component)))
3867             (setf (getf ext:*herald-items*
3868                         (intern (string-upcase  (component-name component))
3869                                 (find-package :keyword)))
3870                   (list
3871                      (component-banner component)))))
3873       ;; Reset the package. (Cleanup form of unwind-protect.)
3874       ;;(in-package old-package)
3875       (setf *package* (find-package old-package)))
3877     ;; Provide the loaded system
3878     (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
3879       (tell-user-generic (format nil "Providing system ~A~%"
3880                                  (component-name component)))
3881       (or *oos-test*
3882           (provide (canonicalize-system-name (component-name component))))))
3884   ;; Return non-NIL if something changed in this component and hence had
3885   ;; to be recompiled. This is only used as a boolean.
3886   changed)
3888 (defvar *force* nil)
3889 (defvar *providing-blocks-load-propagation* t
3890   "If T, if a system dependency exists on *modules*, it is not loaded.")
3892 (defun operate-on-system-dependencies (component operation &optional force)
3893   (when *system-dependencies-delayed*
3894     (let ((*force* force))
3895       (dolist (system (component-depends-on component))
3896         ;; For each system that this system depends on, if it is a
3897         ;; defined system (either via defsystem or component type :system),
3898         ;; and propagation is turned on, propagates the operation to the
3899         ;; subsystem. Otherwise runs require (my version) on that system
3900         ;; to load it (needed since we may be depending on a lisp
3901         ;; dependent package).
3902         ;; Explores the system tree in a DFS manner.
3904         ;; Do not try to do anything with non system components.
3905         (cond ((and *operations-propagate-to-subsystems*
3906                     (not (listp system))
3907                     (or (stringp system) (symbolp system))
3908                     ;; The subsystem is a defined system.
3909                     (find-system system :load-or-nil))
3910                ;; Call OOS on it. Since *system-dependencies-delayed* is
3911                ;; T, the :depends-on slot is filled with the names of
3912                ;; systems, not defstructs.
3913                ;; Aside from system, operation, force, for everything else
3914                ;; we rely on the globals.
3915                (unless (and *providing-blocks-load-propagation*
3916                             ;; If *providing-blocks-load-propagation* is T,
3917                             ;; the system dependency must not exist in the
3918                             ;; *modules* for it to be loaded. Note that
3919                             ;; the dependencies are implicitly systems.
3920                             (find operation '(load :load))
3921                             ;; (or (eq force :all) (eq force t))
3922                             (find (canonicalize-system-name system)
3923                                   *modules* :test #'string-equal))
3925                  (operate-on-system system operation :force force)))
3927               ((listp system)
3928                ;; If the SYSTEM is a list then its contents are as follows.
3929                ;;
3930                ;;    (<name> <definition-pathname> <action> &optional <version>)
3931                ;;
3933                (destructuring-bind (system-name definition-pathname action
3934                                                 &optional version)
3935                    system
3936                  (tell-user-require-system
3937                   (if (and (null system-name)
3938                            (null definition-pathname))
3939                       action
3940                       system)
3941                   component)
3942                  (or *oos-test* (new-require system-name
3943                                              nil
3944                                              (eval definition-pathname)
3945                                              action
3946                                              (or version *version*)))))
3947               ((and (component-p system)
3948                     (not (member (component-type system)
3949                                  '(:defsystem :subsystem :system))))
3950                ;; Do nothing for non system components.
3951                )
3952               (t
3953                (tell-user-require-system system component)
3954                (or *oos-test* (new-require system))))
3955         ))))
3957 ;;; Modules can depend only on siblings. If a module should depend
3958 ;;; on an uncle, then the parent module should depend on that uncle
3959 ;;; instead. Likewise a module should depend on a sibling, not a niece
3960 ;;; or nephew. Modules also cannot depend on cousins. Modules cannot
3961 ;;; depend on parents, since that is circular.
3963 (defun module-depends-on-changed (module changed)
3964   (dolist (dependent (component-depends-on module))
3965     (when (member dependent changed)
3966       (return t))))
3968 (defun operate-on-components (component operation force changed)
3969   (with-tell-user (operation component)
3970     (if (component-components component)
3971         (dolist (module (component-components component))
3972           (when (operate-on-component module operation
3973                   (cond ((and (module-depends-on-changed module changed)
3974                               #||(some #'(lambda (dependent)
3975                                         (member dependent changed))
3976                                     (component-depends-on module))||#
3977                               (or (non-empty-listp force)
3978                                   (eq force :new-source-and-dependents)))
3979                          ;; The component depends on a changed file
3980                          ;; and force agrees.
3981                          (if (eq force :new-source-and-dependents)
3982                              :new-source-all
3983                            :all))
3984                         ((and (non-empty-listp force)
3985                               (member (component-name module) force
3986                                       :test #'string-equal :key #'string))
3987                          ;; Force is a list of modules
3988                          ;; and the component is one of them.
3989                          :all)
3990                         (t force)))
3991             (push module changed)))
3992         (case operation
3993           ((compile :compile)
3994            (eval (component-compile-form component)))
3995           ((load :load)
3996            (eval (component-load-form component))))))
3997   ;; This is only used as a boolean.
3998   changed)
4000 ;;; ********************************
4001 ;;; New Require ********************
4002 ;;; ********************************
4004 ;;; This needs cleaning.  Obviously the code is a left over from the
4005 ;;; time people did not know how to use packages in a proper way or
4006 ;;; CLs were shaky in their implementation.
4008 ;;; First of all we need this. (Commented out for the time being)
4009 ;;; (shadow '(cl:require))
4012 (defvar *old-require* nil)
4014 ;;; All calls to require in this file have been replaced with calls
4015 ;;; to new-require to avoid compiler warnings and make this less of
4016 ;;; a tangled mess.
4018 (defun new-require (module-name
4019                     &optional
4020                     pathname
4021                     definition-pname
4022                     default-action
4023                     (version *version*))
4024   ;; If the pathname is present, this behaves like the old require.
4025   (unless (and module-name
4026                (find (string module-name)
4027                      *modules* :test #'string=))
4028     (handler-case
4029         (cond (pathname
4030                (funcall *old-require* module-name pathname))
4031               ;; If the system is defined, load it.
4032               ((find-system module-name :load-or-nil definition-pname)
4033                (operate-on-system
4034                 module-name :load
4035                 :force *force*
4036                 :version version
4037                 :test *oos-test*
4038                 :verbose *oos-verbose*
4039                 :load-source-if-no-binary *load-source-if-no-binary*
4040                 :bother-user-if-no-binary *bother-user-if-no-binary*
4041                 :compile-during-load *compile-during-load*
4042                 :load-source-instead-of-binary *load-source-instead-of-binary*
4043                 :minimal-load *minimal-load*))
4044               ;; If there's a default action, do it. This could be a progn which
4045               ;; loads a file that does everything.
4046               ((and default-action
4047                     (eval default-action)))
4048               ;; If no system definition file, try regular require.
4049               ;; had last arg  PATHNAME, but this wasn't really necessary.
4050               ((funcall *old-require* module-name))
4051               ;; If no default action, print a warning or error message.
4052               (t
4053                #||
4054                (format t "~&Warning: System ~A doesn't seem to be defined..."
4055                        module-name)
4056                ||#
4057                (error 'missing-system :name module-name)))
4058       (missing-module (mmc) (signal mmc)) ; Resignal.
4059       (error (e)
4060              (declare (ignore e))
4061              ;; Signal a (maybe wrong) MISSING-SYSTEM.
4062              (error 'missing-system :name module-name)))
4063     ))
4066 ;;; Note that in some lisps, when the compiler sees a REQUIRE form at
4067 ;;; top level it immediately executes it. This is as if an
4068 ;;; (eval-when (compile load eval) ...) were wrapped around the REQUIRE
4069 ;;; form. I don't see any easy way to do this without making REQUIRE
4070 ;;; a macro.
4072 ;;; For example, in VAXLisp, if a (require 'streams) form is at the top of
4073 ;;; a file in the system, compiling the system doesn't wind up loading the
4074 ;;; streams module. If the (require 'streams) form is included within an
4075 ;;; (eval-when (compile load eval) ...) then everything is OK.
4077 ;;; So perhaps we should replace the redefinition of lisp:require
4078 ;;; with the following macro definition:
4080 (unless *old-require*
4081   (setf *old-require*
4082         (symbol-function #-(or :lispworks
4083                                :sbcl
4084                                (and :excl :allegro-v4.0)) 'lisp:require
4085                          #+:sbcl 'cl:require
4086                          #+:lispworks 'system:::require
4087                          #+(and :excl :allegro-v4.0) 'cltl1:require))
4089   (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil))
4090     ;; Note that lots of lisps barf if we redefine a function from
4091     ;; the LISP package. So what we do is define a macro with an
4092     ;; unused name, and use (setf macro-function) to redefine
4093     ;; lisp:require without compiler warnings. If the lisp doesn't
4094     ;; do the right thing, try just replacing require-as-macro
4095     ;; with lisp:require.
4096     (defmacro require-as-macro (module-name
4097                                 &optional pathname definition-pname
4098                                 default-action (version '*version*))
4099       `(eval-when (compile load eval)
4100          (new-require ,module-name ,pathname ,definition-pname
4101                       ,default-action ,version)))
4102     (setf (macro-function #-(and :excl :sbcl :allegro-v4.0) 'lisp:require
4103                           #+:sbcl 'cl:require
4104                           #+(and :excl :allegro-v4.0) 'cltl1:require)
4105           (macro-function 'require-as-macro))))
4107 ;;; This will almost certainly fix the problem, but will cause problems
4108 ;;; if anybody does a funcall on #'require.
4110 ;;; Redefine old require to call the new require.
4111 (eval-when #-(or :lucid) (:load-toplevel :execute)
4112            #+(or :lucid) (load eval)
4113 (unless *old-require*
4114   (setf *old-require*
4115         (symbol-function
4116          #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
4117          #+(and :excl :allegro-v4.0) 'cltl1:require
4118          #+:sbcl 'cl:require
4119          #+:lispworks3.1 'common-lisp::require
4120          #+(and :lispworks (not :lispworks3.1)) 'system::require
4121          #+:openmcl 'cl:require
4122          #+(and :mcl (not :openmcl)) 'ccl:require
4123          ))
4125   (unless *dont-redefine-require*
4126     (let (#+(or :mcl (and :CCL (not :lispworks)))
4127           (ccl:*warn-if-redefine-kernel* nil))
4128       #-(or (and allegro-version>= (version>= 4 1)) :lispworks)
4129       (setf (symbol-function
4130              #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
4131              #+(and :excl :allegro-v4.0) 'cltl1:require
4132              #+:lispworks3.1 'common-lisp::require
4133              #+:sbcl 'cl:require
4134              #+(and :lispworks (not :lispworks3.1)) 'system::require
4135              #+:openmcl 'cl:require
4136              #+(and :mcl (not :openmcl)) 'ccl:require
4137              )
4138             (symbol-function 'new-require))
4139       #+:lispworks
4140       (let ((warn-packs system::*packages-for-warn-on-redefinition*))
4141         (declare (special system::*packages-for-warn-on-redefinition*))
4142         (setq system::*packages-for-warn-on-redefinition* nil)
4143         (setf (symbol-function
4144                #+:lispworks3.1 'common-lisp::require
4145                #-:lispworks3.1 'system::require
4146                )
4147               (symbol-function 'new-require))
4148         (setq system::*packages-for-warn-on-redefinition* warn-packs))
4149       #+(and allegro-version>= (version>= 4 1))
4150       (excl:without-package-locks
4151        (setf (symbol-function 'lisp:require)
4152          (symbol-function 'new-require))))))
4156 ;;; Well, let's add some more REQUIRE hacking; specifically for SBCL,
4157 ;;; and, eventually, for CMUCL.
4159 #+sbcl
4160 (eval-when (:compile-toplevel :load-toplevel :execute)
4162 (defun sbcl-mk-defsystem-module-provider (name)
4163   ;; Let's hope things go smoothly.
4164     (let ((module-name (string-downcase (string name))))
4165       (when (mk:find-system module-name :load-or-nil)
4166         (mk:load-system module-name
4167                         :compile-during-load t
4168                         :verbose nil))))
4170 (pushnew 'sbcl-mk-defsystem-module-provider sb-ext:*module-provider-functions*)
4173 #+#.(cl:if (cl:and (cl:find-package "EXT") (cl:find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT")) '(and) '(or))
4174 (progn
4175   (defun cmucl-mk-defsystem-module-provider (name)
4176     (let ((module-name (string-downcase (string name))))
4177       (when (mk:find-system module-name :load-or-nil)
4178         (mk:load-system module-name
4179                         :compile-during-load t
4180                         :verbose nil))))
4182   (pushnew 'cmucl-mk-defsystem-module-provider ext:*module-provider-functions*)
4183   )
4188 ;;; ********************************
4189 ;;; Language-Dependent Characteristics
4190 ;;; ********************************
4191 ;;; This section is used for defining language-specific behavior of
4192 ;;; defsystem. If the user changes a language definition, it should
4193 ;;; take effect immediately -- they shouldn't have to reload the
4194 ;;; system definition file for the changes to take effect.
4196 (defvar *language-table* (make-hash-table :test #'equal)
4197   "Hash table that maps from languages to language structures.")
4198 (defun find-language (name)
4199   (gethash name *language-table*))
4201 (defstruct (language (:print-function print-language))
4202   name                  ; The name of the language (a keyword)
4203   compiler              ; The function used to compile files in the language
4204   loader                ; The function used to load files in the language
4205   source-extension      ; Filename extensions for source files
4206   binary-extension      ; Filename extensions for binary files
4209 (defun print-language (language stream depth)
4210   (declare (ignore depth))
4211   (format stream "#<~:@(~A~): ~A ~A>"
4212           (language-name language)
4213           (language-source-extension language)
4214           (language-binary-extension language)))
4216 (defun compile-function (component)
4217   (or (component-compiler component)
4218       (let ((language (find-language (or (component-language component)
4219                                          :lisp))))
4220         (when language (language-compiler language)))
4221       #'compile-file))
4223 (defun load-function (component)
4224   (or (component-loader component)
4225       (let ((language (find-language (or (component-language component)
4226                                          :lisp))))
4227         (when language (language-loader language)))
4228       #'load))
4230 (defun default-source-extension (component)
4231   (let ((language (find-language (or (component-language component)
4232                                      :lisp))))
4233     (or (when language (language-source-extension language))
4234         (car *filename-extensions*))))
4236 (defun default-binary-extension (component)
4237   (let ((language (find-language (or (component-language component)
4238                                      :lisp))))
4239     (or (when language (language-binary-extension language))
4240         (cdr *filename-extensions*))))
4242 (defmacro define-language (name &key compiler loader
4243                                 source-extension binary-extension)
4244   (let ((language (gensym "LANGUAGE")))
4245     `(let ((,language (make-language :name ,name
4246                                      :compiler ,compiler
4247                                      :loader ,loader
4248                                      :source-extension ,source-extension
4249                                      :binary-extension ,binary-extension)))
4250        (setf (gethash ,name *language-table*) ,language)
4251        ,name)))
4254 ;;; Test System for verifying multi-language capabilities.
4255 (defsystem foo
4256   :language :lisp
4257   :components ((:module c :language :c :components ("foo" "bar"))
4258                (:module lisp :components ("baz" "barf"))))
4262 ;;; *** Lisp Language Definition
4263 (define-language :lisp
4264   :compiler #'compile-file
4265   :loader #'load
4266   :source-extension (car *filename-extensions*)
4267   :binary-extension (cdr *filename-extensions*))
4269 ;;; *** PseudoScheme Language Definition
4270 (defun scheme-compile-file (filename &rest args)
4271   (let ((scheme-package (find-package '#:scheme)))
4272     (apply (symbol-function (find-symbol (symbol-name 'compile-file)
4273                                          scheme-package))
4274            filename
4275            (funcall (symbol-function
4276                      (find-symbol (symbol-name '#:interaction-environment)
4277                                   scheme-package)))
4278            args)))
4280 (define-language :scheme
4281   :compiler #'scheme-compile-file
4282   :loader #'load
4283   :source-extension "scm"
4284   :binary-extension "bin")
4286 ;;; *** C Language Definition
4288 ;;; This is very basic. Somebody else who needs it can add in support
4289 ;;; for header files, libraries, different C compilers, etc. For example,
4290 ;;; we might add a COMPILER-OPTIONS slot to the component defstruct.
4292 (defparameter *c-compiler* "gcc")
4293 #-(or symbolics (and :lispworks :harlequin-pc-lisp ))
4295 (defun run-unix-program (program arguments)
4296   ;; arguments should be a list of strings, where each element is a
4297   ;; command-line option to send to the program.
4298   #+:lucid (run-program program :arguments arguments)
4299   #+:allegro (excl:run-shell-command
4300               (format nil "~A~@[ ~{~A~^ ~}~]"
4301                       program arguments))
4302   #+(or :kcl :ecl) (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
4303   #+(or :cmu :scl) (extensions:run-program program arguments)
4304   #+:openmcl (ccl:run-program program arguments)
4305   #+:sbcl (sb-ext:run-program program arguments)
4306   #+:lispworks (foreign:call-system-showing-output
4307                 (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
4308   #+clisp (#+lisp=cl ext:run-program #-lisp=cl lisp:run-program
4309                      program :arguments arguments)
4310   )
4312 #+(or symbolics (and :lispworks :harlequin-pc-lisp))
4313 (defun run-unix-program (program arguments)
4314   (declare (ignore program arguments))
4315   (error "MK::RUN-UNIX-PROGRAM: this does not seem to be a UN*X system.")
4316   )
4319 (defun c-compile-file (filename &rest args &key output-file error-file)
4320   ;; gcc -c foo.c -o foo.o
4321   (declare (ignore args))
4322   (run-unix-program *c-compiler*
4323                     (format nil "-c ~A~@[ -o ~A~]"
4324                             filename
4325                             output-file)))
4329 (defun c-compile-file (filename &rest args &key output-file error-file)
4330   ;; gcc -c foo.c -o foo.o
4331   (declare (ignore args error-file))
4332   (run-unix-program *c-compiler*
4333                     `("-c" ,filename ,@(if output-file `("-o" ,output-file)))))
4337 ;;; The following code was inserted to improve C compiler support (at
4338 ;;; least under Linux/GCC).
4339 ;;; Thanks to Espen S Johnsen.
4341 ;;; 20001118 Marco Antoniotti.
4343 (defun default-output-pathname (path1 path2 type)
4344   (if (eq path1 t)
4345       (translate-logical-pathname
4346        (merge-pathnames (make-pathname :type type) (pathname path2)))
4347       (translate-logical-pathname (pathname path1))))
4350 (defun run-compiler (program
4351                      arguments
4352                      output-file
4353                      error-file
4354                      error-output
4355                      verbose)
4356   #-(or cmu scl) (declare (ignore error-file error-output))
4358   (flet ((make-useable-stream (&rest streams)
4359            (apply #'make-broadcast-stream (delete nil streams)))
4360          )
4361     (let (#+(or cmu scl) (error-file error-file)
4362           #+(or cmu scl) (error-file-stream nil)
4363           (verbose-stream nil)
4364           (old-timestamp (file-write-date output-file))
4365           (fatal-error nil)
4366           (output-file-written nil)
4367           )
4368       (unwind-protect
4369            (progn
4370              #+(or cmu scl)
4371              (setf error-file
4372                    (when error-file
4373                      (default-output-pathname error-file
4374                                               output-file
4375                                               *compile-error-file-type*))
4377                    error-file-stream
4378                    (and error-file
4379                         (open error-file
4380                               :direction :output
4381                               :if-exists :supersede)))
4383              (setf verbose-stream
4384                    (make-useable-stream
4385                     #+cmu error-file-stream
4386                     (and verbose *trace-output*)))
4388              (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
4389                      program
4390                      arguments)
4392              (setf fatal-error
4393                    #-(or cmu scl)
4394                    (and (run-unix-program program arguments) nil) ; Incomplete.
4395                    #+(or cmu scl)
4396                    (let* ((error-output
4397                            (make-useable-stream error-file-stream
4398                                                 (if (eq error-output t)
4399                                                     *error-output*
4400                                                   error-output)))
4401                           (process
4402                            (ext:run-program program arguments
4403                                             :error error-output)))
4404                      (not (zerop (ext:process-exit-code process)))))
4406              (setf output-file-written
4407                    (and (probe-file output-file)
4408                         (not (eql old-timestamp
4409                                   (file-write-date output-file)))))
4412              (when output-file-written
4413                (format verbose-stream "~A written~%" output-file))
4414              (format verbose-stream "Running of ~A finished~%"
4415                      program)
4416              (values (and output-file-written output-file)
4417                      fatal-error
4418                      fatal-error))
4420         #+(or cmu scl)
4421         (when error-file
4422           (close error-file-stream)
4423           (unless (or fatal-error (not output-file-written))
4424             (delete-file error-file)))
4426         (values (and output-file-written output-file)
4427                 fatal-error
4428                 fatal-error)))))
4431 ;;; C Language definitions.
4433 (defun c-compile-file (filename &rest args
4434                                 &key
4435                                 (output-file t)
4436                                 (error-file t)
4437                                 (error-output t)
4438                                 (verbose *compile-verbose*)
4439                                 debug
4440                                 link
4441                                 optimize
4442                                 cflags
4443                                 definitions
4444                                 include-paths
4445                                 library-paths
4446                                 libraries
4447                                 (error t))
4448   (declare (ignore args))
4450   (flet ((map-options (flag options &optional (func #'identity))
4451            (mapcar #'(lambda (option)
4452                        (format nil "~A~A" flag (funcall func option)))
4453                    options))
4454          )
4455     (let* ((output-file (default-output-pathname output-file filename "o"))
4456            (arguments
4457             `(,@(when (not link) '("-c"))
4458               ,@(when debug '("-g"))
4459               ,@(when optimize (list (format nil "-O~D" optimize)))
4460               ,@cflags
4461               ,@(map-options
4462                  "-D" definitions
4463                  #'(lambda (definition)
4464                      (if (atom definition)
4465                          definition
4466                        (apply #'format nil "~A=~A" definition))))
4467               ,@(map-options "-I" include-paths #'truename)
4468               ,(namestring (truename filename))
4469               "-o"
4470               ,(namestring (translate-logical-pathname output-file))
4471               ,@(map-options "-L" library-paths #'truename)
4472               ,@(map-options "-l" libraries))))
4474       (multiple-value-bind (output-file warnings fatal-errors)
4475           (run-compiler *c-compiler*
4476                         arguments
4477                         output-file
4478                         error-file
4479                         error-output
4480                         verbose)
4481         (if (and error (or (not output-file) fatal-errors))
4482             (error "Compilation failed")
4483             (values output-file warnings fatal-errors))))))
4486 (define-language :c
4487   :compiler #'c-compile-file
4488   :loader #+:lucid #'load-foreign-files
4489           #+:allegro #'load
4490           #+(or :cmu :scl) #'alien:load-foreign
4491           #+:sbcl #'sb-alien:load-foreign
4492           #+(and :lispworks :unix (not :linux) (not :macosx)) #'link-load:read-foreign-modules
4493           #+(and :lispworks :unix (or :linux :macosx)) #'fli:register-module
4494           #+(and :lispworks :win32) #'fli:register-module
4495           #+(or :ecl :gcl :kcl) #'load ; should be enough.
4496           #-(or :lucid
4497                 :allegro
4498                 :cmu
4499                 :sbcl
4500                 :scl
4501                 :lispworks
4502                 :ecl :gcl :kcl)
4503           (lambda (&rest args)
4504             (declare (ignore args))
4505             (cerror "Continue returning NIL."
4506                     "Loader not defined for C foreign libraries in ~A ~A."
4507                     (lisp-implementation-type)
4508                     (lisp-implementation-version)))
4509   :source-extension "c"
4510   :binary-extension "o")
4513 ;;; Fortran Language definitions.
4514 ;;; From Matlisp.
4516 (export '(*fortran-compiler* *fortran-options*))
4518 (defparameter *fortran-compiler* "g77")
4519 (defparameter *fortran-options* '("-O"))
4521 (defun fortran-compile-file (filename &rest args
4522                                       &key output-file error-file
4523                                       &allow-other-keys)
4524   (declare (ignore error-file args))
4525   (let ((arg-list
4526          (append *fortran-options*
4527                  `("-c" ,filename ,@(if output-file `("-o" ,output-file))))))
4528     (run-unix-program *fortran-compiler* arg-list)))
4531 (mk:define-language :fortran
4532     :compiler #'fortran-compile-file
4533     :loader #'identity
4534     :source-extension "f"
4535     :binary-extension "o")
4538 ;;; AR support.
4539 ;; How to create a library (archive) of object files
4541 (export '(*ar-program* build-lib))
4543 (defparameter *ar-program* "ar")
4545 (defun build-lib (libname directory)
4546   (let ((args (list "rv" (truename libname))))
4547     (format t ";;; Building archive ~A~%" libname)
4548     (run-unix-program *ar-program*
4549                       (append args
4550                               (mapcar #'truename (directory directory))))))
4553 ;;; ********************************
4554 ;;; Component Operations ***********
4555 ;;; ********************************
4556 ;;; Define :compile/compile and :load/load operations
4557 (eval-when (load eval)
4558 (component-operation :compile  'compile-and-load-operation)
4559 (component-operation 'compile  'compile-and-load-operation)
4560 (component-operation :load     'load-file-operation)
4561 (component-operation 'load     'load-file-operation)
4564 (defun compile-and-load-operation (component force)
4565   ;; FORCE was CHANGED. this caused defsystem during compilation to only
4566   ;; load files that it immediately compiled.
4567   (let ((changed (compile-file-operation component force)))
4568     ;; Return T if the file had to be recompiled and reloaded.
4569     (if (and changed (component-compile-only component))
4570         ;; For files which are :compile-only T, compiling the file
4571         ;; satisfies the need to load.
4572         changed
4573         ;; If the file wasn't compiled, or :compile-only is nil,
4574         ;; check to see if it needs to be loaded.
4575         (and (load-file-operation component force) ; FORCE was CHANGED ???
4576              changed))))
4578 (defun unmunge-lucid (namestring)
4579   ;; Lucid's implementation of COMPILE-FILE is non-standard, in that
4580   ;; when the :output-file is a relative pathname, it tries to munge
4581   ;; it with the directory of the source file. For example,
4582   ;; (compile-file "src/globals.lisp" :output-file "bin/globals.sbin")
4583   ;; tries to stick the file in "./src/bin/globals.sbin" instead of
4584   ;; "./bin/globals.sbin" like any normal lisp. This hack seems to fix the
4585   ;; problem. I wouldn't have expected this problem to occur with any
4586   ;; use of defsystem, but some defsystem users are depending on
4587   ;; using relative pathnames (at least three folks reported the problem).
4588   (cond ((null-string namestring) namestring)
4589         ((char= (char namestring 0) #\/)
4590          ;; It's an absolute namestring
4591          namestring)
4592         (t
4593          ;; Ugly, but seems to fix the problem.
4594          (concatenate 'string "./" namestring))))
4596 (defun compile-file-operation (component force)
4597   ;; Returns T if the file had to be compiled.
4598   (let ((must-compile
4599          ;; For files which are :load-only T, loading the file
4600          ;; satisfies the demand to recompile.
4601          (and (null (component-load-only component)) ; not load-only
4602               (or (find force '(:all :new-source-all t) :test #'eq)
4603                   (and (find force '(:new-source :new-source-and-dependents)
4604                              :test #'eq)
4605                        (needs-compilation component nil)))))
4606         (source-pname (component-full-pathname component :source)))
4608     (cond ((and must-compile (probe-file source-pname))
4609            (with-tell-user ("Compiling source" component :source)
4610              (let ((output-file
4611                     #+:lucid
4612                      (unmunge-lucid (component-full-pathname component
4613                                                              :binary))
4614                      #-:lucid
4615                      (component-full-pathname component :binary)))
4617                ;; make certain the directory we need to write to
4618                ;; exists [pvaneynd@debian.org 20001114]
4619                ;; Added PATHNAME-HOST following suggestion by John
4620                ;; DeSoi [marcoxa@sourceforge.net 20020529]
4622                (ensure-directories-exist
4623                 (make-pathname
4624                  :host (pathname-host output-file)
4625                  :directory (pathname-directory output-file)))
4627                (or *oos-test*
4628                    (apply (compile-function component)
4629                           source-pname
4630                           :output-file
4631                           output-file
4632                           #+(or :cmu :scl) :error-file
4633                           #+(or :cmu :scl) (and *cmu-errors-to-file*
4634                                                 (component-full-pathname component
4635                                                                          :error))
4636                           #+CMU
4637                           :error-output
4638                           #+CMU
4639                           *cmu-errors-to-terminal*
4640                           (component-compiler-options component)
4641                           ))))
4642            must-compile)
4643           (must-compile
4644            (tell-user "Source file not found. Not compiling"
4645                       component :source :no-dots :force)
4646            nil)
4647           (t nil))))
4649 ;; see CLOCC/PORT/sys.lisp:compiled-file-p
4650 (eval-when (load eval compile)
4651   (when (find-package "PORT")
4652     (import (find-symbol "COMPILED-FILE-P" "PORT"))))
4653 (unless (fboundp 'compiled-file-p)
4654  (defun compiled-file-p (file-name)
4655   "Return T if the FILE-NAME is a filename designator for a valid compiled.
4656 Signal an error when it is not a filename designator.
4657 Return NIL when the file does not exist, or is not readable,
4658 or does not contain valid compiled code."
4659   #+clisp
4660   (with-open-file (in file-name :direction :input :if-does-not-exist nil)
4661     (and in (char= #\( (peek-char nil in))
4662          (let ((form (ignore-errors (read in nil nil))))
4663            (and (consp form)
4664                 (eq (car form) 'SYSTEM::VERSION)
4665                 (null (nth-value 1 (ignore-errors (eval form))))))))
4666   #-clisp t))
4668 (defun needs-compilation (component force)
4669   ;; If there is no binary, or it is older than the source
4670   ;; file, then the component needs to be compiled.
4671   ;; Otherwise we only need to recompile if it depends on a file that changed.
4672   (declare (ignore force))
4673   (let ((source-pname (component-full-pathname component :source))
4674         (binary-pname (component-full-pathname component :binary)))
4675     (and
4676      ;; source must exist
4677      (probe-file source-pname)
4678      (or
4679       ;; We force recompilation.
4680       #|(find force '(:all :new-source-all) :test #'eq)|#
4681       ;; no binary
4682       (null (probe-file binary-pname))
4683       ;; old binary
4684       (< (file-write-date binary-pname)
4685          (file-write-date source-pname))
4686       ;; invalid binary
4687       #+clisp (not (compiled-file-p binary-pname))))))
4690 (defun needs-loading (component &optional (check-source t) (check-binary t))
4691   ;; Compares the component's load-time against the file-write-date of
4692   ;; the files on disk.
4693   (let ((load-time (component-load-time component))
4694         (source-pname (component-full-pathname component :source))
4695         (binary-pname (component-full-pathname component :binary)))
4696     (or
4697      #|| ISI Extension ||#
4698      (component-load-always component)
4700      ;; File never loaded.
4701      (null load-time)
4702      ;; Binary is newer.
4703      (when (and check-binary
4704                 (probe-file binary-pname))
4705        (< load-time
4706           (file-write-date binary-pname)))
4707      ;; Source is newer.
4708      (when (and check-source
4709                 (probe-file source-pname))
4710        (< load-time
4711           (file-write-date source-pname))))))
4713 ;;; Need to completely rework this function...
4714 (defun load-file-operation (component force)
4715   ;; Returns T if the file had to be loaded
4716   (let* ((binary-pname (component-full-pathname component :binary))
4717          (source-pname (component-full-pathname component :source))
4718          (binary-exists (probe-file binary-pname))
4719          (source-exists (probe-file source-pname))
4720          (source-needs-loading (needs-loading component t nil))
4721          (binary-needs-loading (needs-loading component nil t))
4722          ;; needs-compilation has an implicit source-exists in it.
4723          (needs-compilation (if (component-load-only component)
4724                                 source-needs-loading
4725                                 (needs-compilation component force)))
4726          (check-for-new-source
4727           ;; If force is :new-source*, we're checking for files
4728           ;; whose source is newer than the compiled versions.
4729           (find force '(:new-source :new-source-and-dependents :new-source-all)
4730                 :test #'eq))
4731          (load-binary (or (find force '(:all :new-source-all t) :test #'eq)
4732                           binary-needs-loading))
4733          (load-source
4734           (or *load-source-instead-of-binary*
4735               (and load-binary (component-load-only component))
4736               (and check-for-new-source needs-compilation)))
4737          (compile-and-load
4738           (and needs-compilation
4739                (or load-binary check-for-new-source)
4740                (compile-and-load-source-if-no-binary component)))
4741          )
4742     ;; When we're trying to minimize the files loaded to only those
4743     ;; that need be, restrict the values of load-source and load-binary
4744     ;; so that we only load the component if the files are newer than
4745     ;; the load-time.
4746     (when (and *minimal-load*
4747                (not (find force '(:all :new-source-all)
4748                           :test #'eq)))
4749       (when load-source (setf load-source source-needs-loading))
4750       (when load-binary (setf load-binary binary-needs-loading)))
4752     (when (or load-source load-binary compile-and-load)
4753       (cond (compile-and-load
4754              ;; If we're loading the binary and it is old or nonexistent,
4755              ;; and the user says yes, compile and load the source.
4756              (compile-file-operation component t)
4757              (with-tell-user ("Loading binary"   component :binary)
4758                (or *oos-test*
4759                    (progn
4760                      (funcall (load-function component) binary-pname)
4761                      (setf (component-load-time component)
4762                            (file-write-date binary-pname)))))
4763              t)
4764             ((and source-exists
4765                   (or (and load-source  ; implicit needs-comp...
4766                            (or *load-source-instead-of-binary*
4767                                (component-load-only component)
4768                                (not *compile-during-load*)))
4769                       (and load-binary
4770                            (not binary-exists)
4771                            (load-source-if-no-binary component))))
4772              ;; Load the source if the source exists and:
4773              ;;   o  we're loading binary and it doesn't exist
4774              ;;   o  we're forcing it
4775              ;;   o  we're loading new source and user wasn't asked to compile
4776              (with-tell-user ("Loading source" component :source)
4777                (or *oos-test*
4778                    (progn
4779                      (funcall (load-function component) source-pname)
4780                      (setf (component-load-time component)
4781                            (file-write-date source-pname)))))
4782              t)
4783             ((and binary-exists load-binary)
4784              (with-tell-user ("Loading binary"   component :binary)
4785                (or *oos-test*
4786                    (progn
4787                      (funcall (load-function component) binary-pname)
4788                      (setf (component-load-time component)
4789                            (file-write-date binary-pname)))))
4790              t)
4791             ((and (not binary-exists) (not source-exists))
4792              (tell-user-no-files component :force)
4793              (when *files-missing-is-an-error*
4794                (cerror "Continue, ignoring missing files."
4795                        "~&Source file ~S ~:[and binary file ~S ~;~]do not exist."
4796                        source-pname
4797                        (or *load-source-if-no-binary*
4798                            *load-source-instead-of-binary*)
4799                        binary-pname))
4800              nil)
4801             (t
4802              nil)))))
4804 (eval-when (load eval)
4805 (component-operation :clean    'delete-binaries-operation)
4806 (component-operation 'clean    'delete-binaries-operation)
4807 (component-operation :delete-binaries     'delete-binaries-operation)
4808 (component-operation 'delete-binaries     'delete-binaries-operation)
4810 (defun delete-binaries-operation (component force)
4811   (when (or (eq force :all)
4812             (eq force t)
4813             (and (find force '(:new-source :new-source-and-dependents
4814                                            :new-source-all)
4815                        :test #'eq)
4816                  (needs-compilation component nil)))
4817     (let ((binary-pname (component-full-pathname component :binary)))
4818       (when (probe-file binary-pname)
4819         (with-tell-user ("Deleting binary"   component :binary)
4820                         (or *oos-test*
4821                             (delete-file binary-pname)))))))
4824 ;; when the operation = :compile, we can assume the binary exists in test mode.
4825 ;;      ((and *oos-test*
4826 ;;            (eq operation :compile)
4827 ;;            (probe-file (component-full-pathname component :source)))
4828 ;;       (with-tell-user ("Loading binary"   component :binary)))
4830 (defun binary-exists (component)
4831   (probe-file (component-full-pathname component :binary)))
4833 ;;; or old-binary
4834 (defun compile-and-load-source-if-no-binary (component)
4835   (when (not (or *load-source-instead-of-binary*
4836                  (and *load-source-if-no-binary*
4837                       (not (binary-exists component)))))
4838     (cond ((component-load-only component)
4839            #||
4840            (let ((prompt (prompt-string component)))
4841              (format t "~A- File ~A is load-only, ~
4842                         ~&~A  not compiling."
4843                      prompt
4844                      (component-full-pathname component :source)
4845                      prompt))
4846            ||#
4847            nil)
4848           ((eq *compile-during-load* :query)
4849            (let* ((prompt (prompt-string component))
4850                   (compile-source
4851                    (y-or-n-p-wait
4852                     #\y 30
4853                     "~A- Binary file ~A is old or does not exist. ~
4854                      ~&~A  Compile (and load) source file ~A instead? "
4855                     prompt
4856                     (component-full-pathname component :binary)
4857                     prompt
4858                     (component-full-pathname component :source))))
4859              (unless (y-or-n-p-wait
4860                       #\y 30
4861                       "~A- Should I bother you if this happens again? "
4862                       prompt)
4863                (setq *compile-during-load*
4864                      (y-or-n-p-wait
4865                       #\y 30
4866                       "~A- Should I compile while loading the system? "
4867                       prompt)))         ; was compile-source, then t
4868              compile-source))
4869           (*compile-during-load*)
4870           (t nil))))
4872 (defun load-source-if-no-binary (component)
4873   (and (not *load-source-instead-of-binary*)
4874        (or (and *load-source-if-no-binary*
4875                 (not (binary-exists component)))
4876            (component-load-only component)
4877            (when *bother-user-if-no-binary*
4878              (let* ((prompt (prompt-string component))
4879                     (load-source
4880                      (y-or-n-p-wait #\y 30
4881                       "~A- Binary file ~A does not exist. ~
4882                        ~&~A  Load source file ~A instead? "
4883                       prompt
4884                       (component-full-pathname component :binary)
4885                       prompt
4886                       (component-full-pathname component :source))))
4887                (setq *bother-user-if-no-binary*
4888                      (y-or-n-p-wait #\n 30
4889                       "~A- Should I bother you if this happens again? "
4890                       prompt ))
4891                (unless *bother-user-if-no-binary*
4892                  (setq *load-source-if-no-binary* load-source))
4893                load-source)))))
4895 ;;; ********************************
4896 ;;; Allegro Toplevel Commands ******
4897 ;;; ********************************
4898 ;;; Creates toplevel command aliases for Allegro CL.
4899 #+:allegro
4900 (top-level:alias ("compile-system" 8)
4901   (system &key force (minimal-load mk:*minimal-load*)
4902           test verbose version)
4903   "Compile the specified system"
4905   (mk:compile-system system :force force
4906                      :minimal-load minimal-load
4907                      :test test :verbose verbose
4908                      :version version))
4910 #+:allegro
4911 (top-level:alias ("load-system" 5)
4912   (system &key force (minimal-load mk:*minimal-load*)
4913           (compile-during-load mk:*compile-during-load*)
4914           test verbose version)
4915   "Compile the specified system"
4917   (mk:load-system system :force force
4918                   :minimal-load minimal-load
4919                   :compile-during-load compile-during-load
4920                   :test test :verbose verbose
4921                   :version version))
4923 #+:allegro
4924 (top-level:alias ("show-system" 5) (system)
4925   "Show information about the specified system."
4927   (mk:describe-system system))
4929 #+:allegro
4930 (top-level:alias ("describe-system" 9) (system)
4931   "Show information about the specified system."
4933   (mk:describe-system system))
4935 #+:allegro
4936 (top-level:alias ("system-source-size" 9) (system)
4937   "Show size information about source files in the specified system."
4939   (mk:system-source-size system))
4941 #+:allegro
4942 (top-level:alias ("clean-system" 6)
4943   (system &key force test verbose version)
4944   "Delete binaries in the specified system."
4946   (mk:clean-system system :force force
4947                    :test test :verbose verbose
4948                    :version version))
4950 #+:allegro
4951 (top-level:alias ("edit-system" 7)
4952   (system &key force test verbose version)
4953   "Load system source files into Emacs."
4955   (mk:edit-system system :force force
4956                   :test test :verbose verbose
4957                   :version version))
4959 #+:allegro
4960 (top-level:alias ("hardcopy-system" 9)
4961   (system &key force test verbose version)
4962   "Hardcopy files in the specified system."
4964   (mk:hardcopy-system system :force force
4965                       :test test :verbose verbose
4966                       :version version))
4968 #+:allegro
4969 (top-level:alias ("make-system-tag-table" 13) (system)
4970   "Make an Emacs TAGS file for source files in specified system."
4972   (mk:make-system-tag-table system))
4975 ;;; ********************************
4976 ;;; Allegro Make System Fasl *******
4977 ;;; ********************************
4978 #+:excl
4979 (defun allegro-make-system-fasl (system destination
4980                                         &optional (include-dependents t))
4981   (excl:shell
4982    (format nil "rm -f ~A; cat~{ ~A~} > ~A"
4983            destination
4984            (if include-dependents
4985                (files-in-system-and-dependents system :all :binary)
4986                (files-in-system system :all :binary))
4987            destination)))
4989 (defun files-which-need-compilation (system)
4990   (mapcar #'(lambda (comp) (component-full-pathname comp :source))
4991           (remove nil
4992                   (file-components-in-component
4993                    (find-system system :load) :new-source))))
4995 (defun files-in-system-and-dependents (name &optional (force :all)
4996                                             (type :source) version)
4997   ;; Returns a list of the pathnames in system and dependents in load order.
4998   (let ((system (find-system name :load)))
4999     (multiple-value-bind (*version-dir* *version-replace*)
5000         (translate-version version)
5001       (let ((*version* version))
5002         (let ((result (file-pathnames-in-component system type force)))
5003           (dolist (dependent (reverse (component-depends-on system)))
5004             (setq result
5005                   (append (files-in-system-and-dependents dependent
5006                                                           force type version)
5007                           result)))
5008           result)))))
5010 (defun files-in-system (name &optional (force :all) (type :source) version)
5011   ;; Returns a list of the pathnames in system in load order.
5012   (let ((system (if (and (component-p name)
5013                          (member (component-type name) '(:defsystem :system :subsystem)))
5014                     name
5015                     (find-system name :load))))
5016     (multiple-value-bind (*version-dir* *version-replace*)
5017         (translate-version version)
5018       (let ((*version* version))
5019         (file-pathnames-in-component system type force)))))
5021 (defun file-pathnames-in-component (component type &optional (force :all))
5022   (mapcar #'(lambda (comp) (component-full-pathname comp type))
5023           (file-components-in-component component force)))
5025 (defun file-components-in-component (component &optional (force :all)
5026                                                &aux result changed)
5027   (case (component-type component)
5028     ((:file :private-file)
5029      (when (setq changed
5030                  (or (find force '(:all t) :test #'eq)
5031                      (and (not (non-empty-listp force))
5032                           (needs-compilation component nil))))
5033        (setq result
5034              (list component))))
5035     ((:module :system :subsystem :defsystem)
5036      (dolist (module (component-components component))
5037        (multiple-value-bind (r c)
5038            (file-components-in-component
5039             module
5040             (cond ((and (some #'(lambda (dependent)
5041                                   (member dependent changed))
5042                               (component-depends-on module))
5043                         (or (non-empty-listp force)
5044                             (eq force :new-source-and-dependents)))
5045                    ;; The component depends on a changed file and force agrees.
5046                    :all)
5047                   ((and (non-empty-listp force)
5048                         (member (component-name module) force
5049                                 :test #'string-equal :key #'string))
5050                    ;; Force is a list of modules and the component is
5051                    ;; one of them.
5052                    :all)
5053                   (t force)))
5054          (when c
5055            (push module changed)
5056            (setq result (append result r)))))))
5057   (values result changed))
5059 (setf (symbol-function 'oos) (symbol-function 'operate-on-system))
5061 ;;; ********************************
5062 ;;; Additional Component Operations
5063 ;;; ********************************
5065 ;;; *** Edit Operation ***
5067 ;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))?
5069                                      #+:ccl
5070                                      (defun edit-operation (component force)
5071 "Always returns nil, i.e. component not changed."
5072 (declare (ignore force))
5074 (let* ((full-pathname (make::component-full-pathname component :source))
5075 (already-editing\? #+:mcl (dolist (w (CCL:windows :class
5076 'fred-window))
5077 (when (equal (CCL:window-filename w)
5078 full-pathname)
5079 (return w)))
5080 #-:mcl nil))
5081 (if already-editing\?
5082 #+:mcl (CCL:window-select already-editing\?) #-:mcl nil
5083 (ed full-pathname)))
5084 nil)
5086                                      #+:allegro
5087                                      (defun edit-operation (component force)
5088 "Edit a component - always returns nil, i.e. component not changed."
5089 (declare (ignore force))
5090 (let ((full-pathname (component-full-pathname component :source)))
5091 (ed full-pathname))
5092 nil)
5094                                      #+(or :ccl :allegro)
5095                                      (make::component-operation :edit 'edit-operation)
5096                                      #+(or :ccl :allegro)
5097                                      (make::component-operation 'edit 'edit-operation)
5098                                      |#
5100 ;;; *** Hardcopy System ***
5101 (defparameter *print-command* "enscript -2Gr" ; "lpr"
5102   "Command to use for printing files on UNIX systems.")
5103 #+:allegro
5104 (defun hardcopy-operation (component force)
5105   "Hardcopy a component - always returns nil, i.e. component not changed."
5106   (declare (ignore force))
5107   (let ((full-pathname (component-full-pathname component :source)))
5108     (excl:run-shell-command (format nil "~A ~A"
5109                                     *print-command* full-pathname)))
5110   nil)
5112 #+:allegro
5113 (make::component-operation :hardcopy 'hardcopy-operation)
5114 #+:allegro
5115 (make::component-operation 'hardcopy 'hardcopy-operation)
5118 ;;; *** System Source Size ***
5120 (defun system-source-size (system-name &optional (force :all))
5121   "Prints a short report and returns the size in bytes of the source files in
5122    <system-name>."
5123   (let* ((file-list (files-in-system system-name force :source))
5124          (total-size (file-list-size file-list)))
5125     (format t "~&~a/~a (~:d file~:p) totals ~:d byte~:p (~:d kB)"
5126             system-name force (length file-list)
5127             total-size (round total-size 1024))
5128     total-size))
5130 (defun file-list-size (file-list)
5131   "Returns the size in bytes of the files in <file-list>."
5132   ;;
5133   (let ((total-size 0))
5134     (dolist (file file-list)
5135       (with-open-file (stream file)
5136         (incf total-size (file-length stream))))
5137     total-size))
5139 ;;; *** System Tag Table ***
5141 #+:allegro
5142 (defun make-system-tag-table (system-name)
5143   "Makes an Emacs tag table using the GNU etags program."
5144   (let ((files-in-system (files-in-system system-name :all :source)))
5146     (format t "~&Making tag table...")
5147     (excl:run-shell-command (format nil "etags ~{~a ~}" files-in-system))
5148     (format t "done.~%")))
5151 ;;; end of file -- defsystem.lisp --