source: branches/working-0711/ccl/tools/defsystem.lisp @ 11810

Last change on this file since 11810 was 11810, checked in by gz, 10 years ago

Fix bad format (or warn etc.) calls found by the format string scanner

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 196.1 KB
Line 
1;;; -*- Mode: Lisp; Package: make -*-
2;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-
3
4;;; DEFSYSTEM 3.4 Interim.
5
6;;; defsystem.lisp --
7
8;;; ****************************************************************
9;;; MAKE -- A Portable Defsystem Implementation ********************
10;;; ****************************************************************
11
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.
19
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).
27
28;;; Originally written by Mark Kantrowitz, School of Computer Science,
29;;; Carnegie Mellon University, October 1989.
30
31;;; MK:DEFSYSTEM 3.3 Interim
32;;;
33;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
34;;;               1999 - 2004 Mark Kantrowitz and Marco Antoniotti. All
35;;;                           rights reserved.
36
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:
42
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.
54
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.
62
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.
67
68
69;;; Please send bug reports, comments and suggestions to <marcoxa@cons.org>.
70
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>
104;;;
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.
109;;;
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.
545
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
560
561;;;---------------------------------------------------------------------------
562;;; ISI Comments
563;;;
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.)
571
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
593;;;
594
595
596;;; ********************************
597;;; Ports **************************
598;;; ********************************
599;;;
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
618;;;
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
629
630;;; ********************************
631;;; To Do **************************
632;;; ********************************
633;;;
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.
645;;;
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).
650;;;
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.
655;;;
656;;; Create separate stand-alone documentation for defsystem, and also
657;;; a test suite.
658;;;
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)
663;;;
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.
667;;;
668;;; Need way to load old binaries even if source is newer.
669;;;
670;;; Allow defpackage forms/package definitions in the defsystem? If
671;;; a package not defined, look for and load a file named package.pkg?
672;;;
673;;; need to port for GNU CL (ala kcl)?
674;;;
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).
678;;;
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.
684;;;
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.
688;;;
689;;; System Class. Customizable delimiters.
690;;;
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?
695;;;
696;;; modify compile-file-operation to handle a query keyword....
697;;;
698;;; Perhaps systems should keep around the file-write-date of the system
699;;; definition file, to prevent excessive reloading of the system definition?
700;;;
701;;; load-file-operation needs to be completely reworked to simplify the
702;;; logic of when files get loaded or not.
703;;;
704;;; Need to revamp output: Nesting and indenting verbose output doesn't
705;;; seem cool, especially when output overflows the 80-column margins.
706;;;
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.
710;;;
711;;; :load-time for modules and systems -- maybe record the time the system
712;;; was loaded/compiled here and print it in describe-system?
713;;;
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.
717;;;
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).
723;;;
724;;;    Verify that Mac pathnames now work with append-directories.
725;;;
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.
732;;;
733;;; For a module none of whose files needed to be compiled, have it print out
734;;; "no files need recompilation".
735;;;
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.
740;;;
741;;; Add idea of a patch directory.
742;;;
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.
747;;;
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
753;;;
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.
762;;;
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?
767;;;
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.
796
797;;; ********************************************************************
798;;; How to Use this System *********************************************
799;;; ********************************************************************
800
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.
807
808;;; For more information, see the documentation and examples in
809;;; lisp-utilities.ps.
810
811;;; ********************************
812;;; Usage Comments *****************
813;;; ********************************
814
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.
822;;;
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".
826;;;
827
828
829;;; ****************************************************************
830;;; Lisp Code ******************************************************
831;;; ****************************************************************
832
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 :openmcl :sbcl)
839  (pushnew :cltl2 *features*))
840
841;;; ********************************
842;;; Provide/Require/*modules* ******
843;;; ********************************
844
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.
849
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.
856
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.
860
861;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code
862;;; necessary?
863
864#-(or :CMU
865      :vms
866      :mcl
867      :openmcl
868      :lispworks
869      :clisp
870      :gcl
871      :sbcl
872      :cormanlisp
873      :scl
874      (and allegro-version>= (version>= 4 1)))
875(eval-when #-(or :lucid)
876           (:compile-toplevel :load-toplevel :execute)
877           #+(or :lucid)
878           (compile load eval)
879
880  (unless (or (fboundp 'lisp::require)
881              (fboundp 'user::require)
882
883              #+(and :excl (and allegro-version>= (version>= 4 0)))
884              (fboundp 'cltl1::require)
885
886              #+:lispworks
887              (fboundp 'system::require))
888
889    #-:lispworks
890    (in-package "LISP")
891    #+:lispworks
892    (in-package "SYSTEM")
893
894    (export '(*modules* provide require))
895
896    ;; Documentation strings taken almost literally from CLtL1.
897
898    (defvar *modules* ()
899      "List of names of the modules that have been loaded into Lisp so far.
900     It is used by PROVIDE and REQUIRE.")
901
902    ;; We provide two different ways to define modules. The default way
903    ;; is to put either a source or binary file with the same name
904    ;; as the module in the library directory. The other way is to define
905    ;; the list of files in the module with defmodule.
906
907    ;; The directory listed in *library* is implementation dependent,
908    ;; and is intended to be used by Lisp manufacturers as a place to
909    ;; store their implementation dependent packages.
910    ;; Lisp users should use systems and *central-registry* to store
911    ;; their packages -- it is intended that *central-registry* is
912    ;; set by the user, while *library* is set by the lisp.
913
914    (defvar *library* nil               ; "/usr/local/lisp/Modules/"
915      "Directory within the file system containing files, where the name
916     of a file is the same as the name of the module it contains.")
917
918    (defvar *module-files* (make-hash-table :test #'equal)
919      "Hash table mapping from module names to list of files for the
920     module. REQUIRE loads these files in order.")
921
922    (defun canonicalize-module-name (name)
923      ;; if symbol, string-downcase the printrep to make nicer filenames.
924      (if (stringp name) name (string-downcase (string name))))
925
926    (defmacro defmodule (name &rest files)
927      "Defines a module NAME to load the specified FILES in order."
928      `(setf (gethash (canonicalize-module-name ,name) *module-files*)
929             ',files))
930    (defun module-files (name)
931      (gethash name *module-files*))
932
933    (defun provide (name)
934      "Adds a new module name to the list of modules maintained in the
935     variable *modules*, thereby indicating that the module has been
936     loaded. Name may be a string or symbol -- strings are case-senstive,
937     while symbols are treated like lowercase strings. Returns T if
938     NAME was not already present, NIL otherwise."
939      (let ((module (canonicalize-module-name name)))
940        (unless (find module *modules* :test #'string=)
941          ;; Module not present. Add it and return T to signify that it
942          ;; was added.
943          (push module *modules*)
944          t)))
945
946    (defun require (name &optional pathname)
947      "Tests whether a module is already present. If the module is not
948     present, loads the appropriate file or set of files. The pathname
949     argument, if present, is a single pathname or list of pathnames
950     whose files are to be loaded in order, left to right. If the
951     pathname is nil, the system first checks if a module was defined
952     using defmodule and uses the pathnames so defined. If that fails,
953     it looks in the library directory for a file with name the same
954     as that of the module. Returns T if it loads the module."
955      (let ((module (canonicalize-module-name name)))
956        (unless (find module *modules* :test #'string=)
957          ;; Module is not already present.
958          (when (and pathname (not (listp pathname)))
959            ;; If there's a pathname or pathnames, ensure that it's a list.
960            (setf pathname (list pathname)))
961          (unless pathname
962            ;; If there's no pathname, try for a defmodule definition.
963            (setf pathname (module-files module)))
964          (unless pathname
965            ;; If there's still no pathname, try the library directory.
966            (when *library*
967              (setf pathname (concatenate 'string *library* module))
968              ;; Test if the file exists.
969              ;; We assume that the lisp will default the file type
970              ;; appropriately. If it doesn't, use #+".fasl" or some
971              ;; such in the concatenate form above.
972              (if (probe-file pathname)
973                  ;; If it exists, ensure we've got a list
974                  (setf pathname (list pathname))
975                  ;; If the library file doesn't exist, we don't want
976                  ;; a load error.
977                  (setf pathname nil))))
978          ;; Now that we've got the list of pathnames, let's load them.
979          (dolist (pname pathname t)
980            (load pname :verbose nil))))))
981  ) ; eval-when
982
983;;; ********************************
984;;; Set up Package *****************
985;;; ********************************
986
987
988;;; Unfortunately, lots of lisps have their own defsystems, some more
989;;; primitive than others, all uncompatible, and all in the DEFSYSTEM
990;;; package. To avoid name conflicts, we've decided to name this the
991;;; MAKE package. A nice side-effect is that the short nickname
992;;; MK is my initials.
993
994#+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
995(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
996
997#-(or :sbcl :cltl2 :lispworks :ecl :scl)
998(in-package "MAKE" :nicknames '("MK"))
999
1000;;; For CLtL2 compatible lisps...
1001#+(and :excl :allegro-v4.0 :cltl2)
1002(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
1003            (:import-from cltl1 *modules* provide require))
1004
1005;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1006;;; In Allegro 4.1, 'provide' and 'require' are not external in
1007;;; 'CLTL1'.  However they are in 'COMMON-LISP'.  Hence the change.
1008#+(and :excl :allegro-v4.1 :cltl2)
1009(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) )
1010
1011#+(and :excl :allegro-version>= (version>= 4 2))
1012(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp))
1013
1014#+:lispworks
1015(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1016            (:import-from system *modules* provide require)
1017            (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
1018                     "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
1019
1020#+:mcl
1021(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1022  (:import-from ccl *modules* provide require))
1023
1024;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
1025;;; The code below, is originally executed also for CMUCL. However I
1026;;; believe this is wrong, since CMUCL comes with its own defpackage.
1027;;; I added the extra :CMU in the 'or'.
1028#+(and :cltl2 (not (or :cmu :clisp :sbcl
1029                       (and :excl (or :allegro-v4.0 :allegro-v4.1))
1030                       :mcl)))
1031(eval-when (compile load eval)
1032  (unless (find-package "MAKE")
1033    (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))
1034
1035;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
1036;;; Here I add the proper defpackage for CMU
1037#+:CMU
1038(defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
1039  (:nicknames "MK"))
1040
1041#+:sbcl
1042(defpackage "MAKE" (:use "COMMON-LISP")
1043  (:nicknames "MK"))
1044
1045#+:scl
1046(defpackage :make (:use :common-lisp)
1047  (:nicknames :mk))
1048
1049#+(or :cltl2 :lispworks :scl)
1050(eval-when (compile load eval)
1051  (in-package "MAKE"))
1052
1053#+ecl
1054(in-package "MAKE")
1055
1056;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1057;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
1058#+(and :excl :allegro-v4.0 :cltl2)
1059(cltl1:provide 'make)
1060#+(and :excl :allegro-v4.0 :cltl2)
1061(provide 'make)
1062
1063#+:openmcl
1064(cl:provide 'make)
1065
1066#+(and :mcl (not :openmcl))
1067(ccl:provide 'make)
1068
1069#+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)))
1070(provide 'make)
1071
1072#+:lispworks
1073(provide 'make)
1074
1075#-(or :cltl2 :lispworks)
1076(provide 'make)
1077
1078(pushnew :mk-defsystem *features*)
1079
1080;;; Some compatibility issues.  Mostly for CormanLisp.
1081;;; 2002-02-20 Marco Antoniotti
1082
1083#+cormanlisp
1084(defun compile-file-pathname (pathname-designator)
1085 (merge-pathnames (make-pathname :type "fasl")
1086                  (etypecase pathname-designator
1087                    (pathname pathname-designator)
1088                    (string (parse-namestring pathname-designator))
1089                    ;; We need FILE-STREAM here as well.
1090                    )))
1091
1092#+cormanlisp
1093(defun file-namestring (pathname-designator)
1094  (let ((p (etypecase pathname-designator
1095             (pathname pathname-designator)
1096             (string (parse-namestring pathname-designator))
1097             ;; We need FILE-STREAM here as well.
1098             )))
1099    (namestring (make-pathname :directory ()
1100                               :name (pathname-name p)
1101                               :type (pathname-type p)
1102                               :version (pathname-version p)))))
1103
1104;;; The external interface consists of *exports* and *other-exports*.
1105
1106;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in
1107;;; the compile form, so that you can't use a defvar with a default value and
1108;;; then a succeeding export as well.
1109
1110(eval-when (compile load eval)
1111   (defvar *special-exports* nil)
1112   (defvar *exports* nil)
1113   (defvar *other-exports* nil)
1114
1115   (export (setq *exports*
1116                 '(operate-on-system
1117                   oos
1118                   afs-binary-directory afs-source-directory
1119                   files-in-system)))
1120   (export (setq *special-exports*
1121                 '()))
1122   (export (setq *other-exports*
1123                 '(*central-registry*
1124                   *bin-subdir*
1125
1126                   add-registry-location
1127                   find-system
1128                   defsystem compile-system load-system hardcopy-system
1129
1130                   system-definition-pathname
1131
1132                   missing-component
1133                   missing-component-name
1134                   missing-component-component
1135                   missing-module
1136                   missing-system
1137
1138                   register-foreign-system
1139
1140                   machine-type-translation
1141                   software-type-translation
1142                   compiler-type-translation
1143                   ;; require
1144                   define-language
1145                   allegro-make-system-fasl
1146                   files-which-need-compilation
1147                   undefsystem
1148                   defined-systems
1149                   describe-system clean-system edit-system ;hardcopy-system
1150                   system-source-size make-system-tag-table
1151                   *defsystem-version*
1152                   *compile-during-load*
1153                   *minimal-load*
1154                   *dont-redefine-require*
1155                   *files-missing-is-an-error*
1156                   *reload-systems-from-disk*
1157                   *source-pathname-default*
1158                   *binary-pathname-default*
1159                   *multiple-lisp-support*
1160                   ))))
1161
1162
1163;;; We import these symbols into the USER package to make them
1164;;; easier to use. Since some lisps have already defined defsystem
1165;;; in the user package, we may have to shadowing-import it.
1166#|
1167#-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
1168(eval-when (compile load eval)
1169  (import *exports* #-(or :cltl2 :lispworks) "USER"
1170                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
1171  (import *special-exports* #-(or :cltl2 :lispworks) "USER"
1172                            #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
1173#+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
1174(eval-when (compile load eval)
1175  (import *exports* #-(or :cltl2 :lispworks) "USER"
1176                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
1177  (shadowing-import *special-exports*
1178                    #-(or :cltl2 :lispworks) "USER"
1179                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
1180|#
1181
1182#-(or :PCL :CLOS :scl)
1183(when (find-package "PCL")
1184  (pushnew :pcl *modules*)
1185  (pushnew :pcl *features*))
1186
1187;;; ********************************
1188;;; Defsystem Version **************
1189;;; ********************************
1190(defparameter *defsystem-version* "3.3 Interim, 2002-06-13"
1191  "Current version number/date for Defsystem.")
1192
1193;;; ********************************
1194;;; Customizable System Parameters *
1195;;; ********************************
1196
1197(defvar *dont-redefine-require* nil
1198  "If T, prevents the redefinition of REQUIRE. This is useful for
1199   lisps that treat REQUIRE specially in the compiler.")
1200
1201(defvar *multiple-lisp-support* t
1202  "If T, afs-binary-directory will try to return a name dependent
1203   on the particular lisp compiler version being used.")
1204
1205;;; home-subdirectory --
1206;;; HOME-SUBDIRECTORY is used only in *central-registry* below.
1207;;; Note that CMU CL 17e does not understand the ~/ shorthand for home
1208;;; directories.
1209;;;
1210;;; Note:
1211;;; 20020220 Marco Antoniotti
1212;;; The #-cormanlisp version is the original one, which is broken anyway, since
1213;;; it is UNIX dependent.
1214;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing
1215;;; the ANSI USER-HOMEDIR-PATHNAME function.
1216#-cormanlisp
1217(defun home-subdirectory (directory)
1218  (concatenate 'string
1219        #+(or :sbcl :cmu :scl)
1220        "home:"
1221        #-(or :sbcl :cmu :scl)
1222        (let ((homedir (user-homedir-pathname)))
1223          (or (and homedir (namestring homedir))
1224              "~/"))
1225        directory))
1226
1227#+cormanlisp
1228(defun home-subdirectory (directory)
1229  (declare (type string directory))
1230  (concatenate 'string "C:\\" directory))
1231
1232;;; The following function is available for users to add
1233;;;   (setq mk:*central-registry* (defsys-env-search-path))
1234;;; to Lisp init files in order to use the value of the DEFSYSPATH
1235;;; instead of directly coding it in the file.
1236#+:allegro
1237(defun defsys-env-search-path ()
1238  "This function grabs the value of the DEFSYSPATH environment variable
1239   and breaks the search path into a list of paths."
1240  (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
1241                     :test #'string-equal))
1242
1243;;; Change this variable to set up the location of a central
1244;;; repository for system definitions if you want one.
1245;;; This is a defvar to allow users to change the value in their
1246;;; lisp init files without worrying about it reverting if they
1247;;; reload defsystem for some reason.
1248
1249;;; Note that if a form is included in the registry list, it will be evaluated
1250;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check.
1251
1252(defvar *central-registry*
1253  `(;; Current directory
1254    "./"
1255    #+:LUCID     (working-directory)
1256    #+ACLPC      (current-directory)
1257    #+:allegro   (excl:current-directory)
1258    #+:sbcl      (progn *default-pathname-defaults*)
1259    #+(or :cmu :scl)       (ext:default-directory)
1260    ;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu>
1261    ;; Somehow it is better to qualify default-directory in CMU with
1262    ;; the appropriate package (i.e. "EXTENSIONS".)
1263    ;; Same for Allegro.
1264    #+(and :lispworks (not :lispworks4))
1265    ,(multiple-value-bind (major minor)
1266                          #-:lispworks-personal-edition
1267                          (system::lispworks-version)
1268                          #+:lispworks-personal-edition
1269                          (values system::*major-version-number*
1270                                  system::*minor-version-number*)
1271       (if (or (> major 3)
1272               (and (= major 3) (> minor 2))
1273               (and (= major 3) (= minor 2)
1274                    (equal (lisp-implementation-version) "3.2.1")))
1275           `(make-pathname :directory
1276                           ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
1277                                         (find-package "SYSTEM")))
1278           (find-symbol "*CURRENT-WORKING-DIRECTORY*"
1279                        (find-package "LW"))))
1280    #+:lispworks4
1281    (hcl:get-working-directory)
1282    ;; Home directory
1283    #-sbcl
1284    (mk::home-subdirectory "lisp/systems/")
1285
1286    ;; Global registry
1287    "/usr/local/lisp/Registry/")
1288  "Central directory of system definitions. May be either a single
1289   directory pathname, or a list of directory pathnames to be checked
1290   after the local directory.")
1291
1292
1293(defun add-registry-location (pathname)
1294  "Adds a path to the central registry."
1295  (pushnew pathname *central-registry* :test #'equal))
1296
1297(defvar *bin-subdir* ".bin/"
1298  "The subdirectory of an AFS directory where the binaries are really kept.")
1299
1300;;; These variables set up defaults for operate-on-system, and are used
1301;;; for communication in lieu of parameter passing. Yes, this is bad,
1302;;; but it keeps the interface small. Also, in the case of the -if-no-binary
1303;;; variables, parameter passing would require multiple value returns
1304;;; from some functions. Why make life complicated?
1305(defvar *tell-user-when-done* nil
1306  "If T, system will print ...DONE at the end of an operation")
1307(defvar *oos-verbose* nil
1308  "Operate on System Verbose Mode")
1309(defvar *oos-test* nil
1310  "Operate on System Test Mode")
1311(defvar *load-source-if-no-binary* nil
1312  "If T, system will try loading the source if the binary is missing")
1313(defvar *bother-user-if-no-binary* t
1314  "If T, the system will ask the user whether to load the source if
1315   the binary is missing")
1316(defvar *load-source-instead-of-binary* nil
1317  "If T, the system will load the source file instead of the binary.")
1318(defvar *compile-during-load* :query
1319  "If T, the system will compile source files during load if the
1320   binary file is missing. If :query, it will ask the user for
1321   permission first.")
1322(defvar *minimal-load* nil
1323  "If T, the system tries to avoid reloading files that were already loaded
1324   and up to date.")
1325
1326(defvar *files-missing-is-an-error* t
1327  "If both the source and binary files are missing, signal a continuable
1328   error instead of just a warning.")
1329
1330(defvar *operations-propagate-to-subsystems* t
1331  "If T, operations like :COMPILE and :LOAD propagate to subsystems
1332   of a system that are defined either using a component-type of :system
1333   or by another defsystem form.")
1334
1335;;; Particular to CMULisp
1336(defvar *compile-error-file-type* "err"
1337  "File type of compilation error file in cmulisp")
1338(defvar *cmu-errors-to-terminal* t
1339  "Argument to :errors-to-terminal in compile-file in cmulisp")
1340(defvar *cmu-errors-to-file* t
1341  "If T, cmulisp will write an error file during compilation")
1342
1343;;; ********************************
1344;;; Global Variables ***************
1345;;; ********************************
1346
1347;;; Massage people's *features* into better shape.
1348(eval-when (compile load eval)
1349  (dolist (feature *features*)
1350    (when (and (symbolp feature)   ; 3600
1351               (equal (symbol-name feature) "CMU"))
1352      (pushnew :CMU *features*)))
1353
1354  #+Lucid
1355  (when (search "IBM RT PC" (machine-type))
1356    (pushnew :ibm-rt-pc *features*))
1357  )
1358
1359;;; *filename-extensions* is a cons of the source and binary extensions.
1360(defvar *filename-extensions*
1361  (car `(#+(and Symbolics Lispm)              ("lisp" . "bin")
1362         #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
1363         #+(and dec common vax ultrix)        ("lsp"  . "fas")
1364         #+ACLPC                              ("lsp"  . "fsl")
1365         #+CLISP                              ("lsp"  . "fas")
1366         #+KCL                                ("lsp"  . "o")
1367         #+ECL                                ("lsp"  . "so")
1368         #+IBCL                               ("lsp"  . "o")
1369         #+Xerox                              ("lisp" . "dfasl")
1370         ;; Lucid on Silicon Graphics
1371         #+(and Lucid MIPS)                   ("lisp" . "mbin")
1372         ;; the entry for (and lucid hp300) must precede
1373         ;; that of (and lucid mc68000) for hp9000/300's running lucid,
1374         ;; since *features* on hp9000/300's also include the :mc68000
1375         ;; feature.
1376         #+(and lucid hp300)                  ("lisp" . "6bin")
1377         #+(and Lucid MC68000)                ("lisp" . "lbin")
1378         #+(and Lucid Vax)                    ("lisp" . "vbin")
1379         #+(and Lucid Prime)                  ("lisp" . "pbin")
1380         #+(and Lucid SUNRise)                ("lisp" . "sbin")
1381         #+(and Lucid SPARC)                  ("lisp" . "sbin")
1382         #+(and Lucid :IBM-RT-PC)             ("lisp" . "bbin")
1383         ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
1384         #+(and Lucid PA)                     ("lisp" . "hbin")
1385         #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
1386         #+(or :cmu :scl)  ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
1387;        #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
1388;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
1389;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
1390         #+PRIME                              ("lisp" . "pbin")
1391         #+HP                                 ("l"    . "b")
1392         #+TI ("lisp" . #.(string (si::local-binary-file-type)))
1393         #+:gclisp                            ("LSP"  . "F2S")
1394         #+pyramid                            ("clisp" . "o")
1395
1396         ;; Harlequin LispWorks
1397         #+:lispworks         ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
1398;        #+(and :sun4 :lispworks)             ("lisp" . "wfasl")
1399;        #+(and :mips :lispworks)             ("lisp" . "mfasl")
1400         #+:mcl                               ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
1401         #+:coral                             ("lisp" . "fasl")
1402
1403         ;; Otherwise,
1404         ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
1405  "Filename extensions for Common Lisp. A cons of the form
1406   (Source-Extension . Binary-Extension). If the system is
1407   unknown (as in *features* not known), defaults to lisp and fasl.")
1408
1409(defvar *system-extension*
1410  ;; MS-DOS systems can only handle three character extensions.
1411  #-ACLPC "system"
1412  #+ACLPC "sys"
1413  "The filename extension to use with systems.")
1414
1415;;; The above variables and code should be extended to allow a list of
1416;;; valid extensions for each lisp implementation, instead of a single
1417;;; extension. When writing a file, the first extension should be used.
1418;;; But when searching for a file, every extension in the list should
1419;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and
1420;;; "lsp" (*load-source-types*) as source code extensions, and
1421;;; (c:backend-fasl-file-type c:*backend*)
1422;;; (c:backend-byte-fasl-file-type c:*backend*)
1423;;; and "fasl" as binary (object) file extensions (*load-object-types*).
1424
1425;;; Note that the above code is used below in the LANGUAGE defstruct.
1426
1427;;; There is no real support for this variable being nil, so don't change it.
1428;;; Note that in any event, the toplevel system (defined with defsystem)
1429;;; will have its dependencies delayed. Not having dependencies delayed
1430;;; might be useful if we define several systems within one defsystem.
1431(defvar *system-dependencies-delayed* t
1432  "If T, system dependencies are expanded at run time")
1433
1434;;; Replace this with consp, dammit!
1435(defun non-empty-listp (list)
1436  (and list (listp list)))
1437
1438;;; ********************************
1439;;; Component Operation Definition *
1440;;; ********************************
1441(eval-when (:compile-toplevel :load-toplevel :execute)
1442(defvar *version-dir* nil
1443  "The version subdir. bound in operate-on-system.")
1444(defvar *version-replace* nil
1445  "The version replace. bound in operate-on-system.")
1446(defvar *version* nil
1447  "Default version."))
1448
1449(defvar *component-operations* (make-hash-table :test #'equal)
1450  "Hash table of (operation-name function) pairs.")
1451(defun component-operation (name &optional operation)
1452  (if operation
1453      (setf (gethash name *component-operations*) operation)
1454      (gethash name *component-operations*)))
1455
1456;;; ********************************
1457;;; AFS @sys immitator *************
1458;;; ********************************
1459
1460;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.
1461#-:mcl
1462(eval-when (compile load eval)
1463  ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo").
1464  ;; For example,
1465  ;;    <cl> #@"foo"
1466  ;;    "foo/.bin/rt_mach/"
1467  (set-dispatch-macro-character
1468   #\# #\@
1469   #'(lambda (stream char arg)
1470       (declare (ignore char arg))
1471       `(afs-binary-directory ,(read stream t nil t)))))
1472
1473(defvar *find-irix-version-script*
1474    "\"1,4 d\\
1475s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
1476/./,$ d\\
1477\"")
1478
1479(defun operating-system-version ()
1480  #+(and :sgi :excl)
1481  (let* ((full-version (software-version))
1482         (blank-pos (search " " full-version))
1483         (os (subseq full-version 0 blank-pos))
1484         (version-rest (subseq full-version
1485                               (1+ blank-pos)))
1486         os-version)
1487    (setq blank-pos (search " " version-rest))
1488    (setq version-rest (subseq version-rest
1489                               (1+ blank-pos)))
1490    (setq blank-pos (search " " version-rest))
1491    (setq os-version (subseq version-rest 0 blank-pos))
1492    (setq version-rest (subseq version-rest
1493                               (1+ blank-pos)))
1494    (setq blank-pos (search " " version-rest))
1495    (setq version-rest (subseq version-rest
1496                               (1+ blank-pos)))
1497    (concatenate 'string
1498      os " " os-version))      ; " " version-rest
1499  #+(and :sgi :cmu :sbcl)
1500  (concatenate 'string
1501    (software-type)
1502    (software-version))
1503  #+(and :lispworks :irix)
1504  (let ((soft-type (software-type)))
1505    (if (equalp soft-type "IRIX5")
1506        (progn
1507          (foreign:call-system
1508            (format nil "versions ~A | sed -e ~A > ~A"
1509                         "eoe1"
1510                         *find-irix-version-script*
1511                         "irix-version")
1512            "/bin/csh")
1513          (with-open-file (s "irix-version")
1514                          (format nil "IRIX ~S"
1515                                  (read s))))
1516      soft-type))
1517  #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
1518  (software-type))
1519
1520(defun compiler-version ()
1521  #+:lispworks (concatenate 'string
1522                "lispworks" " " (lisp-implementation-version))
1523  #+excl      (concatenate 'string
1524                "excl" " " excl::*common-lisp-version-number*)
1525  #+sbcl      (concatenate 'string
1526                           "sbcl" " " (lisp-implementation-version))
1527  #+cmu       (concatenate 'string
1528                "cmu" " " (lisp-implementation-version))
1529  #+scl       (concatenate 'string
1530                "scl" " " (lisp-implementation-version))
1531
1532  #+kcl       "kcl"
1533  #+IBCL      "ibcl"
1534  #+akcl      "akcl"
1535  #+gcl       "gcl"
1536  #+ecl       "ecl"
1537  #+lucid     "lucid"
1538  #+ACLPC     "aclpc"
1539  #+CLISP     "clisp"
1540  #+Xerox     "xerox"
1541  #+symbolics "symbolics"
1542  #+mcl       "mcl"
1543  #+coral     "coral"
1544  #+gclisp    "gclisp"
1545  )
1546
1547(defun afs-binary-directory (root-directory)
1548  ;; Function for obtaining the directory AFS's @sys feature would have
1549  ;; chosen when we're not in AFS. This function is useful as the argument
1550  ;; to :binary-pathname in defsystem. For example,
1551  ;; :binary-pathname (afs-binary-directory "scanner/")
1552  (let ((machine (machine-type-translation
1553                  #-(and :sgi :allegro-version>= (version>= 4 2))
1554                  (machine-type)
1555                  #+(and :sgi :allegro-version>= (version>= 4 2))
1556                  (machine-version)))
1557        (software (software-type-translation
1558                   #-(and :sgi (or :cmu :sbcl :scl
1559                                   (and :allegro-version>= (version>= 4 2))))
1560                   (software-type)
1561                   #+(and :sgi (or :cmu :sbcl :scl
1562                                   (and :allegro-version>= (version>= 4 2))))
1563                   (operating-system-version)))
1564        (lisp (compiler-type-translation (compiler-version))))
1565    ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
1566    (setq root-directory (namestring root-directory))
1567    (setq root-directory (ensure-trailing-slash root-directory))
1568    (format nil "~A~@[~A~]~@[~A/~]"
1569            root-directory
1570            *bin-subdir*
1571            (if *multiple-lisp-support*
1572                (afs-component machine software lisp)
1573              (afs-component machine software)))))
1574
1575(defun afs-source-directory (root-directory &optional version-flag)
1576  ;; Function for obtaining the directory AFS's @sys feature would have
1577  ;; chosen when we're not in AFS. This function is useful as the argument
1578  ;; to :source-pathname in defsystem.
1579  (setq root-directory (namestring root-directory))
1580  (setq root-directory (ensure-trailing-slash root-directory))
1581  (format nil "~A~@[~A/~]"
1582          root-directory
1583          (and version-flag (translate-version *version*))))
1584
1585(defun null-string (s)
1586  (when (stringp s)
1587    (string-equal s "")))
1588
1589(defun ensure-trailing-slash (dir)
1590  (if (and dir
1591           (not (null-string dir))
1592           (not (char= (char dir
1593                             (1- (length dir)))
1594                       #\/))
1595           (not (char= (char dir
1596                             (1- (length dir)))
1597                       #\\))
1598           )
1599      (concatenate 'string dir "/")
1600      dir))
1601
1602(defun afs-component (machine software &optional lisp)
1603  (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
1604            machine
1605            (or software "mach")
1606            lisp))
1607
1608(defvar *machine-type-alist* (make-hash-table :test #'equal)
1609  "Hash table for retrieving the machine-type")
1610(defun machine-type-translation (name &optional operation)
1611  (if operation
1612      (setf (gethash (string-upcase name) *machine-type-alist*) operation)
1613      (gethash (string-upcase name) *machine-type-alist*)))
1614
1615(machine-type-translation "IBM RT PC"                        "rt")
1616(machine-type-translation "DEC 3100"                         "pmax")
1617(machine-type-translation "DEC VAX-11"                       "vax")
1618(machine-type-translation "DECstation"                       "pmax")
1619(machine-type-translation "Sun3"                             "sun3")
1620(machine-type-translation "Sun-4"                            "sun4")
1621(machine-type-translation "MIPS Risc"                        "mips")
1622(machine-type-translation "SGI"                              "sgi")
1623(machine-type-translation "Silicon Graphics Iris 4D"         "sgi")
1624(machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi")
1625(machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi")
1626(machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi")
1627(machine-type-translation "IP22"                             "sgi")
1628;;; MIPS R4000 Processor Chip Revision: 3.0
1629;;; MIPS R4400 Processor Chip Revision: 5.0
1630;;; MIPS R4600 Processor Chip Revision: 1.0
1631(machine-type-translation "IP20"                             "sgi")
1632;;; MIPS R4000 Processor Chip Revision: 3.0
1633(machine-type-translation "IP17"                             "sgi")
1634;;; MIPS R4000 Processor Chip Revision: 2.2
1635(machine-type-translation "IP12"                             "sgi")
1636;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
1637(machine-type-translation "IP7"                              "sgi")
1638;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
1639
1640(machine-type-translation "x86"                              "x86")
1641;;; ACL
1642(machine-type-translation "IBM PC Compatible"                "x86")
1643;;; LW
1644(machine-type-translation "I686"                             "x86")
1645;;; LW
1646(machine-type-translation "PC/386"                           "x86")
1647;;; CLisp Win32
1648
1649#+(and :lucid :sun :mc68000)
1650(machine-type-translation "unknown"     "sun3")
1651
1652
1653(defvar *software-type-alist* (make-hash-table :test #'equal)
1654  "Hash table for retrieving the software-type")
1655(defun software-type-translation (name &optional operation)
1656  (if operation
1657      (setf (gethash (string-upcase name) *software-type-alist*) operation)
1658      (gethash (string-upcase name) *software-type-alist*)))
1659
1660(software-type-translation "BSD UNIX"      "mach") ; "unix"
1661(software-type-translation "Ultrix"        "mach") ; "ultrix"
1662(software-type-translation "SunOS"         "SunOS")
1663(software-type-translation "MACH/4.3BSD"   "mach")
1664(software-type-translation "IRIX System V" "irix") ; (software-type)
1665(software-type-translation "IRIX5"         "irix5")
1666;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version)
1667
1668(software-type-translation "IRIX 5.2" "irix5")
1669(software-type-translation "IRIX 5.3" "irix5")
1670(software-type-translation "IRIX5.2"  "irix5")
1671(software-type-translation "IRIX5.3"  "irix5")
1672
1673(software-type-translation "Linux" "linux") ; Lispworks for Linux
1674(software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL
1675(software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32")
1676(software-type-translation "Windows NT" "win32") ; LW for Windows
1677(software-type-translation "ANSI C program" "ansi-c") ; CLISP
1678(software-type-translation "C compiler" "ansi-c") ; CLISP for Win32
1679
1680(software-type-translation nil             "")
1681
1682#+:lucid
1683(software-type-translation "Unix"
1684                           #+:lcl4.0 "4.0"
1685                           #+(and :lcl3.0 (not :lcl4.0)) "3.0")
1686
1687(defvar *compiler-type-alist* (make-hash-table :test #'equal)
1688  "Hash table for retrieving the Common Lisp type")
1689(defun compiler-type-translation (name &optional operation)
1690  (if operation
1691      (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
1692    (gethash (string-upcase name) *compiler-type-alist*)))
1693
1694(compiler-type-translation "lispworks 3.2.1"         "lispworks")
1695(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
1696(compiler-type-translation "lispworks 4.2.0"         "lispworks")
1697
1698#+allegro
1699(eval-when (:compile-toplevel :load-toplevel :execute)
1700  (unless (or (find :case-sensitive common-lisp:*features*)
1701              (find :case-insensitive common-lisp:*features*))
1702    (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
1703            (eq excl:*current-case-mode* :case-sensitive-upper))
1704        (push :case-sensitive common-lisp:*features*)
1705      (push :case-insensitive common-lisp:*features*))))
1706
1707
1708#+(and allegro case-sensitive ics)
1709(compiler-type-translation "excl 6.1" "excl-m")
1710#+(and allegro case-sensitive (not ics))
1711(compiler-type-translation "excl 6.1" "excl-m8")
1712
1713#+(and allegro case-insensitive ics)
1714(compiler-type-translation "excl 6.1" "excl-a")
1715#+(and allegro case-insensitive (not ics))
1716(compiler-type-translation "excl 6.1" "excl-a8")
1717
1718(compiler-type-translation "excl 4.2" "excl")
1719(compiler-type-translation "excl 4.1" "excl")
1720(compiler-type-translation "cmu 17f" "cmu")
1721(compiler-type-translation "cmu 17e" "cmu")
1722(compiler-type-translation "cmu 17d" "cmu")
1723
1724;;; ********************************
1725;;; System Names *******************
1726;;; ********************************
1727
1728;;; If you use strings for system names, be sure to use the same case
1729;;; as it appears on disk, if the filesystem is case sensitive.
1730(defun canonicalize-system-name (name)
1731  ;; Originally we were storing systems using GET. This meant that the
1732  ;; name of a system had to be a symbol, so we interned the symbols
1733  ;; in the keyword package to avoid package dependencies. Now that we're
1734  ;; storing the systems in a hash table, we've switched to using strings.
1735  ;; Since the hash table is case sensitive, we use uppercase strings.
1736  ;; (Names of modules and files may be symbols or strings.)
1737  #||(if (keywordp name)
1738      name
1739      (intern (string-upcase (string name)) "KEYWORD"))||#
1740  (if (stringp name) (string-upcase name) (string-upcase (string name))))
1741
1742(defvar *defined-systems* (make-hash-table :test #'equal)
1743  "Hash table containing the definitions of all known systems.")
1744
1745(defun get-system (name)
1746  "Returns the definition of the system named NAME."
1747  (gethash (canonicalize-system-name name) *defined-systems*))
1748
1749(defsetf get-system (name) (value)
1750  `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))
1751
1752(defun undefsystem (name)
1753  "Removes the definition of the system named NAME."
1754  (setf (get-system name) nil))
1755
1756(defun defined-systems ()
1757  "Returns a list of defined systems."
1758  (let ((result nil))
1759    (maphash #'(lambda (key value)
1760                 (declare (ignore key))
1761                 (push value result))
1762             *defined-systems*)
1763    result))
1764
1765;;; ********************************
1766;;; Directory Pathname Hacking *****
1767;;; ********************************
1768
1769;;; Unix example: An absolute directory starts with / while a
1770;;; relative directory doesn't. A directory ends with /, while
1771;;; a file's pathname doesn't. This is important 'cause
1772;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".
1773
1774;;; I haven't been able to test the fix to the problem with symbolics
1775;;; hosts. Essentially, append-directories seems to have been tacking
1776;;; the default host onto the front of the pathname (e.g., mk::source-pathname
1777;;; gets a "B:" on front) and this overrides the :host specified in the
1778;;; component. The value of :host should override that specified in
1779;;; the :source-pathname and the default file server. If this doesn't
1780;;; fix things, specifying the host in the root pathname "F:>root-dir>"
1781;;; may be a good workaround.
1782
1783;;; Need to verify that merging of pathnames where modules are located
1784;;; on different devices (in VMS-based VAXLisp) now works.
1785
1786;;; Merge-pathnames works for VMS systems. In VMS systems, the directory
1787;;; part is enclosed in square brackets, e.g.,
1788;;;     "[root.child.child_child]" or "[root.][child.][child_child]"
1789;;; To concatenate directories merge-pathnames works as follows:
1790;;;     (merge-pathnames "" "[root]")               ==> "[root]"
1791;;;     (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
1792;;;     (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
1793;;;     (merge-pathnames "[root]file.ext" "[son]")  ==> "[root]file.ext"
1794;;; Thus the problem with the #-VMS code was that it was merging x y into
1795;;; [[x]][y] instead of [x][y] or [x]y.
1796
1797;;; Miscellaneous notes:
1798;;;   On GCLisp, the following are equivalent:
1799;;;       "\\root\\subdir\\BAZ"
1800;;;       "/root/subdir/BAZ"
1801;;;   On VAXLisp, the following are equivalent:
1802;;;       "[root.subdir]BAZ"
1803;;;       "[root.][subdir]BAZ"
1804;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2
1805
1806(defun new-append-directories (absolute-dir relative-dir)
1807  ;; Version of append-directories for CLtL2-compliant lisps. In particular,
1808  ;; they must conform to section 23.1.3 "Structured Directories". We are
1809  ;; willing to fix minor aberations in this function, but not major ones.
1810  ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
1811  ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
1812  (setf absolute-dir (or absolute-dir "")
1813        relative-dir (or relative-dir ""))
1814  (let* ((abs-dir (pathname absolute-dir))
1815         (rel-dir (pathname relative-dir))
1816         (host (pathname-host abs-dir))
1817         (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
1818                     (pathname-device rel-dir)
1819                   (pathname-device abs-dir)))
1820         (abs-directory (directory-to-list (pathname-directory abs-dir)))
1821         (abs-keyword (when (keywordp (car abs-directory))
1822                        (pop abs-directory)))
1823         ;; Stig (July 2001):
1824         ;; Somehow CLISP dies on the next line, but NIL is ok.
1825         (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
1826         (rel-directory (directory-to-list (pathname-directory rel-dir)))
1827         (rel-keyword (when (keywordp (car rel-directory))
1828                        (pop rel-directory)))
1829         #-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir))
1830         ;; Stig (July 2001);
1831         ;; These values seems to help clisp as well
1832         #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir))
1833         #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir))
1834         (directory nil))
1835
1836    ;; TI Common Lisp pathnames can return garbage for file names because
1837    ;; of bizarreness in the merging of defaults.  The following code makes
1838    ;; sure that the name is a valid name by comparing it with the
1839    ;; pathname-name.  It also strips TI specific extensions and handles
1840    ;; the necessary case conversion.  TI maps upper back into lower case
1841    ;; for unix files!
1842    #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal)
1843             (setf abs-name (string-right-trim "." (string-upcase abs-name)))
1844             (setf abs-name nil))
1845    #+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal)
1846             (setf rel-file (string-right-trim "." (string-upcase rel-file)))
1847             (setf rel-file nil))
1848    ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
1849    ;; and filename "foo". The namestring of a pathname with
1850    ;; directory '(:absolute :root "foo") ignores everything after the
1851    ;; :root.
1852    #+(and allegro-version>= (version>= 4 0))
1853    (when (eq (car abs-directory) :root) (pop abs-directory))
1854    #+(and allegro-version>= (version>= 4 0))
1855    (when (eq (car rel-directory) :root) (pop rel-directory))
1856
1857    (when (and abs-name (not (null-string abs-name))) ; was abs-name
1858      (cond ((and (null abs-directory) (null abs-keyword))
1859             #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
1860             (setf abs-directory (list abs-name)))
1861            (t
1862             (setf abs-directory (append abs-directory (list abs-name))))))
1863    (when (and (null abs-directory)
1864               (or (null abs-keyword)
1865                   ;; In Lucid, an abs-dir of nil gets a keyword of
1866                   ;; :relative since (pathname-directory (pathname ""))
1867                   ;; returns (:relative) instead of nil.
1868                   #+:lucid (eq abs-keyword :relative))
1869               rel-keyword)
1870      ;; The following feature switches seem necessary in CMUCL
1871      ;; Marco Antoniotti 19990707
1872      #+(or :sbcl :CMU)
1873      (if (typep abs-dir 'logical-pathname)
1874          (setf abs-keyword :absolute)
1875          (setf abs-keyword rel-keyword))
1876      #-(or :sbcl :CMU)
1877      (setf abs-keyword rel-keyword))
1878    (setf directory (append abs-directory rel-directory))
1879    (when abs-keyword (setf directory (cons abs-keyword directory)))
1880    (namestring
1881     (make-pathname :host host
1882                    :device device
1883                    :directory
1884                    directory
1885                    :name
1886                    #-(or :sbcl :MCL :clisp) rel-file
1887                    #+(or :sbcl :MCL :clisp) rel-name
1888
1889                    #+(or :sbcl :MCL :clisp) :type
1890                    #+(or :sbcl :MCL :clisp) rel-type
1891                    ))))
1892
1893(defun directory-to-list (directory)
1894  ;; The directory should be a list, but nonstandard implementations have
1895  ;; been known to use a vector or even a string.
1896  (cond ((listp directory)
1897         directory)
1898        ((stringp directory)
1899         (cond ((find #\; directory)
1900                ;; It's probably a logical pathname, so split at the
1901                ;; semicolons:
1902                (split-string directory :item #\;))
1903               #+MCL
1904               ((and (find #\: directory)
1905                     (not (find #\/ directory)))
1906                ;; It's probably a MCL pathname, so split at the colons.
1907                (split-string directory :item #\:))
1908               (t
1909                ;; It's probably a unix pathname, so split at the slash.
1910                (split-string directory :item #\/))))
1911        (t
1912         (coerce directory 'list))))
1913
1914
1915(defparameter *append-dirs-tests*
1916  '("~/foo/" "baz/bar.lisp"
1917     "~/foo" "baz/bar.lisp"
1918     "/foo/bar/" "baz/barf.lisp"
1919     "/foo/bar/" "/baz/barf.lisp"
1920     "foo/bar/" "baz/barf.lisp"
1921     "foo/bar" "baz/barf.lisp"
1922     "foo/bar" "/baz/barf.lisp"
1923     "foo/bar/" "/baz/barf.lisp"
1924     "/foo/bar/" nil
1925     "foo/bar/" nil
1926     "foo/bar" nil
1927     "foo" nil
1928     "foo" ""
1929     nil "baz/barf.lisp"
1930     nil "/baz/barf.lisp"
1931     nil nil))
1932
1933(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
1934  (do* ((dir-list test-dirs (cddr dir-list))
1935        (abs-dir (car dir-list) (car dir-list))
1936        (rel-dir (cadr dir-list) (cadr dir-list)))
1937      ((null dir-list) (values))
1938    (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
1939            abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
1940
1941#||
1942<cl> (test-new-append-directories)
1943
1944ABS: "~/foo/"     REL: "baz/bar.lisp"    Result: "/usr0/mkant/foo/baz/bar.lisp"
1945ABS: "~/foo"      REL: "baz/bar.lisp"    Result: "/usr0/mkant/foo/baz/bar.lisp"
1946ABS: "/foo/bar/"  REL: "baz/barf.lisp"   Result: "/foo/bar/baz/barf.lisp"
1947ABS: "/foo/bar/"  REL: "/baz/barf.lisp"  Result: "/foo/bar/baz/barf.lisp"
1948ABS: "foo/bar/"   REL: "baz/barf.lisp"   Result: "foo/bar/baz/barf.lisp"
1949ABS: "foo/bar"    REL: "baz/barf.lisp"   Result: "foo/bar/baz/barf.lisp"
1950ABS: "foo/bar"    REL: "/baz/barf.lisp"  Result: "foo/bar/baz/barf.lisp"
1951ABS: "foo/bar/"   REL: "/baz/barf.lisp"  Result: "foo/bar/baz/barf.lisp"
1952ABS: "/foo/bar/"  REL: NIL               Result: "/foo/bar/"
1953ABS: "foo/bar/"   REL: NIL               Result: "foo/bar/"
1954ABS: "foo/bar"    REL: NIL               Result: "foo/bar/"
1955ABS: "foo"        REL: NIL               Result: "foo/"
1956ABS: "foo"        REL: ""                Result: "foo/"
1957ABS: NIL          REL: "baz/barf.lisp"   Result: "baz/barf.lisp"
1958ABS: NIL          REL: "/baz/barf.lisp"  Result: "/baz/barf.lisp"
1959ABS: NIL          REL: NIL               Result: ""
1960
1961||#
1962
1963
1964(defun append-directories (absolute-directory relative-directory)
1965  "There is no CL primitive for tacking a subdirectory onto a directory.
1966   We need such a function because defsystem has both absolute and
1967   relative pathnames in the modules. This is a somewhat ugly hack which
1968   seems to work most of the time. We assume that ABSOLUTE-DIRECTORY
1969   is a directory, with no filename stuck on the end. Relative-directory,
1970   however, may have a filename stuck on the end."
1971  (when (or absolute-directory relative-directory)
1972    (cond
1973     ;; KMR commented out because: when appending two logical pathnames,
1974     ;; using this code translates the first logical pathname then appends
1975     ;; the second logical pathname -- an error.
1976     #|
1977      ;; We need a reliable way to determine if a pathname is logical.
1978      ;; Allegro 4.1 does not recognize the syntax of a logical pathname
1979      ;;  as being logical unless its logical host is already defined.
1980
1981      #+(or (and allegro-version>= (version>= 4 1))
1982            :logical-pathnames-mk)
1983      ((and absolute-directory
1984            (logical-pathname-p absolute-directory)
1985            relative-directory)
1986       ;; For use with logical pathnames package.
1987       (append-logical-directories-mk absolute-directory relative-directory))
1988     |#
1989      ((namestring-probably-logical absolute-directory)
1990       ;; A simplistic stab at handling logical pathnames
1991       (append-logical-pnames absolute-directory relative-directory))
1992      (t
1993       ;; In VMS, merge-pathnames actually does what we want!!!
1994       #+:VMS
1995       (namestring (merge-pathnames (or absolute-directory "")
1996                                    (or relative-directory "")))
1997       #+:macl1.3.2
1998       (namestring (make-pathname :directory absolute-directory
1999                                  :name relative-directory))
2000       ;; Cross your fingers and pray.
2001       #-(or :VMS :macl1.3.2)
2002       (new-append-directories absolute-directory relative-directory)))))
2003
2004#+:logical-pathnames-mk
2005(defun append-logical-directories-mk (absolute-dir relative-dir)
2006  (lp:append-logical-directories absolute-dir relative-dir))
2007
2008
2009;;; append-logical-pathnames-mk --
2010;;; The following is probably still bogus and it does not solve the
2011;;; problem of appending two logical pathnames.
2012;;; Anyway, as per suggetsion by KMR, the function is not called
2013;;; anymore.
2014;;; Hopefully this will not cause problems for ACL.
2015
2016#+(and (and allegro-version>= (version>= 4 1))
2017       (not :logical-pathnames-mk))
2018(defun append-logical-directories-mk (absolute-dir relative-dir)
2019  ;; We know absolute-dir and relative-dir are non nil.  Moreover
2020  ;; absolute-dir is a logical pathname.
2021  (setq absolute-dir (logical-pathname absolute-dir))
2022  (etypecase relative-dir
2023    (string (setq relative-dir (parse-namestring relative-dir)))
2024    (pathname #| do nothing |#))
2025
2026  (translate-logical-pathname
2027   (merge-pathnames relative-dir absolute-dir)))
2028
2029#| Old version 2002-03-02
2030#+(and (and allegro-version>= (version>= 4 1))
2031       (not :logical-pathnames-mk))
2032(defun append-logical-directories-mk (absolute-dir relative-dir)
2033  ;; We know absolute-dir and relative-dir are non nil.  Moreover
2034  ;; absolute-dir is a logical pathname.
2035  (setq absolute-dir (logical-pathname absolute-dir))
2036  (etypecase relative-dir
2037    (string (setq relative-dir (parse-namestring relative-dir)))
2038    (pathname #| do nothing |#))
2039
2040  (translate-logical-pathname
2041   (make-pathname
2042    :host (or (pathname-host absolute-dir)
2043              (pathname-host relative-dir))
2044    :directory (append (pathname-directory absolute-dir)
2045                       (cdr (pathname-directory relative-dir)))
2046    :name (or (pathname-name absolute-dir)
2047              (pathname-name relative-dir))
2048    :type (or (pathname-type absolute-dir)
2049              (pathname-type relative-dir))
2050    :version (or (pathname-version absolute-dir)
2051                 (pathname-version relative-dir)))))
2052
2053;; Old version
2054#+(and (and allegro-version>= (version>= 4 1))
2055       (not :logical-pathnames-mk))
2056(defun append-logical-directories-mk (absolute-dir relative-dir)
2057  (when (or absolute-dir relative-dir)
2058    (setq absolute-dir (logical-pathname (or absolute-dir ""))
2059          relative-dir (logical-pathname (or relative-dir "")))
2060    (translate-logical-pathname
2061     (make-pathname
2062      :host (or (pathname-host absolute-dir)
2063                (pathname-host relative-dir))
2064      :directory (append (pathname-directory absolute-dir)
2065                         (cdr (pathname-directory relative-dir)))
2066      :name (or (pathname-name absolute-dir)
2067                (pathname-name relative-dir))
2068      :type (or (pathname-type absolute-dir)
2069                (pathname-type relative-dir))
2070      :version (or (pathname-version absolute-dir)
2071                   (pathname-version relative-dir))))))
2072|#
2073
2074;;; determines if string or pathname object is logical
2075#+:logical-pathnames-mk
2076(defun logical-pathname-p (thing)
2077  (eq (lp:pathname-host-type thing) :logical))
2078
2079;;; From Kevin Layer for 4.1final.
2080#+(and (and allegro-version>= (version>= 4 1))
2081       (not :logical-pathnames-mk))
2082(defun logical-pathname-p (thing)
2083  (typep (parse-namestring thing) 'logical-pathname))
2084
2085(defun pathname-logical-p (thing)
2086  (typecase thing
2087    (logical-pathname t)
2088    #+clisp ; CLisp has non conformant Logical Pathnames.
2089    (pathname (pathname-logical-p (namestring thing)))
2090    (string (and (= 1 (count #\: thing)) ; Shortcut.
2091                 (ignore-errors (translate-logical-pathname thing))
2092                 t))
2093    (t nil)))
2094
2095;;; This affects only one thing.
2096;;; 19990707 Marco Antoniotti
2097;;; old version
2098
2099(defun namestring-probably-logical (namestring)
2100  (and (stringp namestring)
2101       ;; unix pathnames don't have embedded semicolons
2102       (find #\; namestring)))
2103#||
2104;;; New version
2105(defun namestring-probably-logical (namestring)
2106  (and (stringp namestring)
2107       (typep (parse-namestring namestring) 'logical-pathname)))
2108
2109
2110;;; New new version
2111;;; 20000321 Marco Antoniotti
2112(defun namestring-probably-logical (namestring)
2113  (pathname-logical-p namestring))
2114||#
2115
2116(defun append-logical-pnames (absolute relative)
2117  (declare (type (or null string pathname) absolute relative))
2118  (let ((abs (if absolute
2119                 #-clisp (namestring absolute)
2120                 #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
2121                 ""))
2122        (rel (if relative (namestring relative) ""))
2123        )
2124    ;; Make sure the absolute directory ends with a semicolon unless
2125    ;; the pieces are null strings
2126    (unless (or (null-string abs) (null-string rel)
2127                (char= (char abs (1- (length abs)))
2128                       #\;))
2129      (setq abs (concatenate 'string abs ";")))
2130    ;; Return the concatenate pathnames
2131    (concatenate 'string abs rel)))
2132
2133#||
2134;;; This was a try at appending a subdirectory onto a directory.
2135;;; It failed. We're keeping this around to prevent future mistakes
2136;;; of a similar sort.
2137(defun merge-directories (absolute-directory relative-directory)
2138  ;; replace concatenate with something more intelligent
2139  ;; i.e., concatenation won't work with some directories.
2140  ;; it should also behave well if the parent directory
2141  ;; has a filename at the end, or if the relative-directory ain't relative
2142  (when absolute-directory
2143    (setq absolute-directory (pathname-directory absolute-directory)))
2144  (concatenate 'string
2145               (or absolute-directory "")
2146               (or relative-directory "")))
2147||#
2148
2149#||
2150<cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
2151
2152D
2153<cl> (d "~/foo/" "baz/bar.lisp")
2154"/usr0/mkant/foo/baz/bar.lisp"
2155
2156<cl> (d "~/foo" "baz/bar.lisp")
2157"/usr0/mkant/foo/baz/bar.lisp"
2158
2159<cl> (d "/foo/bar/" "baz/barf.lisp")
2160"/foo/bar/baz/barf.lisp"
2161
2162<cl> (d "foo/bar/" "baz/barf.lisp")
2163"foo/bar/baz/barf.lisp"
2164
2165<cl> (d "foo/bar" "baz/barf.lisp")
2166"foo/bar/baz/barf.lisp"
2167
2168<cl> (d "foo/bar" "/baz/barf.lisp")
2169"foo/bar//baz/barf.lisp"
2170
2171<cl> (d "foo/bar" nil)
2172"foo/bar/"
2173
2174<cl> (d nil "baz/barf.lisp")
2175"baz/barf.lisp"
2176
2177<cl> (d nil nil)
2178""
2179
2180||#
2181
2182;;; The following is a change proposed by DTC for SCL.
2183;;; Maybe it could be used all the time.
2184
2185#-scl
2186(defun new-file-type (pathname type)
2187  ;; why not (make-pathname :type type :defaults pathname)?
2188  (make-pathname
2189   :host (pathname-host pathname)
2190   :device (pathname-device pathname)
2191   :directory (pathname-directory pathname)
2192   :name (pathname-name pathname)
2193   :type type
2194   :version (pathname-version pathname)))
2195
2196
2197#+scl
2198(defun new-file-type (pathname type)
2199  ;; why not (make-pathname :type type :defaults pathname)?
2200  (make-pathname
2201   :host (pathname-host pathname :case :common)
2202   :device (pathname-device pathname :case :common)
2203   :directory (pathname-directory pathname :case :common)
2204   :name (pathname-name pathname :case :common)
2205   :type (string-upcase type)
2206   :version (pathname-version pathname :case :common)))
2207
2208
2209
2210;;; ********************************
2211;;; Component Defstruct ************
2212;;; ********************************
2213(defvar *source-pathname-default* nil
2214  "Default value of :source-pathname keyword in DEFSYSTEM. Set this to
2215   \"\" to avoid having to type :source-pathname \"\" all the time.")
2216
2217(defvar *binary-pathname-default* nil
2218  "Default value of :binary-pathname keyword in DEFSYSTEM.")
2219
2220;;; Removed TIME slot, which has been made unnecessary by the new definition
2221;;; of topological-sort.
2222
2223(defstruct (topological-sort-node (:conc-name topsort-))
2224  (color :white :type (member :gray :black :white))
2225  ;; time
2226  )
2227
2228(defstruct (component (:include topological-sort-node)
2229                      (:print-function print-component))
2230  (type :file     ; to pacify the CMUCL compiler (:type is alway supplied)
2231        :type (member :defsystem
2232                      :system
2233                      :subsystem
2234                      :module
2235                      :file
2236                      :private-file
2237                      ))
2238  (name nil :type (or symbol string))
2239  (indent 0 :type (mod 1024))           ; Number of characters of indent in
2240                                        ; verbose output to the user.
2241  host                                  ; The pathname host (i.e., "/../a").
2242  device                                ; The pathname device.
2243  source-root-dir                       ; Relative or absolute (starts
2244                                        ; with "/"), directory or file
2245                                        ; (ends with "/").
2246  (source-pathname *source-pathname-default*)
2247  source-extension                      ; A string, e.g., "lisp"
2248                                        ; if NIL, inherit
2249  (binary-pathname *binary-pathname-default*)
2250  binary-root-dir
2251  binary-extension                      ; A string, e.g., "fasl". If
2252                                        ; NIL, uses default for
2253                                        ; machine-type.
2254  package                               ; Package for use-package.
2255
2256  ;; The following three slots are used to provide for alternate compilation
2257  ;; and loading functions for the files contained within a component. If
2258  ;; a component has a compiler or a loader specified, those functions are
2259  ;; used. Otherwise the functions are derived from the language. If no
2260  ;; language is specified, it defaults to Common Lisp (:lisp). Other current
2261  ;; possible languages include :scheme (PseudoScheme) and :c, but the user
2262  ;; can define additional language mappings. Compilation functions should
2263  ;; accept a pathname argument and a :output-file keyword; loading functions
2264  ;; just a pathname argument. The default functions are #'compile-file and
2265  ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to
2266  ;; mix languages.
2267  (language nil :type (or null symbol))
2268  (compiler nil :type (or null symbol function))
2269  (loader   nil :type (or null symbol function))
2270  (compiler-options nil :type list)     ; A list of compiler options to
2271                                        ; use for compiling this
2272                                        ; component.  These must be
2273                                        ; keyword options supported by
2274                                        ; the compiler.
2275
2276  (components () :type list)            ; A list of components
2277                                        ; comprising this component's
2278                                        ; definition.
2279  (depends-on () :type list)            ; A list of the components
2280                                        ; this one depends on. may
2281                                        ; refer only to the components
2282                                        ; at the same level as this
2283                                        ; one.
2284  proclamations                         ; Compiler options, such as
2285                                        ; '(optimize (safety 3)).
2286  initially-do                          ; Form to evaluate before the
2287                                        ; operation.
2288  finally-do                            ; Form to evaluate after the operation.
2289  compile-form                          ; For foreign libraries.
2290  load-form                             ; For foreign libraries.
2291
2292  ;; load-time                          ; The file-write-date of the
2293                                        ; binary/source file loaded.
2294
2295  ;; If load-only is T, will not compile the file on operation :compile.
2296  ;; In other words, for files which are :load-only T, loading the file
2297  ;; satisfies any demand to recompile.
2298  load-only                             ; If T, will not compile this
2299                                        ; file on operation :compile.
2300  ;; If compile-only is T, will not load the file on operation :compile.
2301  ;; Either compiles or loads the file, but not both. In other words,
2302  ;; compiling the file satisfies the demand to load it. This is useful
2303  ;; for PCL defmethod and defclass definitions, which wrap a
2304  ;; (eval-when (compile load eval) ...) around the body of the definition.
2305  ;; This saves time in some lisps.
2306  compile-only                          ; If T, will not load this
2307                                        ; file on operation :compile.
2308  #|| ISI Extension ||#
2309  load-always                           ; If T, will force loading
2310                                        ; even if file has not
2311                                        ; changed.
2312  ;; PVE: add banner
2313  (banner nil :type (or null string))
2314
2315  (documentation nil :type (or null string)) ; Optional documentation slot
2316  )
2317
2318
2319;;; To allow dependencies from "foreign systems" like ASDF or one of
2320;;; the proprietary ones like ACL or LW.
2321
2322(defstruct (foreign-system (:include component (type :system)))
2323  kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...)
2324  object ; The actual foreign system object.
2325  )
2326
2327
2328(defun register-foreign-system (name &key representation kind)
2329  (declare (type (or symbol string) name))
2330  (let ((fs (make-foreign-system :name name
2331                                 :kind kind
2332                                 :object representation)))
2333    (setf (get-system name) fs)))
2334
2335
2336
2337(define-condition missing-component (simple-condition)
2338  ((name :reader missing-component-name
2339         :initarg :name)
2340   (component :reader missing-component-component
2341              :initarg :component)
2342   )
2343  (:default-initargs :component nil)
2344  (:report (lambda (mmc stream)
2345             (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
2346                     (missing-component-name mmc)
2347                     (missing-component-component mmc))))
2348  )
2349
2350(define-condition missing-module (missing-component)
2351  ()
2352  (:report (lambda (mmc stream)
2353             (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
2354                     (missing-component-name mmc)
2355                     (missing-component-component mmc))))
2356  )
2357
2358(define-condition missing-system (missing-module)
2359  ()
2360  (:report (lambda (msc stream)
2361             (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
2362                     (missing-component-name msc)
2363                     (missing-component-component msc))))
2364  )
2365
2366
2367
2368(defvar *file-load-time-table* (make-hash-table :test #'equal)
2369  "Hash table of file-write-dates for the system definitions and
2370   files in the system definitions.")
2371(defun component-load-time (component)
2372  (when component
2373    (etypecase component
2374      (string    (gethash component *file-load-time-table*))
2375      (pathname (gethash (namestring component) *file-load-time-table*))
2376      (component
2377       (ecase (component-type component)
2378         (:defsystem
2379          (let* ((name (component-name component))
2380                 (path (when name (compute-system-path name nil))))
2381            (declare (type (or string pathname null) path))
2382            (when path
2383              (gethash (namestring path) *file-load-time-table*))))
2384         ((:file :private-file)
2385          ;; Use only :source pathname to identify component's
2386          ;; load time.
2387          (let ((path (component-full-pathname component :source)))
2388            (when path
2389              (gethash path *file-load-time-table*)))))))))
2390
2391#-(or :cmu)
2392(defsetf component-load-time (component) (value)
2393  `(when ,component
2394    (etypecase ,component
2395      (string   (setf (gethash ,component *file-load-time-table*) ,value))
2396      (pathname (setf (gethash (namestring (the pathname ,component))
2397                               *file-load-time-table*)
2398                      ,value))
2399      (component
2400       (ecase (component-type ,component)
2401         (:defsystem
2402          (let* ((name (component-name ,component))
2403                 (path (when name (compute-system-path name nil))))
2404            (declare (type (or string pathname null) path))
2405            (when path
2406              (setf (gethash (namestring path) *file-load-time-table*)
2407                    ,value))))
2408         ((:file :private-file)
2409          ;; Use only :source pathname to identify file.
2410          (let ((path (component-full-pathname ,component :source)))
2411            (when path
2412              (setf (gethash path *file-load-time-table*)
2413                    ,value)))))))
2414    ,value))
2415
2416#+(or :cmu)
2417(defun (setf component-load-time) (value component)
2418  (declare
2419   (type (or null string pathname component) component)
2420   (type (or unsigned-byte null) value))
2421  (when component
2422    (etypecase component
2423      (string   (setf (gethash component *file-load-time-table*) value))
2424      (pathname (setf (gethash (namestring (the pathname component))
2425                               *file-load-time-table*)
2426                      value))
2427      (component
2428       (ecase (component-type component)
2429         (:defsystem
2430             (let* ((name (component-name component))
2431                    (path (when name (compute-system-path name nil))))
2432               (declare (type (or string pathname null) path))
2433               (when path
2434                 (setf (gethash (namestring path) *file-load-time-table*)
2435                       value))))
2436         ((:file :private-file)
2437          ;; Use only :source pathname to identify file.
2438          (let ((path (component-full-pathname component :source)))
2439            (when path
2440              (setf (gethash path *file-load-time-table*)
2441                    value)))))))
2442    value))
2443
2444
2445;;; compute-system-path --
2446
2447(defun compute-system-path (module-name definition-pname)
2448  (let* ((file-pathname
2449          (make-pathname :name (etypecase module-name
2450                                 (symbol (string-downcase
2451                                          (string module-name)))
2452                                 (string module-name))
2453                         :type *system-extension*))
2454         (lib-file-pathname
2455          (make-pathname :directory (list :relative module-name)
2456                         :name (etypecase module-name
2457                                 (symbol (string-downcase
2458                                          (string module-name)))
2459                                 (string module-name))
2460                         :type *system-extension*))
2461         )
2462    (or (when definition-pname          ; given pathname for system def
2463          (probe-file definition-pname))
2464        ;; Then the central registry. Note that we also check the current
2465        ;; directory in the registry, but the above check is hard-coded.
2466        (cond (*central-registry*
2467               (if (listp *central-registry*)
2468                   (dolist (registry *central-registry*)
2469                     (let ((file (or (probe-file
2470                                      (append-directories (if (consp registry)
2471                                                              (eval registry)
2472                                                              registry)
2473                                                          file-pathname))
2474                                     (probe-file
2475                                      (append-directories (if (consp registry)
2476                                                              (eval registry)
2477                                                              registry)
2478                                                          lib-file-pathname))
2479                                     ))
2480                           )
2481                       (when file (return file))))
2482                   (or (probe-file (append-directories *central-registry*
2483                                                       file-pathname))
2484                       (probe-file (append-directories *central-registry*
2485                                                       lib-file-pathname))
2486                       ))
2487               )
2488              (t
2489               ;; No central registry. Assume current working directory.
2490               ;; Maybe this should be an error?
2491               (or (probe-file file-pathname)
2492                   (probe-file lib-file-pathname)))))
2493    ))
2494
2495
2496(defun system-definition-pathname (system-name)
2497  (let ((system (ignore-errors (find-system system-name :error))))
2498    (if system
2499        (let ((system-def-pathname
2500               (make-pathname :type "system"
2501                              :defaults (pathname (component-full-pathname system :source))))
2502              )
2503          (values system-def-pathname
2504                  (probe-file system-def-pathname)))
2505        (values nil nil))))
2506         
2507         
2508
2509
2510#|
2511
2512(defun compute-system-path (module-name definition-pname)
2513  (let* ((filename (format nil "~A.~A"
2514                           (if (symbolp module-name)
2515                               (string-downcase (string module-name))
2516                             module-name)
2517                           *system-extension*)))
2518    (or (when definition-pname          ; given pathname for system def
2519          (probe-file definition-pname))
2520        ;; Then the central registry. Note that we also check the current
2521        ;; directory in the registry, but the above check is hard-coded.
2522        (cond (*central-registry*
2523               (if (listp *central-registry*)
2524                   (dolist (registry *central-registry*)
2525                     (let ((file (probe-file
2526                                  (append-directories (if (consp registry)
2527                                                          (eval registry)
2528                                                        registry)
2529                                                      filename))))
2530                       (when file (return file))))
2531                 (probe-file (append-directories *central-registry*
2532                                                 filename))))
2533              (t
2534               ;; No central registry. Assume current working directory.
2535               ;; Maybe this should be an error?
2536               (probe-file filename))))))
2537|#
2538
2539
2540(defvar *reload-systems-from-disk* t
2541  "If T, always tries to reload newer system definitions from disk.
2542   Otherwise first tries to find the system definition in the current
2543   environment.")
2544
2545(defun find-system (system-name &optional (mode :ask) definition-pname)
2546  "Returns the system named SYSTEM-NAME.
2547If not already loaded, loads it, depending on the value of
2548*RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK,
2549:ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default.
2550This allows OPERATE-ON-SYSTEM to work on non-loaded as well as
2551loaded system definitions. DEFINITION-PNAME is the pathname for
2552the system definition, if provided."
2553  (ecase mode
2554    (:ask
2555     (or (get-system system-name)
2556         (when (y-or-n-p-wait
2557                #\y 20
2558                "System ~A not loaded. Shall I try loading it? "
2559                system-name)
2560           (find-system system-name :load definition-pname))))
2561    (:error
2562     (or (get-system system-name)
2563         (error 'missing-system :name system-name)))
2564    (:load-or-nil
2565     (let ((system (get-system system-name)))
2566       (or (unless *reload-systems-from-disk* system)
2567           ;; If SYSTEM-NAME is a symbol, it will lowercase the
2568           ;; symbol's string.
2569           ;; If SYSTEM-NAME is a string, it doesn't change the case of the
2570           ;; string. So if case matters in the filename, use strings, not
2571           ;; symbols, wherever the system is named.
2572           (when (foreign-system-p system)
2573             (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system)
2574             (return-from find-system nil))
2575           (let ((path (compute-system-path system-name definition-pname)))
2576             (when (and path
2577                        (or (null system)
2578                            (null (component-load-time path))
2579                            (< (component-load-time path)
2580                               (file-write-date path))))
2581               (tell-user-generic
2582                (format nil "Loading system ~A from file ~A"
2583                        system-name
2584                        path))
2585               (load path)
2586               (setf system (get-system system-name))
2587               (when system
2588                 (setf (component-load-time path)
2589                       (file-write-date path))))
2590             system)
2591           system)))
2592    (:load
2593     (or (unless *reload-systems-from-disk* (get-system system-name))
2594         (when (foreign-system-p (get-system system-name))
2595           (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system-name)
2596           (return-from find-system nil))
2597         (or (find-system system-name :load-or-nil definition-pname)
2598             (error "Can't find system named ~s." system-name))))))
2599
2600
2601(defun print-component (component stream depth)
2602  (declare (ignore depth))
2603  (format stream "#<~:@(~A~): ~A>"
2604          (component-type component)
2605          (component-name component)))
2606
2607
2608(defun describe-system (name &optional (stream *standard-output*))
2609  "Prints a description of the system to the stream. If NAME is the
2610   name of a system, gets it and prints a description of the system.
2611   If NAME is a component, prints a description of the component."
2612  (let ((system (if (typep name 'component) name (find-system name :load))))
2613    (format stream "~&~A ~A: ~
2614                    ~@[~&   Host: ~A~]~
2615                    ~@[~&   Device: ~A~]~
2616                    ~@[~&   Package: ~A~]~
2617                    ~&   Source: ~@[~A~] ~@[~A~] ~@[~A~]~
2618                    ~&   Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
2619                    ~@[~&   Depends On: ~A ~]~&   Components: ~{~15T~A~&~}"
2620            (component-type system)
2621            (component-name system)
2622            (component-host system)
2623            (component-device system)
2624            (component-package system)
2625            (component-root-dir system :source)
2626            (component-pathname system :source)
2627            (component-extension system :source)
2628            (component-root-dir system :binary)
2629            (component-pathname system :binary)
2630            (component-extension system :binary)
2631            (component-depends-on system)
2632            (component-components system))
2633    #||(when recursive
2634      (dolist (component (component-components system))
2635        (describe-system component stream recursive)))||#
2636    system))
2637
2638(defun canonicalize-component-name (component)
2639  ;; Within the component, the name is a string.
2640  (if (typep (component-name component) 'string)
2641      ;; Unnecessary to change it, so just return it, same case
2642      (component-name component)
2643    ;; Otherwise, make it a downcase string -- important since file
2644    ;; names are often constructed from component names, and unix
2645    ;; prefers lowercase as a default.
2646    (setf (component-name component)
2647          (string-downcase (string (component-name component))))))
2648
2649(defun component-pathname (component type)
2650  (when component
2651    (ecase type
2652      (:source (component-source-pathname component))
2653      (:binary (component-binary-pathname component))
2654      (:error  (component-error-pathname component)))))
2655(defun component-error-pathname (component)
2656  (let ((binary (component-pathname component :binary)))
2657    (new-file-type binary *compile-error-file-type*)))
2658(defsetf component-pathname (component type) (value)
2659  `(when ,component
2660     (ecase ,type
2661       (:source (setf (component-source-pathname ,component) ,value))
2662       (:binary (setf (component-binary-pathname ,component) ,value)))))
2663
2664(defun component-root-dir (component type)
2665  (when component
2666    (ecase type
2667      (:source (component-source-root-dir component))
2668      ((:binary :error) (component-binary-root-dir component))
2669      )))
2670(defsetf component-root-dir (component type) (value)
2671  `(when ,component
2672     (ecase ,type
2673       (:source (setf (component-source-root-dir ,component) ,value))
2674       (:binary (setf (component-binary-root-dir ,component) ,value)))))
2675
2676(defvar *source-pathnames-table* (make-hash-table :test #'equal)
2677  "Table which maps from components to full source pathnames.")
2678(defvar *binary-pathnames-table* (make-hash-table :test #'equal)
2679  "Table which maps from components to full binary pathnames.")
2680(defparameter *reset-full-pathname-table* t
2681  "If T, clears the full-pathname tables before each call to
2682   OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance
2683   after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could
2684   result in changes to system and language definitions to not take
2685   effect, and so should be used with caution.")
2686(defun clear-full-pathname-tables ()
2687  (clrhash *source-pathnames-table*)
2688  (clrhash *binary-pathnames-table*))
2689
2690(defun component-full-pathname (component type &optional (version *version*))
2691  (when component
2692    (case type
2693      (:source
2694       (let ((old (gethash component *source-pathnames-table*)))
2695         (or old
2696             (let ((new (component-full-pathname-i component type version)))
2697               (setf (gethash component *source-pathnames-table*) new)
2698               new))))
2699      (:binary
2700        (let ((old (gethash component *binary-pathnames-table*)))
2701         (or old
2702             (let ((new (component-full-pathname-i component type version)))
2703               (setf (gethash component *binary-pathnames-table*) new)
2704               new))))
2705      (otherwise
2706       (component-full-pathname-i component type version)))))
2707
2708(defun component-full-pathname-i (component type &optional (version *version*)
2709                                            &aux version-dir version-replace)
2710  ;; If the pathname-type is :binary and the root pathname is null,
2711  ;; distribute the binaries among the sources (= use :source pathname).
2712  ;; This assumes that the component's :source pathname has been set
2713  ;; before the :binary one.
2714  (if version
2715      (multiple-value-setq (version-dir version-replace)
2716        (translate-version version))
2717      (setq version-dir *version-dir* version-replace *version-replace*))
2718  (let ((pathname
2719         (append-directories
2720          (if version-replace
2721              version-dir
2722              (append-directories (component-root-dir component type)
2723                                  version-dir))
2724          (component-pathname component type))))
2725
2726    ;; When a logical pathname is used, it must first be translated to
2727    ;; a physical pathname. This isn't strictly correct. What should happen
2728    ;; is we fill in the appropriate slots of the logical pathname, and
2729    ;; then return the logical pathname for use by compile-file & friends.
2730    ;; But calling translate-logical-pathname to return the actual pathname
2731    ;; should do for now.
2732
2733    ;; (format t "pathname = ~A~%" pathname)
2734    ;; (format t "type = ~S~%" (component-extension component type))
2735
2736    ;; 20000303 Marco Antoniotti
2737    ;; Changed the following according to suggestion by Ray Toy.  I
2738    ;; just collapsed the tests for "logical-pathname-ness" into a
2739    ;; single test (heavy, but probably very portable) and added the
2740    ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES
2741    ;; beacuse of possible null names (e.g. :defsystem components)
2742    ;; causing problems with the subsequenct call to NAMESTRING.
2743    (cond ((pathname-logical-p pathname) ; See definition of test above.
2744           (setf pathname
2745                 (merge-pathnames pathname
2746                                  (make-pathname
2747                                   :name (component-name component)
2748                                   :type (component-extension component
2749                                                              type))))
2750           ;;(format t "new path = ~A~%" pathname)
2751           (namestring (translate-logical-pathname pathname)))
2752          (t
2753           (namestring
2754            (make-pathname :host (when (component-host component)
2755                                   ;; MCL2.0b1 and ACLPC cause an error on
2756                                   ;; (pathname-host nil)
2757                                   (pathname-host (component-host component)
2758                                                  #+scl :case #+scl :common
2759                                                  ))
2760                           :directory (pathname-directory pathname
2761                                                  #+scl :case #+scl :common
2762                                                  )
2763                           ;; Use :directory instead of :defaults
2764                           :name (pathname-name pathname
2765                                                  #+scl :case #+scl :common
2766                                                  )
2767                           :type #-scl (component-extension component type)
2768                                 #+scl (string-upcase
2769                                        (component-extension component type))
2770                           :device
2771                           #+sbcl
2772                           :unspecific
2773                           #-(or :sbcl)
2774                           (let ((dev (component-device component)))
2775                             (if dev
2776                                 (pathname-device dev
2777                                                  #+scl :case #+scl :common
2778                                                  )
2779                                 (pathname-device pathname
2780                                                  #+scl :case #+scl :common
2781                                                  )))
2782                           ;; :version :newest
2783                           ))))))
2784
2785;;; What about CMU17 :device :unspecific in the above?
2786
2787(defun translate-version (version)
2788  ;; Value returns the version directory and whether it replaces
2789  ;; the entire root (t) or is a subdirectory.
2790  ;; Version may be nil to signify no subdirectory,
2791  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
2792  ;; specifies a subdirectory of the root, or
2793  ;; a string, which replaces the root.
2794  (cond ((null version)
2795         (values "" nil))
2796        ((symbolp version)
2797         (values (let ((sversion (string version)))
2798                   (if (find-if #'lower-case-p sversion)
2799                       sversion
2800                       (string-downcase sversion)))
2801                 nil))
2802        ((stringp version)
2803         (values version t))
2804        (t (error "~&; Illegal version ~S" version))))
2805
2806(defun component-extension (component type &key local)
2807  (ecase type
2808    (:source (or (component-source-extension component)
2809                 (unless local
2810                   (default-source-extension component)))) ; system default
2811    (:binary (or (component-binary-extension component)
2812                 (unless local
2813                   (default-binary-extension component)))) ; system default
2814    (:error  *compile-error-file-type*)))
2815(defsetf component-extension (component type) (value)
2816  `(ecase ,type
2817     (:source (setf (component-source-extension ,component) ,value))
2818     (:binary (setf (component-binary-extension ,component) ,value))
2819     (:error  (setf *compile-error-file-type* ,value))))
2820
2821;;; ********************************
2822;;; System Definition **************
2823;;; ********************************
2824(defun create-component (type name definition-body &optional parent (indent 0))
2825  (let ((component (apply #'make-component
2826                          :type type
2827                          :name name
2828                          :indent indent definition-body)))
2829    ;; Set up :load-only attribute
2830    (unless (find :load-only definition-body)
2831      ;; If the :load-only attribute wasn't specified,
2832      ;; inherit it from the parent. If no parent, default it to nil.
2833      (setf (component-load-only component)
2834            (when parent
2835              (component-load-only parent))))
2836    ;; Set up :compile-only attribute
2837    (unless (find :compile-only definition-body)
2838      ;; If the :compile-only attribute wasn't specified,
2839      ;; inherit it from the parent. If no parent, default it to nil.
2840      (setf (component-compile-only component)
2841            (when parent
2842              (component-compile-only parent))))
2843
2844    ;; Set up :compiler-options attribute
2845    (unless (find :compiler-options definition-body)
2846      ;; If the :compiler-option attribute wasn't specified,
2847      ;; inherit it from the parent.  If no parent, default it to NIL.
2848      (setf (component-compiler-options component)
2849            (when parent
2850              (component-compiler-options parent))))
2851
2852    #|| ISI Extension ||#
2853    ;; Set up :load-always attribute
2854    (unless (find :load-always definition-body)
2855      ;; If the :load-always attribute wasn't specified,
2856      ;; inherit it from the parent. If no parent, default it to nil.
2857      (setf (component-load-always component)
2858            (when parent
2859              (component-load-always parent))))
2860
2861    ;; Initializations/after makes
2862    (canonicalize-component-name component)
2863
2864    ;; Inherit package from parent if not specified.
2865    (setf (component-package component)
2866          (or (component-package component)
2867              (when parent (component-package parent))))
2868
2869    ;; Type specific setup:
2870    (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
2871      (setf (get-system name) component))
2872
2873    ;; Set up the component's pathname
2874    (create-component-pathnames component parent)
2875
2876    ;; If there are any components of the component, expand them too.
2877    (expand-component-components component (+ indent 2))
2878
2879    ;; Make depends-on refer to structs instead of names.
2880    (link-component-depends-on (component-components component))
2881
2882    ;; Design Decision: Topologically sort the dependency graph at
2883    ;; time of definition instead of at time of use. Probably saves a
2884    ;; little bit of time for the user.
2885
2886    ;; Topological Sort the components at this level.
2887    (setf (component-components component)
2888          (topological-sort (component-components component)))
2889
2890    ;; Return the component.
2891    component))
2892
2893
2894;;; defsystem --
2895;;; The main macro.
2896;;;
2897;;; 2002-11-22 Marco Antoniotti
2898;;; Added code to achieve a first cut "pathname less" operation,
2899;;; following the ideas in ASDF.  If the DEFSYSTEM form is loaded from
2900;;; a file, then the location of the file (intended as a directory) is
2901;;; computed from *LOAD-PATHNAME* and stored as the :SOURCE-PATHNAME
2902;;; of the system.
2903
2904(defmacro defsystem (name &rest definition-body)
2905  (unless (find :source-pathname definition-body)
2906    (setf definition-body
2907          (list* :source-pathname
2908                 '(when *load-pathname*
2909                        (make-pathname :name nil
2910                                       :type nil
2911                                       :defaults *load-pathname*))
2912                 definition-body)))
2913  `(create-component :defsystem ',name ',definition-body nil 0))
2914
2915(defun create-component-pathnames (component parent)
2916  ;; Set up language-specific defaults
2917  (setf (component-language component)
2918        (or (component-language component) ; for local defaulting
2919            (when parent                ; parent's default
2920              (component-language parent))))
2921  (setf (component-compiler component)
2922        (or (component-compiler component) ; for local defaulting
2923            (when parent                ; parent's default
2924              (component-compiler parent))))
2925  (setf (component-loader component)
2926        (or (component-loader component) ; for local defaulting
2927            (when parent                ; parent's default
2928              (component-loader parent))))
2929
2930  ;; Evaluate the root dir arg
2931  (setf (component-root-dir component :source)
2932        (eval (component-root-dir component :source)))
2933  (setf (component-root-dir component :binary)
2934        (eval (component-root-dir component :binary)))
2935
2936  ;; Evaluate the pathname arg
2937  (setf (component-pathname component :source)
2938        (eval (component-pathname component :source)))
2939  (setf (component-pathname component :binary)
2940        (eval (component-pathname component :binary)))
2941
2942  ;; Pass along the host and devices
2943  (setf (component-host component)
2944        (or (component-host component)
2945            (when parent (component-host parent))))
2946  (setf (component-device component)
2947        (or (component-device component)
2948            (when parent (component-device parent))))
2949
2950  ;; Set up extension defaults
2951  (setf (component-extension component :source)
2952        (or (component-extension component :source :local t) ; local default
2953            (when parent                ; parent's default
2954              (component-extension parent :source))))
2955  (setf (component-extension component :binary)
2956        (or (component-extension component :binary  :local t) ; local default
2957            (when parent                ; parent's default
2958              (component-extension parent :binary))))
2959
2960  ;; Set up pathname defaults -- expand with parent
2961  ;; We must set up the source pathname before the binary pathname
2962  ;; to allow distribution of binaries among the sources to work.
2963  (generate-component-pathname component parent :source)
2964  (generate-component-pathname component parent :binary))
2965
2966;; maybe file's inheriting of pathnames should be moved elsewhere?
2967(defun generate-component-pathname (component parent pathname-type)
2968  ;; Pieces together a pathname for the component based on its component-type.
2969  ;; Assumes source defined first.
2970  ;; Null binary pathnames inherit from source instead of the component's
2971  ;; name. This allows binaries to be distributed among the source if
2972  ;; binary pathnames are not specified. Or if the root directory is
2973  ;; specified for binaries, but no module directories, it inherits
2974  ;; parallel directory structure.
2975  (case (component-type component)
2976    ((:defsystem :system)               ; Absolute Pathname
2977     ;; Set the root-dir to be the absolute pathname
2978     (setf (component-root-dir component pathname-type)
2979           (or (component-pathname component pathname-type)
2980               (when (eq pathname-type :binary)
2981                 ;; When the binary root is nil, use source.
2982                 (component-root-dir component :source))) )
2983     ;; Set the relative pathname to be nil
2984     (setf (component-pathname component pathname-type)
2985           nil));; should this be "" instead?
2986    ;; If the name of the component-pathname is nil, it
2987    ;; defaults to the name of the component. Use "" to
2988    ;; avoid this defaulting.
2989    (:private-file                      ; Absolute Pathname
2990     ;; Root-dir is the directory part of the pathname
2991     (setf (component-root-dir component pathname-type)
2992           ""
2993           #+ignore(or (when (component-pathname component pathname-type)
2994                         (pathname-directory
2995                          (component-pathname component pathname-type)))
2996                       (when (eq pathname-type :binary)
2997                         ;; When the binary root is nil, use source.
2998                         (component-root-dir component :source)))
2999           )
3000     ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
3001     ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
3002     ;; wind up being "", which is wrong for :file components. So replace
3003     ;; them with NIL.
3004     (when (null-string (component-pathname component pathname-type))
3005       (setf (component-pathname component pathname-type) nil))
3006     ;; The relative pathname is the name part
3007     (setf (component-pathname component pathname-type)
3008           (or (when (and (eq pathname-type :binary)
3009                          (null (component-pathname component :binary)))
3010                 ;; When the binary-pathname is nil use source.
3011                 (component-pathname component :source))
3012               (or (when (component-pathname component pathname-type)
3013;                    (pathname-name )
3014                     (component-pathname component pathname-type))
3015                   (component-name component)))))
3016    ((:module :subsystem)                       ; Pathname relative to parent.
3017     ;; Inherit root-dir from parent
3018     (setf (component-root-dir component pathname-type)
3019           (component-root-dir parent pathname-type))
3020     ;; Tack the relative-dir onto the pathname
3021     (setf (component-pathname component pathname-type)
3022           (or (when (and (eq pathname-type :binary)
3023                          (null (component-pathname component :binary)))
3024                 ;; When the binary-pathname is nil use source.
3025                 (component-pathname component :source))
3026               (append-directories
3027                (component-pathname parent pathname-type)
3028                (or (component-pathname component pathname-type)
3029                    (component-name component))))))
3030    (:file                              ; Pathname relative to parent.
3031     ;; Inherit root-dir from parent
3032     (setf (component-root-dir component pathname-type)
3033           (component-root-dir parent pathname-type))
3034     ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
3035     ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
3036     ;; wind up being "", which is wrong for :file components. So replace
3037     ;; them with NIL.
3038     (when (null-string (component-pathname component pathname-type))
3039       (setf (component-pathname component pathname-type) nil))
3040     ;; Tack the relative-dir onto the pathname
3041     (setf (component-pathname component pathname-type)
3042           (or (append-directories
3043                (component-pathname parent pathname-type)
3044                (or (component-pathname component pathname-type)
3045                    (component-name component)
3046                    (when (eq pathname-type :binary)
3047                      ;; When the binary-pathname is nil use source.
3048                      (component-pathname component :source)))))))
3049    ))
3050
3051#|| ;; old version
3052(defun expand-component-components (component &optional (indent 0))
3053  (let ((definitions (component-components component)))
3054    (setf (component-components component)
3055          (remove-if #'null
3056                     (mapcar #'(lambda (definition)
3057                                 (expand-component-definition definition
3058                                                              component
3059                                                              indent))
3060                             definitions)))))
3061||#
3062;; new version
3063(defun expand-component-components (component &optional (indent 0))
3064  (let ((definitions (component-components component)))
3065    (if (eq (car definitions) :serial)
3066        (setf (component-components component)
3067              (expand-serial-component-chain (cdr definitions)
3068                                             component indent))
3069        (setf (component-components component)
3070              (expand-component-definitions definitions component indent)))))
3071
3072(defun expand-component-definitions (definitions parent &optional (indent 0))
3073  (let ((components nil))
3074    (dolist (definition definitions)
3075      (let ((new (expand-component-definition definition parent indent)))
3076        (when new (push new components))))
3077    (nreverse components)))
3078
3079(defun expand-serial-component-chain (definitions parent &optional (indent 0))
3080  (let ((previous nil)
3081        (components nil))
3082    (dolist (definition definitions)
3083      (let ((new (expand-component-definition definition parent indent)))
3084        (when new
3085          ;; Make this component depend on the previous one. Since
3086          ;; we don't know the form of the definition, we have to
3087          ;; expand it first.
3088          (when previous (pushnew previous (component-depends-on new)))
3089          ;; The dependencies will be linked later, so we use the name
3090          ;; instead of the actual component.
3091          (setq previous (component-name new))
3092          ;; Save the new component.
3093          (push new components))))
3094    ;; Return the list of expanded components, in appropriate order.
3095    (nreverse components)))
3096
3097
3098(defparameter *enable-straz-absolute-string-hack* nil
3099  "Special hack requested by Steve Strassman, where the shorthand
3100   that specifies a list of components as a list of strings also
3101   recognizes absolute pathnames and treats them as files of type
3102   :private-file instead of type :file. Defaults to NIL, because I
3103   haven't tested this.")
3104(defun absolute-file-namestring-p (string)
3105  ;; If a FILE namestring starts with a slash, or is a logical pathname
3106  ;; as implied by the existence of a colon in the filename, assume it
3107  ;; represents an absolute pathname.
3108  (or (find #\: string :test #'char=)
3109      (and (not (null-string string))
3110           (char= (char string 0) #\/))))
3111
3112(defun expand-component-definition (definition parent &optional (indent 0))
3113  ;; Should do some checking for malformed definitions here.
3114  (cond ((null definition) nil)
3115        ((stringp definition)
3116         ;; Strings are assumed to be of type :file
3117         (if (and *enable-straz-absolute-string-hack*
3118                  (absolute-file-namestring-p definition))
3119             ;; Special hack for Straz
3120             (create-component :private-file definition nil parent indent)
3121           ;; Normal behavior
3122           (create-component :file definition nil parent indent)))
3123        ((and (listp definition)
3124              (not (member (car definition)
3125                           '(:defsystem :system :subsystem
3126                             :module :file :private-file))))
3127         ;; Lists whose first element is not a component type
3128         ;; are assumed to be of type :file
3129         (create-component :file
3130                           (car definition)
3131                           (cdr definition)
3132                           parent
3133                           indent))
3134        ((listp definition)
3135         ;; Otherwise, it is (we hope) a normal form definition
3136         (create-component (car definition)   ; type
3137                           (cadr definition)  ; name
3138                           (cddr definition)  ; definition body
3139                           parent             ; parent
3140                           indent)            ; indent
3141         )))
3142
3143(defun link-component-depends-on (components)
3144  (dolist (component components)
3145    (unless (and *system-dependencies-delayed*
3146                 (eq (component-type component) :defsystem))
3147      (setf (component-depends-on component)
3148            (mapcar #'(lambda (dependency)
3149                        (let ((parent (find (string dependency) components
3150                                            :key #'component-name
3151                                            :test #'string-equal)))
3152                          (cond (parent parent)
3153                                ;; make it more intelligent about the following
3154                                (t (warn "Dependency ~S of component ~S not found."
3155                                         dependency component)))))
3156
3157                    (component-depends-on component))))))
3158
3159;;; ********************************
3160;;; Topological Sort the Graph *****
3161;;; ********************************
3162
3163;;; New version of topological sort suggested by rs2. Even though
3164;;; this version avoids the call to sort, in practice it isn't faster. It
3165;;; does, however, eliminate the need to have a TIME slot in the
3166;;; topological-sort-node defstruct.
3167(defun topological-sort (list &aux (sorted-list nil))
3168  (labels ((dfs-visit (znode)
3169              (setf (topsort-color znode) :gray)
3170              (unless (and *system-dependencies-delayed*
3171                           (eq (component-type znode) :system))
3172                (dolist (child (component-depends-on znode))
3173                  (cond ((eq (topsort-color child) :white)
3174                         (dfs-visit child))
3175                        ((eq (topsort-color child) :gray)
3176                         (format t "~&Detected cycle containing ~A" child)))))
3177              (setf (topsort-color znode) :black)
3178              (push znode sorted-list)))
3179    (dolist (znode list)
3180      (setf (topsort-color znode) :white))
3181    (dolist (znode list)
3182      (when (eq (topsort-color znode) :white)
3183        (dfs-visit znode)))
3184    (nreverse sorted-list)))
3185
3186#||
3187;;; Older version of topological sort.
3188(defun topological-sort (list &aux (time 0))
3189  ;; The algorithm works by calling depth-first-search to compute the
3190  ;; blackening times for each vertex, and then sorts the vertices into
3191  ;; reverse order by blackening time.
3192  (labels ((dfs-visit (node)
3193              (setf (topsort-color node) 'gray)
3194              (unless (and *system-dependencies-delayed*
3195                           (eq (component-type node) :defsystem))
3196                (dolist (child (component-depends-on node))
3197                  (cond ((eq (topsort-color child) 'white)
3198                         (dfs-visit child))
3199                        ((eq (topsort-color child) 'gray)
3200                         (format t "~&Detected cycle containing ~A" child)))))
3201                      (setf (topsort-color node) 'black)
3202                      (setf (topsort-time node) time)
3203                      (incf time)))
3204    (dolist (node list)
3205      (setf (topsort-color node) 'white))
3206    (dolist (node list)
3207      (when (eq (topsort-color node) 'white)
3208        (dfs-visit node)))
3209    (sort list #'< :key #'topsort-time)))
3210||#
3211
3212;;; ********************************
3213;;; Output to User *****************
3214;;; ********************************
3215;;; All output to the user is via the tell-user functions.
3216
3217(defun split-string (string &key (item #\space) (test #'char=))
3218  ;; Splits the string into substrings at spaces.
3219  (let ((len (length string))
3220        (index 0) result)
3221    (dotimes (i len
3222                (progn (unless (= index len)
3223                         (push (subseq string index) result))
3224                       (reverse result)))
3225      (when (funcall test (char string i) item)
3226        (unless (= index i);; two spaces in a row
3227          (push (subseq string index i) result))
3228        (setf index (1+ i))))))
3229
3230;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it
3231;; because of an AKCL bug.
3232;; KGK suggests using an 8 instead, but 1 does nicely.
3233(defun prompt-string (component)
3234  (format nil "; ~:[~;TEST:~]~V,1@T "
3235          *oos-test*
3236          (component-indent component)))
3237
3238#||
3239(defun format-justified-string (prompt contents)
3240  (format t (concatenate 'string
3241                         "~%"
3242                         prompt
3243                         "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
3244          (split-string contents))
3245  (finish-output *standard-output*))
3246||#
3247
3248(defun format-justified-string (prompt contents &optional (width 80)
3249                                       (stream *standard-output*))
3250  (let ((prompt-length (+ 2 (length prompt))))
3251    (cond ((< (+ prompt-length (length contents)) width)
3252           (format stream "~%~A- ~A" prompt contents))
3253          (t
3254           (format stream "~%~A-" prompt)
3255           (do* ((cursor prompt-length)
3256                 (contents (split-string contents) (cdr contents))
3257                 (content (car contents) (car contents))
3258                 (content-length (1+ (length content)) (1+ (length content))))
3259               ((null contents))
3260             (cond ((< (+ cursor content-length) width)
3261                    (incf cursor content-length)
3262                    (format stream " ~A" content))
3263                   (t
3264                    (setf cursor (+ prompt-length content-length))
3265                    (format stream "~%~A  ~A" prompt content)))))))
3266  (finish-output stream))
3267
3268(defun tell-user (what component &optional type no-dots force)
3269  (when (or *oos-verbose* force)
3270    (format-justified-string (prompt-string component)
3271     (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]"
3272             ;; To have better messages, wrap the following around the
3273             ;; case statement:
3274             ;;(if (find (component-type component)
3275             ;;    '(:defsystem :system :subsystem :module))
3276             ;;  "Checking"
3277             ;;  (case ...))
3278             ;; This gets around the problem of DEFSYSTEM reporting
3279             ;; that it's loading a module, when it eventually never
3280             ;; loads any of the files of the module.
3281             (case what
3282               ((compile :compile)
3283                (if (component-load-only component)
3284                    ;; If it is :load-only t, we're loading.
3285                    "Loading"
3286                    ;; Otherwise we're compiling.
3287                    "Compiling"))
3288               ((load :load) "Loading")
3289               (otherwise what))
3290             (component-type component)
3291             (or (when type
3292                   (component-full-pathname component type))
3293                 (component-name component))
3294             (and *tell-user-when-done*
3295                  (not no-dots))))))
3296
3297(defun tell-user-done (component &optional force no-dots)
3298  ;; test is no longer really used, but we're leaving it in.
3299  (when (and *tell-user-when-done*
3300             (or *oos-verbose* force))
3301    (format t "~&~A~:[~;...~] Done."
3302            (prompt-string component) (not no-dots))
3303    (finish-output *standard-output*)))
3304
3305(defmacro with-tell-user ((what component &optional type no-dots force) &body body)
3306  `(progn
3307     (tell-user ,what ,component ,type ,no-dots ,force)
3308     ,@body
3309     (tell-user-done ,component ,force ,no-dots)))
3310
3311(defun tell-user-no-files (component &optional force)
3312  (when (or *oos-verbose* force)
3313    (format-justified-string (prompt-string component)
3314      (format nil "Source file ~A ~
3315             ~:[and binary file ~A ~;~]not found, not loading."
3316              (component-full-pathname component :source)
3317              (or *load-source-if-no-binary* *load-source-instead-of-binary*)
3318              (component-full-pathname component :binary)))))
3319
3320(defun tell-user-require-system (name parent)
3321  (when *oos-verbose*
3322    (format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
3323            *oos-test* (component-name parent) name)
3324    (finish-output *standard-output*)))
3325
3326(defun tell-user-generic (string)
3327  (when *oos-verbose*
3328    (format t "~&; ~:[~;TEST:~] - ~A"
3329            *oos-test* string)
3330    (finish-output *standard-output*)))
3331
3332;;; ********************************
3333;;; Y-OR-N-P-WAIT ******************
3334;;; ********************************
3335;;; Y-OR-N-P-WAIT is like Y-OR-N-P, but will timeout after a specified
3336;;; number of seconds. I should really replace this with a call to
3337;;; the Y-OR-N-P-WAIT defined in the query.cl package and include that
3338;;; instead.
3339
3340(defparameter *use-timeouts* t
3341  "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves
3342   like Y-OR-N-P. This is provided for users whose lisps don't handle
3343   read-char-no-hang properly.")
3344
3345(defparameter *clear-input-before-query* t
3346  "If T, y-or-n-p-wait will clear the input before printing the prompt
3347   and asking the user for input.")
3348
3349;;; The higher *sleep-amount* is, the less consing, but the lower the
3350;;; responsiveness.
3351(defparameter *sleep-amount* #-CMU 0.1 #+CMU 1.0
3352    "Amount of time to sleep between checking query-io. In multiprocessing
3353     Lisps, this allows other processes to continue while we busy-wait. If
3354     0, skips call to SLEEP.")
3355
3356(defun internal-real-time-in-seconds ()
3357  (get-universal-time))
3358
3359(defun read-char-wait (&optional (timeout 20) input-stream
3360                                 (eof-error-p t) eof-value
3361                                 &aux peek)
3362  (do ((start (internal-real-time-in-seconds)))
3363      ((or (setq peek (listen input-stream))
3364           (< (+ start timeout) (internal-real-time-in-seconds)))
3365       (when peek
3366         ;; was read-char-no-hang
3367         (read-char input-stream eof-error-p eof-value)))
3368    (unless (zerop *sleep-amount*)
3369      (sleep *sleep-amount*))))
3370
3371;;; Lots of lisps, especially those that run on top of UNIX, do not get
3372;;; their input one character at a time, but a whole line at a time because
3373;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait
3374;;; to not always work as expected.
3375;;;
3376;;; I wish lisp did all its own buffering (turning off UNIX input line
3377;;; buffering by putting the UNIX into CBREAK mode). Of course, this means
3378;;; that we lose input editing, but why can't the lisp implement this?
3379
3380(defun y-or-n-p-wait (&optional (default #\y) (timeout 20)
3381                                format-string &rest args)
3382  "Y-OR-N-P-WAIT prints the message, if any, and reads characters from
3383   *QUERY-IO* until the user enters y, Y or space as an affirmative, or either
3384   n or N as a negative answer, or the timeout occurs. It asks again if
3385   you enter any other characters."
3386  (when *clear-input-before-query* (clear-input *query-io*))
3387  (when format-string
3388    (fresh-line *query-io*)
3389    (apply #'format *query-io* format-string args)
3390    ;; FINISH-OUTPUT needed for CMU and other places which don't handle
3391    ;; output streams nicely. This prevents it from continuing and
3392    ;; reading the query until the prompt has been printed.
3393    (finish-output *query-io*))
3394  (loop
3395   (let* ((read-char (if *use-timeouts*
3396                         (read-char-wait timeout *query-io* nil nil)
3397                         (read-char *query-io*)))
3398          (char (or read-char default)))
3399     ;; We need to ignore #\newline because otherwise the bugs in
3400     ;; clear-input will cause y-or-n-p-wait to print the "Type ..."
3401     ;; message every time... *sigh*
3402     ;; Anyway, we might want to use this to ignore whitespace once
3403     ;; clear-input is fixed.
3404     (unless (find char '(#\tab #\newline #\return))
3405       (when (null read-char)
3406         (format *query-io* "~@[~A~]" default)
3407         (finish-output *query-io*))
3408       (cond ((null char) (return t))
3409             ((find char '(#\y #\Y #\space) :test #'char=) (return t))
3410             ((find char '(#\n #\N) :test #'char=) (return nil))
3411             (t
3412              (when *clear-input-before-query* (clear-input *query-io*))
3413              (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ")
3414              (when format-string
3415                (fresh-line *query-io*)
3416                (apply #'format *query-io* format-string args))
3417              (finish-output *query-io*)))))))
3418
3419#||
3420(y-or-n-p-wait #\y 20 "What? ")
3421(progn (format t "~&hi") (finish-output)
3422       (y-or-n-p-wait #\y 10 "1? ")
3423       (y-or-n-p-wait #\n 10 "2? "))
3424||#
3425;;; ********************************
3426;;; Operate on System **************
3427;;; ********************************
3428;;; Operate-on-system
3429;;; Operation is :compile, 'compile, :load or 'load
3430;;; Force is :all or :new-source or :new-source-and-dependents or a list of
3431;;; specific modules.
3432;;;    :all (or T) forces a recompilation of every file in the system
3433;;;    :new-source-and-dependents compiles only those files whose
3434;;;          sources have changed or who depend on recompiled files.
3435;;;    :new-source compiles only those files whose sources have changed
3436;;;    A list of modules means that only those modules and their
3437;;;    dependents are recompiled.
3438;;; Test is T to print out what it would do without actually doing it.
3439;;;      Note: it automatically sets verbose to T if test is T.
3440;;; Verbose is T to print out what it is doing (compiling, loading of
3441;;;      modules and files) as it does it.
3442;;; Dribble should be the pathname of the dribble file if you want to
3443;;; dribble the compilation.
3444;;; Load-source-instead-of-binary is T to load .lisp instead of binary files.
3445;;; Version may be nil to signify no subdirectory,
3446;;; a symbol, such as alpha, beta, omega, :alpha, mark, which
3447;;; specifies a subdirectory of the root, or
3448;;; a string, which replaces the root.
3449
3450(defun operate-on-system (name operation
3451                               &key
3452                               force
3453                               (version *version*)
3454                               (test *oos-test*) (verbose *oos-verbose*)
3455                               (load-source-instead-of-binary
3456                                *load-source-instead-of-binary*)
3457                               (load-source-if-no-binary
3458                                *load-source-if-no-binary*)
3459                               (bother-user-if-no-binary
3460                                *bother-user-if-no-binary*)
3461                               (compile-during-load *compile-during-load*)
3462                               dribble
3463                               (minimal-load *minimal-load*)
3464                               (override-compilation-unit t)
3465                               )
3466  (declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit))
3467  (unwind-protect
3468      ;; Protect the undribble.
3469      (#+(or :cltl2 :ansi-cl) with-compilation-unit
3470         #+(or :cltl2 :ansi-cl) (:override override-compilation-unit)
3471         #-(or :cltl2 :ansi-cl) progn
3472        (when *reset-full-pathname-table* (clear-full-pathname-tables))
3473        (when dribble (dribble dribble))
3474        (when test (setq verbose t))
3475        (when (null force)              ; defaults
3476          (case operation
3477            ((load :load) (setq force :all))
3478            ((compile :compile) (setq force :new-source-and-dependents))
3479            (t (setq force :all))))
3480        ;; Some CL implementations have a variable called *compile-verbose*
3481        ;; or *compile-file-verbose*.
3482        (multiple-value-bind (*version-dir* *version-replace*)
3483            (translate-version version)
3484          ;; CL implementations may uniformly default this to nil
3485          (let ((*load-verbose* #-common-lisp-controller t
3486                                #+common-lisp-controller nil) ; nil
3487                #-(or MCL CMU CLISP ECL :sbcl lispworks scl)
3488                (*compile-file-verbose* t) ; nil
3489                #+common-lisp-controller
3490                (*compile-print* nil)
3491                #+(and common-lisp-controller cmu)
3492                (ext:*compile-progress* nil)
3493                #+(and common-lisp-controller cmu)
3494                (ext:*require-verbose* nil)
3495                #+(and common-lisp-controller cmu)
3496                (ext:*gc-verbose* nil)
3497
3498                (*compile-verbose* #-common-lisp-controller t
3499                                   #+common-lisp-controller nil) ; nil
3500                (*version* version)
3501                (*oos-verbose* verbose)
3502                (*oos-test* test)
3503                (*load-source-if-no-binary* load-source-if-no-binary)
3504                (*compile-during-load* compile-during-load)
3505                (*bother-user-if-no-binary* bother-user-if-no-binary)
3506                (*load-source-instead-of-binary* load-source-instead-of-binary)
3507                (*minimal-load* minimal-load)
3508                (system (if (and (component-p name)
3509                                 (member (component-type name) '(:system :defsystem :subsystem)))
3510                            name
3511                            (find-system name :load))))
3512            #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
3513            (declare (special *compile-verbose* #-MCL *compile-file-verbose*)
3514                     #-openmcl (ignore *compile-verbose*
3515                                       #-MCL *compile-file-verbose*)
3516                     #-openmcl (optimize (inhibit-warnings 3)))
3517            (unless (component-operation operation)
3518              (error "Operation ~A undefined." operation))
3519            (operate-on-component system operation force))))
3520    (when dribble (dribble))))
3521
3522
3523(defun compile-system (name &key force
3524                            (version *version*)
3525                            (test *oos-test*) (verbose *oos-verbose*)
3526                            (load-source-instead-of-binary
3527                             *load-source-instead-of-binary*)
3528                            (load-source-if-no-binary
3529                             *load-source-if-no-binary*)
3530                            (bother-user-if-no-binary
3531                             *bother-user-if-no-binary*)
3532                            (compile-during-load *compile-during-load*)
3533                            dribble
3534                            (minimal-load *minimal-load*))
3535  ;; For users who are confused by OOS.
3536  (operate-on-system
3537   name :compile
3538   :force force
3539   :version version
3540   :test test
3541   :verbose verbose
3542   :load-source-instead-of-binary load-source-instead-of-binary
3543   :load-source-if-no-binary load-source-if-no-binary
3544   :bother-user-if-no-binary bother-user-if-no-binary
3545   :compile-during-load compile-during-load
3546   :dribble dribble
3547   :minimal-load minimal-load))
3548
3549(defun load-system (name &key force
3550                         (version *version*)
3551                         (test *oos-test*) (verbose *oos-verbose*)
3552                         (load-source-instead-of-binary
3553                          *load-source-instead-of-binary*)
3554                         (load-source-if-no-binary *load-source-if-no-binary*)
3555                         (bother-user-if-no-binary *bother-user-if-no-binary*)
3556                         (compile-during-load *compile-during-load*)
3557                         dribble
3558                         (minimal-load *minimal-load*))
3559  ;; For users who are confused by OOS.
3560  (operate-on-system
3561   name :load
3562   :force force
3563   :version version
3564   :test test
3565   :verbose verbose
3566   :load-source-instead-of-binary load-source-instead-of-binary
3567   :load-source-if-no-binary load-source-if-no-binary
3568   :bother-user-if-no-binary bother-user-if-no-binary
3569   :compile-during-load compile-during-load
3570   :dribble dribble
3571   :minimal-load minimal-load))
3572
3573(defun clean-system (name &key (force :all)
3574                         (version *version*)
3575                         (test *oos-test*) (verbose *oos-verbose*)
3576                         dribble)
3577  "Deletes all the binaries in the system."
3578  ;; For users who are confused by OOS.
3579  (operate-on-system
3580   name :delete-binaries
3581   :force force
3582   :version version
3583   :test test
3584   :verbose verbose
3585   :dribble dribble))
3586
3587(defun edit-system
3588    (name &key force
3589               (version *version*)
3590               (test *oos-test*)
3591               (verbose *oos-verbose*)
3592               dribble)
3593
3594  (operate-on-system
3595   name :edit
3596   :force force
3597   :version version
3598   :test test
3599   :verbose verbose
3600   :dribble dribble))
3601
3602(defun hardcopy-system
3603    (name &key force
3604               (version *version*)
3605               (test *oos-test*)
3606               (verbose *oos-verbose*)
3607               dribble)
3608
3609  (operate-on-system
3610   name :hardcopy
3611   :force force
3612   :version version
3613   :test test
3614   :verbose verbose
3615   :dribble dribble))
3616
3617(defun operate-on-component (component operation force &aux changed)
3618  ;; Returns T if something changed and had to be compiled.
3619  (let ((type (component-type component))
3620        (old-package (package-name *package*)))
3621
3622    (unwind-protect
3623        ;; Protect old-package.
3624        (progn
3625          ;; Use the correct package.
3626          (when (component-package component)
3627            (tell-user-generic (format nil "Using package ~A"
3628                                       (component-package component)))
3629            (unless *oos-test*
3630              (unless (find-package (component-package component))
3631                ;; If the package name is the same as the name of the system,
3632                ;; and the package is not defined, this would lead to an
3633                ;; infinite loop, so bomb out with an error.
3634                (when (string-equal (string (component-package component))
3635                                    (component-name component))
3636                  (format t "~%Component ~A not loaded:~%"
3637                          (component-name component))
3638                  (error  "  Package ~A is not defined"
3639                          (component-package component)))
3640                ;; If package not found, try using REQUIRE to load it.
3641                (new-require (component-package component)))
3642              ;; This was USE-PACKAGE, but should be IN-PACKAGE.
3643              ;; Actually, CLtL2 lisps define in-package as a macro,
3644              ;; so we'll set the package manually.
3645              ;; (in-package (component-package component))
3646              (let ((package (find-package (component-package component))))
3647                (when package
3648                  (setf *package* package)))))
3649          #+mk-original
3650          (when (eq type :defsystem)    ; maybe :system too?
3651            (operate-on-system-dependencies component operation force))
3652          (when (or (eq type :defsystem) (eq type :system))
3653            (operate-on-system-dependencies component operation force))
3654
3655          ;; Do any compiler proclamations
3656          (when (component-proclamations component)
3657            (tell-user-generic (format nil "Doing proclamations for ~A"
3658                                       (component-name component)))
3659            (or *oos-test*
3660                (proclaim (component-proclamations component))))
3661
3662          ;; Do any initial actions
3663          (when (component-initially-do component)
3664            (tell-user-generic (format nil "Doing initializations for ~A"
3665                                       (component-name component)))
3666            (or *oos-test*
3667                (eval (component-initially-do component))))
3668
3669          ;; If operation is :compile and load-only is T, this would change
3670          ;; the operation to load. Only, this would mean that a module would
3671          ;; be considered to have changed if it was :load-only and had to be
3672          ;; loaded, and then dependents would be recompiled -- this doesn't
3673          ;; seem right. So instead, we propagate the :load-only attribute
3674          ;; to the components, and modify compile-file-operation so that
3675          ;; it won't compile the files (and modify tell-user to say "Loading"
3676          ;; instead of "Compiling" for load-only modules).
3677          #||
3678          (when (and (find operation '(:compile compile))
3679                     (component-load-only component))
3680            (setf operation :load))
3681          ||#
3682
3683          ;; Do operation and set changed flag if necessary.
3684          (setq changed
3685                (case type
3686                  ((:file :private-file)
3687                   (funcall (component-operation operation) component force))
3688                  ((:module :system :subsystem :defsystem)
3689                   (operate-on-components component operation force changed))))
3690
3691          ;; Do any final actions
3692          (when (component-finally-do component)
3693            (tell-user-generic (format nil "Doing finalizations for ~A"
3694                                       (component-name component)))
3695            (or *oos-test*
3696                (eval (component-finally-do component))))
3697
3698          ;; add the banner if needed
3699          #+(or cmu scl)
3700          (when (component-banner component)
3701            (unless (stringp (component-banner component))
3702              (error "The banner should be a string, it is: ~S"
3703                     (component-banner component)))
3704            (setf (getf ext:*herald-items*
3705                        (intern (string-upcase  (component-name component))
3706                                (find-package :keyword)))
3707                  (list
3708                     (component-banner component)))))
3709
3710      ;; Reset the package. (Cleanup form of unwind-protect.)
3711      ;;(in-package old-package)
3712      (setf *package* (find-package old-package)))
3713
3714    ;; Provide the loaded system
3715    (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
3716      (tell-user-generic (format nil "Providing system ~A~%"
3717                                 (component-name component)))
3718      (or *oos-test*
3719          (provide (canonicalize-system-name (component-name component))))))
3720
3721  ;; Return non-NIL if something changed in this component and hence had
3722  ;; to be recompiled. This is only used as a boolean.
3723  changed)
3724
3725(defvar *force* nil)
3726(defvar *providing-blocks-load-propagation* t
3727  "If T, if a system dependency exists on *modules*, it is not loaded.")
3728
3729(defun operate-on-system-dependencies (component operation &optional force)
3730  (when *system-dependencies-delayed*
3731    (let ((*force* force))
3732      (dolist (system (component-depends-on component))
3733        ;; For each system that this system depends on, if it is a
3734        ;; defined system (either via defsystem or component type :system),
3735        ;; and propagation is turned on, propagates the operation to the
3736        ;; subsystem. Otherwise runs require (my version) on that system
3737        ;; to load it (needed since we may be depending on a lisp
3738        ;; dependent package).
3739        ;; Explores the system tree in a DFS manner.
3740        (cond ((and *operations-propagate-to-subsystems*
3741                    (not (listp system))
3742                    ;; The subsystem is a defined system.
3743                    (find-system system :load-or-nil))
3744               ;; Call OOS on it. Since *system-dependencies-delayed* is
3745               ;; T, the :depends-on slot is filled with the names of
3746               ;; systems, not defstructs.
3747               ;; Aside from system, operation, force, for everything else
3748               ;; we rely on the globals.
3749               (unless (and *providing-blocks-load-propagation*
3750                            ;; If *providing-blocks-load-propagation* is T,
3751                            ;; the system dependency must not exist in the
3752                            ;; *modules* for it to be loaded. Note that
3753                            ;; the dependencies are implicitly systems.
3754                            (find operation '(load :load))
3755                            ;; (or (eq force :all) (eq force t))
3756                            (find (canonicalize-system-name system)
3757                                  *modules* :test #'string-equal))
3758                 
3759                 (operate-on-system system operation :force force)))
3760
3761              ((listp system)
3762               ;; If the SYSTEM is a list then its contents are as follows.
3763               ;;
3764               ;;    (<name> <definition-pathname> <action> <version>)
3765               ;;
3766               (tell-user-require-system
3767                (cond ((and (null (first system)) (null (second system)))
3768                       (third system))
3769                      (t system))
3770                component)
3771               (or *oos-test* (new-require (first system)
3772                                           nil
3773                                           (eval (second system))
3774                                           (third system)
3775                                           (or (fourth system)
3776                                               *version*))))
3777              (t
3778               (tell-user-require-system system component)
3779               (or *oos-test* (new-require system))))))))
3780
3781;;; Modules can depend only on siblings. If a module should depend
3782;;; on an uncle, then the parent module should depend on that uncle
3783;;; instead. Likewise a module should depend on a sibling, not a niece
3784;;; or nephew. Modules also cannot depend on cousins. Modules cannot
3785;;; depend on parents, since that is circular.
3786
3787(defun module-depends-on-changed (module changed)
3788  (dolist (dependent (component-depends-on module))
3789    (when (member dependent changed)
3790      (return t))))
3791
3792(defun operate-on-components (component operation force changed)
3793  (with-tell-user (operation component)
3794    (if (component-components component)
3795        (dolist (module (component-components component))
3796          (when (operate-on-component module operation
3797                  (cond ((and (module-depends-on-changed module changed)
3798                              #||(some #'(lambda (dependent)
3799                                        (member dependent changed))
3800                                    (component-depends-on module))||#
3801                              (or (non-empty-listp force)
3802                                  (eq force :new-source-and-dependents)))
3803                         ;; The component depends on a changed file
3804                         ;; and force agrees.
3805                         (if (eq force :new-source-and-dependents)
3806                             :new-source-all
3807                           :all))
3808                        ((and (non-empty-listp force)
3809                              (member (component-name module) force
3810                                      :test #'string-equal :key #'string))
3811                         ;; Force is a list of modules
3812                         ;; and the component is one of them.
3813                         :all)
3814                        (t force)))
3815            (push module changed)))
3816        (case operation
3817          ((compile :compile)
3818           (eval (component-compile-form component)))
3819          ((load :load)
3820           (eval (component-load-form component))))))
3821  ;; This is only used as a boolean.
3822  changed)
3823
3824;;; ********************************
3825;;; New Require ********************
3826;;; ********************************
3827
3828;;; This needs cleaning.  Obviously the code is a left over from the
3829;;; time people did not know how to use packages in a proper way or
3830;;; CLs were shaky in their implementation.
3831
3832;;; First of all we need this. (Commented out for the time being)
3833;;; (shadow '(cl:require))
3834
3835
3836(defvar *old-require* nil)
3837
3838;;; All calls to require in this file have been replaced with calls
3839;;; to new-require to avoid compiler warnings and make this less of
3840;;; a tangled mess.
3841
3842(defun new-require (module-name
3843                    &optional
3844                    pathname
3845                    definition-pname
3846                    default-action
3847                    (version *version*))
3848  ;; If the pathname is present, this behaves like the old require.
3849  (unless (and module-name
3850               (find (string module-name)
3851                     *modules* :test #'string=))
3852    (handler-case
3853        (cond (pathname
3854               (funcall *old-require* module-name pathname))
3855              ;; If the system is defined, load it.
3856              ((find-system module-name :load-or-nil definition-pname)
3857               (operate-on-system
3858                module-name :load
3859                :force *force*
3860                :version version
3861                :test *oos-test*
3862                :verbose *oos-verbose*
3863                :load-source-if-no-binary *load-source-if-no-binary*
3864                :bother-user-if-no-binary *bother-user-if-no-binary*
3865                :compile-during-load *compile-during-load*
3866                :load-source-instead-of-binary *load-source-instead-of-binary*
3867                :minimal-load *minimal-load*))
3868              ;; If there's a default action, do it. This could be a progn which
3869              ;; loads a file that does everything.
3870              ((and default-action
3871                    (eval default-action)))
3872              ;; If no system definition file, try regular require.
3873              ;; had last arg  PATHNAME, but this wasn't really necessary.
3874              ((funcall *old-require* module-name))
3875              ;; If no default action, print a warning or error message.
3876              (t
3877               #||
3878               (format t "~&Warning: System ~A doesn't seem to be defined..."
3879                       module-name)
3880               ||#
3881               (error 'missing-system :name module-name)))
3882      (missing-module (mmc) (signal mmc)) ; Resignal.
3883      (error (e)
3884             (declare (ignore e))
3885             ;; Signal a (maybe wrong) MISSING-SYSTEM.
3886             (error 'missing-system :name module-name)))
3887    ))
3888
3889
3890;;; Note that in some lisps, when the compiler sees a REQUIRE form at
3891;;; top level it immediately executes it. This is as if an
3892;;; (eval-when (compile load eval) ...) were wrapped around the REQUIRE
3893;;; form. I don't see any easy way to do this without making REQUIRE
3894;;; a macro.
3895;;;
3896;;; For example, in VAXLisp, if a (require 'streams) form is at the top of
3897;;; a file in the system, compiling the system doesn't wind up loading the
3898;;; streams module. If the (require 'streams) form is included within an
3899;;; (eval-when (compile load eval) ...) then everything is OK.
3900;;;
3901;;; So perhaps we should replace the redefinition of lisp:require
3902;;; with the following macro definition:
3903#||
3904(unless *old-require*
3905  (setf *old-require*
3906        (symbol-function #-(or :lispworks
3907                               :sbcl
3908                               (and :excl :allegro-v4.0)) 'lisp:require
3909                         #+:sbcl 'cl:require
3910                         #+:lispworks 'system:::require
3911                         #+(and :excl :allegro-v4.0) 'cltl1:require))
3912
3913  (let (#+(or :CCL :openmcl) (ccl:*warn-if-redefine-kernel* nil))
3914    ;; Note that lots of lisps barf if we redefine a function from
3915    ;; the LISP package. So what we do is define a macro with an
3916    ;; unused name, and use (setf macro-function) to redefine
3917    ;; lisp:require without compiler warnings. If the lisp doesn't
3918    ;; do the right thing, try just replacing require-as-macro
3919    ;; with lisp:require.
3920    (defmacro require-as-macro (module-name
3921                                &optional pathname definition-pname
3922                                default-action (version '*version*))
3923      `(eval-when (compile load eval)
3924         (new-require ,module-name ,pathname ,definition-pname
3925                      ,default-action ,version)))
3926    (setf (macro-function #-(and :excl :sbcl :allegro-v4.0) 'lisp:require
3927                          #+:sbcl 'cl:require
3928                          #+(and :excl :allegro-v4.0) 'cltl1:require)
3929          (macro-function 'require-as-macro))))
3930||#
3931;;; This will almost certainly fix the problem, but will cause problems
3932;;; if anybody does a funcall on #'require.
3933
3934;;; Redefine old require to call the new require.
3935(eval-when #-(or :lucid) (:load-toplevel :execute)
3936           #+(or :lucid) (load eval)
3937(unless *old-require*
3938  (setf *old-require*
3939        (symbol-function
3940         #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require
3941         #+(and :excl :allegro-v4.0) 'cltl1:require
3942         #+:sbcl 'cl:require
3943         #+:lispworks3.1 'common-lisp::require
3944         #+(and :lispworks (not :lispworks3.1)) 'system::require
3945         #+:openmcl 'cl:require
3946         #+(and :mcl (not :openmcl)) 'ccl:require
3947         ))
3948
3949  (unless *dont-redefine-require*
3950    (let (#+(or :mcl :openmcl (and :CCL (not :lispworks)))
3951          (ccl:*warn-if-redefine-kernel* nil))
3952      #-(or (and allegro-version>= (version>= 4 1)) :lispworks)
3953      (setf (symbol-function
3954             #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require
3955             #+(and :excl :allegro-v4.0) 'cltl1:require
3956             #+:lispworks3.1 'common-lisp::require
3957             #+:sbcl 'cl:require
3958             #+(and :lispworks (not :lispworks3.1)) 'system::require
3959             #+:openmcl 'cl:require
3960             #+(and :mcl (not :openmcl)) 'ccl:require
3961             )
3962            (symbol-function 'new-require))
3963      #+:lispworks
3964      (let ((warn-packs system::*packages-for-warn-on-redefinition*))
3965        (declare (special system::*packages-for-warn-on-redefinition*))
3966        (setq system::*packages-for-warn-on-redefinition* nil)
3967        (setf (symbol-function
3968               #+:lispworks3.1 'common-lisp::require
3969               #-:lispworks3.1 'system::require
3970               )
3971              (symbol-function 'new-require))
3972        (setq system::*packages-for-warn-on-redefinition* warn-packs))
3973      #+(and allegro-version>= (version>= 4 1))
3974      (excl:without-package-locks
3975       (setf (symbol-function 'lisp:require)
3976         (symbol-function 'new-require))))))
3977)
3978
3979;;; ********************************
3980;;; Language-Dependent Characteristics
3981;;; ********************************
3982;;; This section is used for defining language-specific behavior of
3983;;; defsystem. If the user changes a language definition, it should
3984;;; take effect immediately -- they shouldn't have to reload the
3985;;; system definition file for the changes to take effect.
3986
3987(defvar *language-table* (make-hash-table :test #'equal)
3988  "Hash table that maps from languages to language structures.")
3989(defun find-language (name)
3990  (gethash name *language-table*))
3991
3992(defstruct (language (:print-function print-language))
3993  name                  ; The name of the language (a keyword)
3994  compiler              ; The function used to compile files in the language
3995  loader                ; The function used to load files in the language
3996  source-extension      ; Filename extensions for source files
3997  binary-extension      ; Filename extensions for binary files
3998)
3999
4000(defun print-language (language stream depth)
4001  (declare (ignore depth))
4002  (format stream "#<~:@(~A~): ~A ~A>"
4003          (language-name language)
4004          (language-source-extension language)
4005          (language-binary-extension language)))
4006
4007(defun compile-function (component)
4008  (or (component-compiler component)
4009      (let ((language (find-language (or (component-language component)
4010                                         :lisp))))
4011        (when language (language-compiler language)))
4012      #'compile-file))
4013
4014(defun load-function (component)
4015  (or (component-loader component)
4016      (let ((language (find-language (or (component-language component)
4017                                         :lisp))))
4018        (when language (language-loader language)))
4019      #'load))
4020
4021(defun default-source-extension (component)
4022  (let ((language (find-language (or (component-language component)
4023                                     :lisp))))
4024    (or (when language (language-source-extension language))
4025        (car *filename-extensions*))))
4026
4027(defun default-binary-extension (component)
4028  (let ((language (find-language (or (component-language component)
4029                                     :lisp))))
4030    (or (when language (language-binary-extension language))
4031        (cdr *filename-extensions*))))
4032
4033(defmacro define-language (name &key compiler loader
4034                                source-extension binary-extension)
4035  (let ((language (gensym "LANGUAGE")))
4036    `(let ((,language (make-language :name ,name
4037                                     :compiler ,compiler
4038                                     :loader ,loader
4039                                     :source-extension ,source-extension
4040                                     :binary-extension ,binary-extension)))
4041       (setf (gethash ,name *language-table*) ,language)
4042       ,name)))
4043
4044#||
4045;;; Test System for verifying multi-language capabilities.
4046(defsystem foo
4047  :language :lisp
4048  :components ((:module c :language :c :components ("foo" "bar"))
4049               (:module lisp :components ("baz" "barf"))))
4050
4051||#
4052
4053;;; *** Lisp Language Definition
4054(define-language :lisp
4055  :compiler #'compile-file
4056  :loader #'load
4057  :source-extension (car *filename-extensions*)
4058  :binary-extension (cdr *filename-extensions*))
4059
4060;;; *** PseudoScheme Language Definition
4061(defun scheme-compile-file (filename &rest args)
4062  (let ((scheme-package (find-package '#:scheme)))
4063    (apply (symbol-function (find-symbol (symbol-name 'compile-file)
4064                                         scheme-package))
4065           filename
4066           (funcall (symbol-function
4067                     (find-symbol (symbol-name '#:interaction-environment)
4068                                  scheme-package)))
4069           args)))
4070
4071(define-language :scheme
4072  :compiler #'scheme-compile-file
4073  :loader #'load
4074  :source-extension "scm"
4075  :binary-extension "bin")
4076
4077;;; *** C Language Definition
4078
4079;;; This is very basic. Somebody else who needs it can add in support
4080;;; for header files, libraries, different C compilers, etc. For example,
4081;;; we might add a COMPILER-OPTIONS slot to the component defstruct.
4082
4083(defparameter *c-compiler* "gcc")
4084#-(or symbolics (and :lispworks :harlequin-pc-lisp ))
4085
4086(defun run-unix-program (program arguments)
4087  ;; arguments should be a list of strings, where each element is a
4088  ;; command-line option to send to the program.
4089  #+:lucid (run-program program :arguments arguments)
4090  #+:allegro (excl:run-shell-command
4091              (format nil "~A~@[ ~{~A~^ ~}~]"
4092                      program arguments))
4093  #+(or :kcl :ecl) (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
4094  #+(or :cmu :scl) (extensions:run-program program arguments)
4095  #+:openmcl (ccl:run-program program arguments)
4096  #+:sbcl (sb-ext:run-program program arguments)
4097  #+:lispworks (foreign:call-system-showing-output
4098                (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
4099  #+clisp (#+lisp=cl ext:run-program #-lisp=cl lisp:run-program
4100                     program :arguments arguments)
4101  )
4102
4103#+(or symbolics (and :lispworks :harlequin-pc-lisp))
4104(defun run-unix-program (program arguments)
4105  (declare (ignore program arguments))
4106  (error "MK::RUN-UNIX-PROGRAM: this does not seem to be a UN*X system.")
4107  )
4108
4109#||
4110(defun c-compile-file (filename &rest args &key output-file error-file)
4111  ;; gcc -c foo.c -o foo.o
4112  (declare (ignore args))
4113  (run-unix-program *c-compiler*
4114                    (format nil "-c ~A~@[ -o ~A~]"
4115                            filename
4116                            output-file)))
4117||#
4118
4119#||
4120(defun c-compile-file (filename &rest args &key output-file error-file)
4121  ;; gcc -c foo.c -o foo.o
4122  (declare (ignore args error-file))
4123  (run-unix-program *c-compiler*
4124                    `("-c" ,filename ,@(if output-file `("-o" ,output-file)))))
4125||#
4126
4127
4128;;; The following code was inserted to improve C compiler support (at
4129;;; least under Linux/GCC).
4130;;; Thanks to Espen S Johnsen.
4131;;;
4132;;; 20001118 Marco Antoniotti.
4133
4134(defun default-output-pathname (path1 path2 type)
4135  (if (eq path1 t)
4136      (translate-logical-pathname
4137       (merge-pathnames (make-pathname :type type) (pathname path2)))
4138      (translate-logical-pathname (pathname path1))))
4139
4140
4141(defun run-compiler (program
4142                     arguments
4143                     output-file
4144                     error-file
4145                     error-output
4146                     verbose)
4147  #-(or cmu scl) (declare (ignore error-file error-output))
4148
4149  (flet ((make-useable-stream (&rest streams)
4150           (apply #'make-broadcast-stream (delete nil streams)))
4151         )
4152    (let (#+(or cmu scl) (error-file error-file)
4153          #+(or cmu scl) (error-file-stream nil)
4154          (verbose-stream nil)
4155          (old-timestamp (file-write-date output-file))
4156          (fatal-error nil)
4157          (output-file-written nil)
4158          )
4159      (unwind-protect
4160           (progn
4161             #+(or cmu scl)
4162             (setf error-file
4163                   (when error-file
4164                     (default-output-pathname error-file
4165                                              output-file
4166                                              *compile-error-file-type*))
4167
4168                   error-file-stream
4169                   (and error-file
4170                        (open error-file
4171                              :direction :output
4172                              :if-exists :supersede)))
4173
4174             (setf verbose-stream
4175                   (make-useable-stream
4176                    #+cmu error-file-stream
4177                    (and verbose *trace-output*)))
4178
4179             (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
4180                     program
4181                     arguments)
4182
4183             (setf fatal-error
4184                   #-(or cmu scl)
4185                   (and (run-unix-program program arguments) nil) ; Incomplete.
4186                   #+(or cmu scl)
4187                   (let* ((error-output
4188                           (make-useable-stream error-file-stream
4189                                                (if (eq error-output t)
4190                                                    *error-output*
4191                                                  error-output)))
4192                          (process
4193                           (ext:run-program program arguments
4194                                            :error error-output)))
4195                     (not (zerop (ext:process-exit-code process)))))
4196
4197             (setf output-file-written
4198                   (and (probe-file output-file)
4199                        (not (eql old-timestamp
4200                                  (file-write-date output-file)))))
4201
4202
4203             (when output-file-written
4204               (format verbose-stream "~A written~%" output-file))
4205             (format verbose-stream "Running of ~A finished~%"
4206                     program)
4207             (values (and output-file-written output-file)
4208                     fatal-error
4209                     fatal-error))
4210
4211        #+(or cmu scl)
4212        (when error-file
4213          (close error-file-stream)
4214          (unless (or fatal-error (not output-file-written))
4215            (delete-file error-file)))
4216
4217        (values (and output-file-written output-file)
4218                fatal-error
4219                fatal-error)))))
4220
4221
4222(defun c-compile-file (filename &rest args
4223                                &key
4224                                (output-file t)
4225                                (error-file t)
4226                                (error-output t)
4227                                (verbose *compile-verbose*)
4228                                debug
4229                                link
4230                                optimize
4231                                cflags
4232                                definitions
4233                                include-paths
4234                                library-paths
4235                                libraries
4236                                (error t))
4237  (declare (ignore args))
4238
4239  (flet ((map-options (flag options &optional (func #'identity))
4240           (mapcar #'(lambda (option)
4241                       (format nil "~A~A" flag (funcall func option)))
4242                   options))
4243         )
4244    (let* ((output-file (default-output-pathname output-file filename "o"))
4245           (arguments
4246            `(,@(when (not link) '("-c"))
4247              ,@(when debug '("-g"))
4248              ,@(when optimize (list (format nil "-O~D" optimize)))
4249              ,@cflags
4250              ,@(map-options
4251                 "-D" definitions
4252                 #'(lambda (definition)
4253                     (if (atom definition)
4254                         definition
4255                       (apply #'format nil "~A=~A" definition))))
4256              ,@(map-options "-I" include-paths #'truename)
4257              ,(namestring (truename filename))
4258              "-o"
4259              ,(namestring (translate-logical-pathname output-file))
4260              ,@(map-options "-L" library-paths #'truename)
4261              ,@(map-options "-l" libraries))))
4262
4263      (multiple-value-bind (output-file warnings fatal-errors)
4264          (run-compiler *c-compiler*
4265                        arguments
4266                        output-file
4267                        error-file
4268                        error-output
4269                        verbose)
4270        (if (and error (or (not output-file) fatal-errors))
4271            (error "Compilation failed")
4272            (values output-file warnings fatal-errors))))))
4273
4274
4275(define-language :c
4276  :compiler #'c-compile-file
4277  :loader #+:lucid #'load-foreign-files
4278          #+:allegro #'load
4279          #+(or :cmu :scl) #'alien:load-foreign
4280          #+:sbcl #'sb-alien:load-foreign
4281          #+(and :lispworks :unix (not :linux)) #'link-load:read-foreign-modules
4282          #+(and :lispworks (or (not :unix) :linux)) #'fli:register-module
4283          #+(or :ecl :gcl :kcl) #'load ; should be enough.
4284          #-(or :lucid
4285                :allegro
4286                :cmu
4287                :sbcl
4288                :scl
4289                :lispworks
4290                :ecl :gcl :kcl)
4291          (lambda (&rest args)
4292            (declare (ignore args))
4293            (cerror "Continue returning NIL."
4294                    "Loader not defined for C foreign libraries in ~A ~A."
4295                    (lisp-implementation-type)
4296                    (lisp-implementation-version)))
4297  :source-extension "c"
4298  :binary-extension "o")
4299
4300#||
4301;;; FDMM's changes, which we've replaced.
4302(defvar *compile-file-function* #'cl-compile-file)
4303
4304#+(or :clos :pcl)
4305(defmethod set-language ((lang (eql :common-lisp)))
4306  (setq *compile-file-function* #'cl-compile-file))
4307
4308#+(or :clos :pcl)
4309(defmethod set-language ((lang (eql :scheme)))
4310  (setq *compile-file-function #'scheme-compile-file))
4311||#
4312
4313;;; ********************************
4314;;; Component Operations ***********
4315;;; ********************************
4316;;; Define :compile/compile and :load/load operations
4317(eval-when (load eval)
4318(component-operation :compile  'compile-and-load-operation)
4319(component-operation 'compile  'compile-and-load-operation)
4320(component-operation :load     'load-file-operation)
4321(component-operation 'load     'load-file-operation)
4322)
4323
4324(defun compile-and-load-operation (component force)
4325  ;; FORCE was CHANGED. this caused defsystem during compilation to only
4326  ;; load files that it immediately compiled.
4327  (let ((changed (compile-file-operation component force)))
4328    ;; Return T if the file had to be recompiled and reloaded.
4329    (if (and changed (component-compile-only component))
4330        ;; For files which are :compile-only T, compiling the file
4331        ;; satisfies the need to load.
4332        changed
4333        ;; If the file wasn't compiled, or :compile-only is nil,
4334        ;; check to see if it needs to be loaded.
4335        (and (load-file-operation component force) ; FORCE was CHANGED ???
4336             changed))))
4337
4338(defun unmunge-lucid (namestring)
4339  ;; Lucid's implementation of COMPILE-FILE is non-standard, in that
4340  ;; when the :output-file is a relative pathname, it tries to munge
4341  ;; it with the directory of the source file. For example,
4342  ;; (compile-file "src/globals.lisp" :output-file "bin/globals.sbin")
4343  ;; tries to stick the file in "./src/bin/globals.sbin" instead of
4344  ;; "./bin/globals.sbin" like any normal lisp. This hack seems to fix the
4345  ;; problem. I wouldn't have expected this problem to occur with any
4346  ;; use of defsystem, but some defsystem users are depending on
4347  ;; using relative pathnames (at least three folks reported the problem).
4348  (cond ((null-string namestring) namestring)
4349        ((char= (char namestring 0) #\/)
4350         ;; It's an absolute namestring
4351         namestring)
4352        (t
4353         ;; Ugly, but seems to fix the problem.
4354         (concatenate 'string "./" namestring))))
4355
4356(defun compile-file-operation (component force)
4357  ;; Returns T if the file had to be compiled.
4358  (let ((must-compile
4359         ;; For files which are :load-only T, loading the file
4360         ;; satisfies the demand to recompile.
4361         (and (null (component-load-only component)) ; not load-only
4362              (or (find force '(:all :new-source-all t) :test #'eq)
4363                  (and (find force '(:new-source :new-source-and-dependents)
4364                             :test #'eq)
4365                       (needs-compilation component)))))
4366        (source-pname (component-full-pathname component :source)))
4367
4368    (cond ((and must-compile (probe-file source-pname))
4369           (with-tell-user ("Compiling source" component :source)
4370             (let ((output-file
4371                    #+:lucid
4372                     (unmunge-lucid (component-full-pathname component
4373                                                             :binary))
4374                     #-:lucid
4375                     (component-full-pathname component :binary)))
4376
4377               ;; make certain the directory we need to write to
4378               ;; exists [pvaneynd@debian.org 20001114]
4379               ;; Added PATHNAME-HOST following suggestion by John
4380               ;; DeSoi [marcoxa@sourceforge.net 20020529]
4381
4382               (ensure-directories-exist
4383                (make-pathname
4384                 :host (pathname-host output-file)
4385                 :directory (pathname-directory output-file)))
4386
4387               (or *oos-test*
4388                   (apply (compile-function component)
4389                          source-pname
4390                          :output-file
4391                          output-file
4392                          #+(or :cmu :scl) :error-file
4393                          #+(or :cmu :scl) (and *cmu-errors-to-file*
4394                                                (component-full-pathname component
4395                                                                         :error))
4396                          #+CMU
4397                          :error-output
4398                          #+CMU
4399                          *cmu-errors-to-terminal*
4400                          (component-compiler-options component)
4401                          ))))
4402           must-compile)
4403          (must-compile
4404           (tell-user "Source file not found. Not compiling"
4405                      component :source :no-dots :force)
4406           nil)
4407          (t nil))))
4408
4409(defun needs-compilation (component)
4410  ;; If there is no binary, or it is older than the source
4411  ;; file, then the component needs to be compiled.
4412  ;; Otherwise we only need to recompile if it depends on a file that changed.
4413  (let ((source-pname (component-full-pathname component :source))
4414        (binary-pname (component-full-pathname component :binary)))
4415    (and
4416     ;; source must exist
4417     (probe-file source-pname)
4418     (or
4419      ;; no binary
4420      (null (probe-file binary-pname))
4421      ;; old binary
4422      (< (file-write-date binary-pname)
4423         (file-write-date source-pname))))))
4424
4425(defun needs-loading (component &optional (check-source t) (check-binary t))
4426  ;; Compares the component's load-time against the file-write-date of
4427  ;; the files on disk.
4428  (let ((load-time (component-load-time component))
4429        (source-pname (component-full-pathname component :source))
4430        (binary-pname (component-full-pathname component :binary)))
4431    (or
4432     #|| ISI Extension ||#
4433     (component-load-always component)
4434
4435     ;; File never loaded.
4436     (null load-time)
4437     ;; Binary is newer.
4438     (when (and check-binary
4439                (probe-file binary-pname))
4440       (< load-time
4441          (file-write-date binary-pname)))
4442     ;; Source is newer.
4443     (when (and check-source
4444                (probe-file source-pname))
4445       (< load-time
4446          (file-write-date source-pname))))))
4447
4448;;; Need to completely rework this function...
4449(defun load-file-operation (component force)
4450  ;; Returns T if the file had to be loaded
4451  (let* ((binary-pname (component-full-pathname component :binary))
4452         (source-pname (component-full-pathname component :source))
4453         (binary-exists (probe-file binary-pname))
4454         (source-exists (probe-file source-pname))
4455         (source-needs-loading (needs-loading component t nil))
4456         (binary-needs-loading (needs-loading component nil t))
4457         ;; needs-compilation has an implicit source-exists in it.
4458         (needs-compilation (if (component-load-only component)
4459                                source-needs-loading
4460                                (needs-compilation component)))
4461         (check-for-new-source
4462          ;; If force is :new-source*, we're checking for files
4463          ;; whose source is newer than the compiled versions.
4464          (find force '(:new-source :new-source-and-dependents :new-source-all)
4465                :test #'eq))
4466         (load-binary (or (find force '(:all :new-source-all t) :test #'eq)
4467                          binary-needs-loading))
4468         (load-source
4469          (or *load-source-instead-of-binary*
4470              (and load-binary (component-load-only component))
4471              (and check-for-new-source needs-compilation)))
4472         (compile-and-load
4473          (and needs-compilation (or load-binary check-for-new-source)
4474               (compile-and-load-source-if-no-binary component))))
4475    ;; When we're trying to minimize the files loaded to only those
4476    ;; that need be, restrict the values of load-source and load-binary
4477    ;; so that we only load the component if the files are newer than
4478    ;; the load-time.
4479    (when *minimal-load*
4480      (when load-source (setf load-source source-needs-loading))
4481      (when load-binary (setf load-binary binary-needs-loading)))
4482
4483    (when (or load-source load-binary compile-and-load)
4484      (cond (compile-and-load
4485             ;; If we're loading the binary and it is old or nonexistent,
4486             ;; and the user says yes, compile and load the source.
4487             (compile-file-operation component t)
4488             (with-tell-user ("Loading binary"   component :binary)
4489               (or *oos-test*
4490                   (progn
4491                     (funcall (load-function component) binary-pname)
4492                     (setf (component-load-time component)
4493                           (file-write-date binary-pname)))))
4494             t)
4495            ((and source-exists
4496                  (or (and load-source  ; implicit needs-comp...
4497                           (or *load-source-instead-of-binary*
4498                               (component-load-only component)
4499                               (not *compile-during-load*)))
4500                      (and load-binary (not binary-exists)
4501                           (load-source-if-no-binary component))))
4502             ;; Load the source if the source exists and:
4503             ;;   o  we're loading binary and it doesn't exist
4504             ;;   o  we're forcing it
4505             ;;   o  we're loading new source and user wasn't asked to compile
4506             (with-tell-user ("Loading source" component :source)
4507               (or *oos-test*
4508                   (progn
4509                     (funcall (load-function component) source-pname)
4510                     (setf (component-load-time component)
4511                           (file-write-date source-pname)))))
4512             t)
4513            ((and binary-exists load-binary)
4514             (with-tell-user ("Loading binary"   component :binary)
4515               (or *oos-test*
4516                   (progn
4517                     (funcall (load-function component) binary-pname)
4518                     (setf (component-load-time component)
4519                           (file-write-date binary-pname)))))
4520             t)
4521            ((and (not binary-exists) (not source-exists))
4522             (tell-user-no-files component :force)
4523             (when *files-missing-is-an-error*
4524               (cerror "Continue, ignoring missing files."
4525                       "~&Source file ~S ~:[and binary file ~S ~;~]do not exist."
4526                       source-pname
4527                       (or *load-source-if-no-binary*
4528                           *load-source-instead-of-binary*)
4529                       binary-pname))
4530             nil)
4531            (t
4532             nil)))))
4533
4534(eval-when (load eval)
4535(component-operation :clean    'delete-binaries-operation)
4536(component-operation 'clean    'delete-binaries-operation)
4537(component-operation :delete-binaries     'delete-binaries-operation)
4538(component-operation 'delete-binaries     'delete-binaries-operation)
4539)
4540(defun delete-binaries-operation (component force)
4541  (when (or (eq force :all)
4542            (eq force t)
4543            (and (find force '(:new-source :new-source-and-dependents
4544                                           :new-source-all)
4545                       :test #'eq)
4546                 (needs-compilation component)))
4547    (let ((binary-pname (component-full-pathname component :binary)))
4548      (when (probe-file binary-pname)
4549        (with-tell-user ("Deleting binary"   component :binary)
4550                        (or *oos-test*
4551                            (delete-file binary-pname)))))))
4552
4553
4554;; when the operation = :compile, we can assume the binary exists in test mode.
4555;;      ((and *oos-test*
4556;;            (eq operation :compile)
4557;;            (probe-file (component-full-pathname component :source)))
4558;;       (with-tell-user ("Loading binary"   component :binary)))
4559
4560(defun binary-exists (component)
4561  (probe-file (component-full-pathname component :binary)))
4562
4563;;; or old-binary
4564(defun compile-and-load-source-if-no-binary (component)
4565  (when (not (or *load-source-instead-of-binary*
4566                 (and *load-source-if-no-binary*
4567                      (not (binary-exists component)))))
4568    (cond ((component-load-only component)
4569           #||
4570           (let ((prompt (prompt-string component)))
4571             (format t "~A- File ~A is load-only, ~
4572                        ~&~A  not compiling."
4573                     prompt
4574                     (component-full-pathname component :source)
4575                     prompt))
4576           ||#
4577           nil)
4578          ((eq *compile-during-load* :query)
4579           (let* ((prompt (prompt-string component))
4580                  (compile-source
4581                   (y-or-n-p-wait
4582                    #\y 30
4583                    "~A- Binary file ~A is old or does not exist. ~
4584                     ~&~A  Compile (and load) source file ~A instead? "
4585                    prompt
4586                    (component-full-pathname component :binary)
4587                    prompt
4588                    (component-full-pathname component :source))))
4589             (unless (y-or-n-p-wait
4590                      #\y 30
4591                      "~A- Should I bother you if this happens again? "
4592                      prompt)
4593               (setq *compile-during-load*
4594                     (y-or-n-p-wait
4595                      #\y 30
4596                      "~A- Should I compile and load or not? "
4597                      prompt)))         ; was compile-source, then t
4598             compile-source))
4599          (*compile-during-load*)
4600          (t nil))))
4601
4602(defun load-source-if-no-binary (component)
4603  (and (not *load-source-instead-of-binary*)
4604       (or (and *load-source-if-no-binary*
4605                (not (binary-exists component)))
4606           (component-load-only component)
4607           (when *bother-user-if-no-binary*
4608             (let* ((prompt (prompt-string component))
4609                    (load-source
4610                     (y-or-n-p-wait #\y 30
4611                      "~A- Binary file ~A does not exist. ~
4612                       ~&~A  Load source file ~A instead? "
4613                      prompt
4614                      (component-full-pathname component :binary)
4615                      prompt
4616                      (component-full-pathname component :source))))
4617               (setq *bother-user-if-no-binary*
4618                     (y-or-n-p-wait #\n 30
4619                      "~A- Should I bother you if this happens again? "
4620                      prompt ))
4621               (unless *bother-user-if-no-binary*
4622                 (setq *load-source-if-no-binary* load-source))
4623               load-source)))))
4624
4625;;; ********************************
4626;;; Allegro Toplevel Commands ******
4627;;; ********************************
4628;;; Creates toplevel command aliases for Allegro CL.
4629#+:allegro
4630(top-level:alias ("compile-system" 8)
4631  (system &key force (minimal-load mk:*minimal-load*)
4632          test verbose version)
4633  "Compile the specified system"
4634
4635  (mk:compile-system system :force force
4636                     :minimal-load minimal-load
4637                     :test test :verbose verbose
4638                     :version version))
4639
4640#+:allegro
4641(top-level:alias ("load-system" 5)
4642  (system &key force (minimal-load mk:*minimal-load*)
4643          (compile-during-load mk:*compile-during-load*)
4644          test verbose version)
4645  "Compile the specified system"
4646
4647  (mk:load-system system :force force
4648                  :minimal-load minimal-load
4649                  :compile-during-load compile-during-load
4650                  :test test :verbose verbose
4651                  :version version))
4652
4653#+:allegro
4654(top-level:alias ("show-system" 5) (system)
4655  "Show information about the specified system."
4656
4657  (mk:describe-system system))
4658
4659#+:allegro
4660(top-level:alias ("describe-system" 9) (system)
4661  "Show information about the specified system."
4662
4663  (mk:describe-system system))
4664
4665#+:allegro
4666(top-level:alias ("system-source-size" 9) (system)
4667  "Show size information about source files in the specified system."
4668
4669  (mk:system-source-size system))
4670
4671#+:allegro
4672(top-level:alias ("clean-system" 6)
4673  (system &key force test verbose version)
4674  "Delete binaries in the specified system."
4675
4676  (mk:clean-system system :force force
4677                   :test test :verbose verbose
4678                   :version version))
4679
4680#+:allegro
4681(top-level:alias ("edit-system" 7)
4682  (system &key force test verbose version)
4683  "Load system source files into Emacs."
4684
4685  (mk:edit-system system :force force
4686                  :test test :verbose verbose
4687                  :version version))
4688
4689#+:allegro
4690(top-level:alias ("hardcopy-system" 9)
4691  (system &key force test verbose version)
4692  "Hardcopy files in the specified system."
4693
4694  (mk:hardcopy-system system :force force
4695                      :test test :verbose verbose
4696                      :version version))
4697
4698#+:allegro
4699(top-level:alias ("make-system-tag-table" 13) (system)
4700  "Make an Emacs TAGS file for source files in specified system."
4701
4702  (mk:make-system-tag-table system))
4703
4704
4705;;; ********************************
4706;;; Allegro Make System Fasl *******
4707;;; ********************************
4708#+:excl
4709(defun allegro-make-system-fasl (system destination
4710                                        &optional (include-dependents t))
4711  (excl:shell
4712   (format nil "rm -f ~A; cat~{ ~A~} > ~A"
4713           destination
4714           (if include-dependents
4715               (files-in-system-and-dependents system :all :binary)
4716               (files-in-system system :all :binary))
4717           destination)))
4718
4719(defun files-which-need-compilation (system)
4720  (mapcar #'(lambda (comp) (component-full-pathname comp :source))
4721          (remove nil
4722                  (file-components-in-component
4723                   (find-system system :load) :new-source))))
4724
4725(defun files-in-system-and-dependents (name &optional (force :all)
4726                                            (type :source) version)
4727  ;; Returns a list of the pathnames in system and dependents in load order.
4728  (let ((system (find-system name :load)))
4729    (multiple-value-bind (*version-dir* *version-replace*)
4730        (translate-version version)
4731      (let ((*version* version))
4732        (let ((result (file-pathnames-in-component system type force)))
4733          (dolist (dependent (reverse (component-depends-on system)))
4734            (setq result
4735                  (append (files-in-system-and-dependents dependent
4736                                                          force type version)
4737                          result)))
4738          result)))))
4739
4740(defun files-in-system (name &optional (force :all) (type :source) version)
4741  ;; Returns a list of the pathnames in system in load order.
4742  (let ((system (if (and (component-p name)
4743                         (member (component-type name) '(:defsystem :system :subsystem)))
4744                    name
4745                    (find-system name :load))))
4746    (multiple-value-bind (*version-dir* *version-replace*)
4747        (translate-version version)
4748      (let ((*version* version))
4749        (file-pathnames-in-component system type force)))))
4750
4751(defun file-pathnames-in-component (component type &optional (force :all))
4752  (mapcar #'(lambda (comp) (component-full-pathname comp type))
4753          (file-components-in-component component force)))
4754
4755(defun file-components-in-component (component &optional (force :all)
4756                                               &aux result changed)
4757  (case (component-type component)
4758    ((:file :private-file)
4759     (when (setq changed
4760                 (or (find force '(:all t) :test #'eq)
4761                     (and (not (non-empty-listp force))
4762                          (needs-compilation component))))
4763       (setq result
4764             (list component))))
4765    ((:module :system :subsystem :defsystem)
4766     (dolist (module (component-components component))
4767       (multiple-value-bind (r c)
4768           (file-components-in-component
4769            module
4770            (cond ((and (some #'(lambda (dependent)
4771                                  (member dependent changed))
4772                              (component-depends-on module))
4773                        (or (non-empty-listp force)
4774                            (eq force :new-source-and-dependents)))
4775                   ;; The component depends on a changed file and force agrees.
4776                   :all)
4777                  ((and (non-empty-listp force)
4778                        (member (component-name module) force
4779                                :test #'string-equal :key #'string))
4780                   ;; Force is a list of modules and the component is
4781                   ;; one of them.
4782                   :all)
4783                  (t force)))
4784         (when c
4785           (push module changed)
4786           (setq result (append result r)))))))
4787  (values result changed))
4788
4789(setf (symbol-function 'oos) (symbol-function 'operate-on-system))
4790
4791;;; ********************************
4792;;; Additional Component Operations
4793;;; ********************************
4794
4795;;; *** Edit Operation ***
4796
4797;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))?
4798#|
4799#+:ccl
4800(defun edit-operation (component force)
4801  "Always returns nil, i.e. component not changed."
4802  (declare (ignore force))
4803  ;;
4804  (let* ((full-pathname (make::component-full-pathname component :source))
4805         (already-editing\? #+:mcl (dolist (w (CCL:windows :class
4806                                                           'fred-window))
4807                                    (when (equal (CCL:window-filename w)
4808                                                 full-pathname)
4809                                      (return w)))
4810                           #-:mcl nil))
4811    (if already-editing\?
4812      #+:mcl (CCL:window-select already-editing\?) #-:mcl nil
4813      (ed full-pathname)))
4814  nil)
4815
4816#+:allegro
4817(defun edit-operation (component force)
4818  "Edit a component - always returns nil, i.e. component not changed."
4819  (declare (ignore force))
4820  (let ((full-pathname (component-full-pathname component :source)))
4821    (ed full-pathname))
4822  nil)
4823
4824#+(or :ccl :allegro)
4825(make::component-operation :edit 'edit-operation)
4826#+(or :ccl :allegro)
4827(make::component-operation 'edit 'edit-operation)
4828|#
4829
4830;;; *** Hardcopy System ***
4831(defparameter *print-command* "enscript -2Gr" ; "lpr"
4832  "Command to use for printing files on UNIX systems.")
4833#+:allegro
4834(defun hardcopy-operation (component force)
4835  "Hardcopy a component - always returns nil, i.e. component not changed."
4836  (declare (ignore force))
4837  (let ((full-pathname (component-full-pathname component :source)))
4838    (excl:run-shell-command (format nil "~A ~A"
4839                                    *print-command* full-pathname)))
4840  nil)
4841
4842#+:allegro
4843(make::component-operation :hardcopy 'hardcopy-operation)
4844#+:allegro
4845(make::component-operation 'hardcopy 'hardcopy-operation)
4846
4847
4848;;; *** System Source Size ***
4849
4850(defun system-source-size (system-name &optional (force :all))
4851  "Prints a short report and returns the size in bytes of the source files in
4852   <system-name>."
4853  (let* ((file-list (files-in-system system-name force :source))
4854         (total-size (file-list-size file-list)))
4855    (format t "~&~a/~a (~:d file~:p) totals ~:d byte~:p (~:d kB)"
4856            system-name force (length file-list)
4857            total-size (round total-size 1024))
4858    total-size))
4859
4860(defun file-list-size (file-list)
4861  "Returns the size in bytes of the files in <file-list>."
4862  ;;
4863  (let ((total-size 0))
4864    (dolist (file file-list)
4865      (with-open-file (stream file)
4866        (incf total-size (file-length stream))))
4867    total-size))
4868
4869;;; *** System Tag Table ***
4870
4871#+:allegro
4872(defun make-system-tag-table (system-name)
4873  "Makes an Emacs tag table using the GNU etags program."
4874  (let ((files-in-system (files-in-system system-name :all :source)))
4875
4876    (format t "~&Making tag table...")
4877    (excl:run-shell-command (format nil "etags ~{~a ~}" files-in-system))
4878    (format t "done.~%")))
4879
4880
4881;;; end of file -- defsystem.lisp --
Note: See TracBrowser for help on using the repository browser.