Fix ticket:62: Needed an IN-PACKAGE.
[projects/cmucl/cmucl.git] / src / contrib / defsystem / defsystem.lisp
1 ;;; -*- Mode: Lisp; Package: make -*-
2 ;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-
3
4 ;;; DEFSYSTEM 3.6 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.6 Interim
32 ;;;
33 ;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
34 ;;;               1999 - 2005 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 \f
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 \f
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 \f
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 \f
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 :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       :lispworks
868       :clisp
869       :gcl
870       :sbcl
871       :cormanlisp
872       :scl
873       (and allegro-version>= (version>= 4 1)))
874 (eval-when #-(or :lucid)
875            (:compile-toplevel :load-toplevel :execute)
876            #+(or :lucid)
877            (compile load eval)
878
879   (unless (or (fboundp 'lisp::require)
880               (fboundp 'user::require)
881
882               #+(and :excl (and allegro-version>= (version>= 4 0)))
883               (fboundp 'cltl1::require)
884
885               #+:lispworks
886               (fboundp 'system::require))
887
888     #-:lispworks
889     (in-package "LISP")
890     #+:lispworks
891     (in-package "SYSTEM")
892
893     (export '(*modules* provide require))
894
895     ;; Documentation strings taken almost literally from CLtL1.
896
897     (defvar *modules* ()
898       "List of names of the modules that have been loaded into Lisp so far.
899      It is used by PROVIDE and REQUIRE.")
900
901     ;; We provide two different ways to define modules. The default way
902     ;; is to put either a source or binary file with the same name
903     ;; as the module in the library directory. The other way is to define
904     ;; the list of files in the module with defmodule.
905
906     ;; The directory listed in *library* is implementation dependent,
907     ;; and is intended to be used by Lisp manufacturers as a place to
908     ;; store their implementation dependent packages.
909     ;; Lisp users should use systems and *central-registry* to store
910     ;; their packages -- it is intended that *central-registry* is
911     ;; set by the user, while *library* is set by the lisp.
912
913     (defvar *library* nil               ; "/usr/local/lisp/Modules/"
914       "Directory within the file system containing files, where the name
915      of a file is the same as the name of the module it contains.")
916
917     (defvar *module-files* (make-hash-table :test #'equal)
918       "Hash table mapping from module names to list of files for the
919      module. REQUIRE loads these files in order.")
920
921     (defun canonicalize-module-name (name)
922       ;; if symbol, string-downcase the printrep to make nicer filenames.
923       (if (stringp name) name (string-downcase (string name))))
924
925     (defmacro defmodule (name &rest files)
926       "Defines a module NAME to load the specified FILES in order."
927       `(setf (gethash (canonicalize-module-name ,name) *module-files*)
928              ',files))
929     (defun module-files (name)
930       (gethash name *module-files*))
931
932     (defun provide (name)
933       "Adds a new module name to the list of modules maintained in the
934      variable *modules*, thereby indicating that the module has been
935      loaded. Name may be a string or symbol -- strings are case-senstive,
936      while symbols are treated like lowercase strings. Returns T if
937      NAME was not already present, NIL otherwise."
938       (let ((module (canonicalize-module-name name)))
939         (unless (find module *modules* :test #'string=)
940           ;; Module not present. Add it and return T to signify that it
941           ;; was added.
942           (push module *modules*)
943           t)))
944
945     (defun require (name &optional pathname)
946       "Tests whether a module is already present. If the module is not
947      present, loads the appropriate file or set of files. The pathname
948      argument, if present, is a single pathname or list of pathnames
949      whose files are to be loaded in order, left to right. If the
950      pathname is nil, the system first checks if a module was defined
951      using defmodule and uses the pathnames so defined. If that fails,
952      it looks in the library directory for a file with name the same
953      as that of the module. Returns T if it loads the module."
954       (let ((module (canonicalize-module-name name)))
955         (unless (find module *modules* :test #'string=)
956           ;; Module is not already present.
957           (when (and pathname (not (listp pathname)))
958             ;; If there's a pathname or pathnames, ensure that it's a list.
959             (setf pathname (list pathname)))
960           (unless pathname
961             ;; If there's no pathname, try for a defmodule definition.
962             (setf pathname (module-files module)))
963           (unless pathname
964             ;; If there's still no pathname, try the library directory.
965             (when *library*
966               (setf pathname (concatenate 'string *library* module))
967               ;; Test if the file exists.
968               ;; We assume that the lisp will default the file type
969               ;; appropriately. If it doesn't, use #+".fasl" or some
970               ;; such in the concatenate form above.
971               (if (probe-file pathname)
972                   ;; If it exists, ensure we've got a list
973                   (setf pathname (list pathname))
974                   ;; If the library file doesn't exist, we don't want
975                   ;; a load error.
976                   (setf pathname nil))))
977           ;; Now that we've got the list of pathnames, let's load them.
978           (dolist (pname pathname t)
979             (load pname :verbose nil))))))
980   ) ; eval-when
981
982 ;;; ********************************
983 ;;; Set up Package *****************
984 ;;; ********************************
985
986
987 ;;; Unfortunately, lots of lisps have their own defsystems, some more
988 ;;; primitive than others, all uncompatible, and all in the DEFSYSTEM
989 ;;; package. To avoid name conflicts, we've decided to name this the
990 ;;; MAKE package. A nice side-effect is that the short nickname
991 ;;; MK is my initials.
992
993 #+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
994 (defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
995
996 #-(or :sbcl :cltl2 :lispworks :ecl :scl)
997 (in-package "MAKE" :nicknames '("MK"))
998
999 ;;; For CLtL2 compatible lisps...
1000 #+(and :excl :allegro-v4.0 :cltl2)
1001 (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
1002             (:import-from cltl1 *modules* provide require))
1003
1004 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1005 ;;; In Allegro 4.1, 'provide' and 'require' are not external in
1006 ;;; 'CLTL1'.  However they are in 'COMMON-LISP'.  Hence the change.
1007 #+(and :excl :allegro-v4.1 :cltl2)
1008 (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) )
1009
1010 #+(and :excl :allegro-version>= (version>= 4 2))
1011 (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp))
1012
1013 #+:lispworks
1014 (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1015             (:import-from "SYSTEM" *modules* provide require)
1016             (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
1017                      "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
1018
1019 #+:mcl
1020 (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1021   (:import-from ccl *modules* provide require))
1022
1023 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
1024 ;;; The code below, is originally executed also for CMUCL. However I
1025 ;;; believe this is wrong, since CMUCL comes with its own defpackage.
1026 ;;; I added the extra :CMU in the 'or'.
1027 #+(and :cltl2 (not (or :cmu :clisp :sbcl
1028                        (and :excl (or :allegro-v4.0 :allegro-v4.1))
1029                        :mcl)))
1030 (eval-when (compile load eval)
1031   (unless (find-package "MAKE")
1032     (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))
1033
1034 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
1035 ;;; Here I add the proper defpackage for CMU
1036 #+:CMU
1037 (defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
1038   (:nicknames "MK")
1039   (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
1040            "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"
1041            "FIND-SYSTEM"))
1042
1043 #+:sbcl
1044 (defpackage "MAKE" (:use "COMMON-LISP")
1045   (:nicknames "MK"))
1046
1047 #+:scl
1048 (defpackage :make (:use :common-lisp)
1049   (:nicknames :mk))
1050
1051 #+(or :cltl2 :lispworks :scl)
1052 (eval-when (compile load eval)
1053   (in-package "MAKE"))
1054
1055 #+(or ecl cmu)
1056 (in-package "MAKE")
1057
1058 ;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
1059 ;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
1060 #+(and :excl :allegro-v4.0 :cltl2)
1061 (cltl1:provide 'make)
1062 #+(and :excl :allegro-v4.0 :cltl2)
1063 (provide 'make)
1064
1065 #+:openmcl
1066 (cl:provide 'make)
1067
1068 #+(and :mcl (not :openmcl))
1069 (ccl:provide 'make)
1070
1071 #+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)))
1072 (provide 'make)
1073
1074 #+:lispworks
1075 (provide 'make)
1076
1077 #-(or :cltl2 :lispworks)
1078 (progn
1079   (provide 'make)
1080   (provide 'defsystem))
1081
1082 (pushnew :mk-defsystem *features*)
1083
1084 ;;; Some compatibility issues.  Mostly for CormanLisp.
1085 ;;; 2002-02-20 Marco Antoniotti
1086
1087 #+cormanlisp
1088 (defun compile-file-pathname (pathname-designator)
1089  (merge-pathnames (make-pathname :type "fasl")
1090                   (etypecase pathname-designator
1091                     (pathname pathname-designator)
1092                     (string (parse-namestring pathname-designator))
1093                     ;; We need FILE-STREAM here as well.
1094                     )))
1095
1096 #+cormanlisp
1097 (defun file-namestring (pathname-designator)
1098   (let ((p (etypecase pathname-designator
1099              (pathname pathname-designator)
1100              (string (parse-namestring pathname-designator))
1101              ;; We need FILE-STREAM here as well.
1102              )))
1103     (namestring (make-pathname :directory ()
1104                                :name (pathname-name p)
1105                                :type (pathname-type p)
1106                                :version (pathname-version p)))))
1107
1108 ;;; The external interface consists of *exports* and *other-exports*.
1109
1110 ;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in
1111 ;;; the compile form, so that you can't use a defvar with a default value and
1112 ;;; then a succeeding export as well.
1113
1114 (eval-when (compile load eval)
1115   (defvar *special-exports* nil)
1116   (defvar *exports* nil)
1117   (defvar *other-exports* nil)
1118
1119   (export (setq *exports*
1120                 '(operate-on-system
1121                   oos
1122                   afs-binary-directory afs-source-directory
1123                   files-in-system)))
1124   (export (setq *special-exports*
1125                 '()))
1126   (export (setq *other-exports*
1127                 '(*central-registry*
1128                   *bin-subdir*
1129
1130                   add-registry-location
1131                   list-central-registry-directories
1132                   print-central-registry-directories
1133                   find-system
1134                   defsystem compile-system load-system hardcopy-system
1135
1136                   system-definition-pathname
1137
1138                   missing-component
1139                   missing-component-name
1140                   missing-component-component
1141                   missing-module
1142                   missing-system
1143
1144                   register-foreign-system
1145
1146                   machine-type-translation
1147                   software-type-translation
1148                   compiler-type-translation
1149                   ;; require
1150                   define-language
1151                   allegro-make-system-fasl
1152                   files-which-need-compilation
1153                   undefsystem
1154                   defined-systems
1155                   describe-system clean-system edit-system ;hardcopy-system
1156                   system-source-size make-system-tag-table
1157                   *defsystem-version*
1158                   *compile-during-load*
1159                   *minimal-load*
1160                   *dont-redefine-require*
1161                   *files-missing-is-an-error*
1162                   *reload-systems-from-disk*
1163                   *source-pathname-default*
1164                   *binary-pathname-default*
1165                   *multiple-lisp-support*
1166
1167                   run-unix-program
1168                   *default-shell*
1169                   run-shell-command
1170                   )))
1171   )
1172
1173
1174 ;;; We import these symbols into the USER package to make them
1175 ;;; easier to use. Since some lisps have already defined defsystem
1176 ;;; in the user package, we may have to shadowing-import it.
1177 #|
1178 #-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
1179 (eval-when (compile load eval)
1180   (import *exports* #-(or :cltl2 :lispworks) "USER"
1181                     #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
1182   (import *special-exports* #-(or :cltl2 :lispworks) "USER"
1183                             #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
1184 #+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
1185 (eval-when (compile load eval)
1186   (import *exports* #-(or :cltl2 :lispworks) "USER"
1187                     #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
1188   (shadowing-import *special-exports*
1189                     #-(or :cltl2 :lispworks) "USER"
1190                     #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
1191 |#
1192
1193 #-(or :PCL :CLOS :scl)
1194 (when (find-package "PCL")
1195   (pushnew :pcl *modules*)
1196   (pushnew :pcl *features*))
1197
1198
1199 ;;; ********************************
1200 ;;; Defsystem Version **************
1201 ;;; ********************************
1202 (defparameter *defsystem-version* "3.6 Interim, 2008-12-18"
1203   "Current version number/date for MK:DEFSYSTEM.")
1204
1205
1206 ;;; ********************************
1207 ;;; Customizable System Parameters *
1208 ;;; ********************************
1209
1210 (defvar *dont-redefine-require*
1211   #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil)
1212   #+(or clisp sbcl) t
1213   #+allegro t
1214   #-(or cmu sbcl clisp allegro) nil
1215   "If T, prevents the redefinition of REQUIRE.
1216 This is useful for lisps that treat REQUIRE specially in the compiler.")
1217
1218
1219 (defvar *multiple-lisp-support* t
1220   "If T, afs-binary-directory will try to return a name dependent
1221 on the particular lisp compiler version being used.")
1222
1223
1224 ;;; home-subdirectory --
1225 ;;; HOME-SUBDIRECTORY is used only in *central-registry* below.
1226 ;;; Note that CMU CL 17e does not understand the ~/ shorthand for home
1227 ;;; directories.
1228 ;;;
1229 ;;; Note:
1230 ;;; 20020220 Marco Antoniotti
1231 ;;; The #-cormanlisp version is the original one, which is broken anyway, since
1232 ;;; it is UNIX dependent.
1233 ;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing
1234 ;;; the ANSI USER-HOMEDIR-PATHNAME function.
1235
1236 #-cormanlisp
1237 (defun home-subdirectory (directory)
1238   (concatenate 'string
1239         #+(or :sbcl :cmu :scl)
1240         "home:"
1241         #-(or :sbcl :cmu :scl)
1242         (let ((homedir (user-homedir-pathname)))
1243           (or (and homedir (namestring homedir))
1244               "~/"))
1245         directory))
1246
1247
1248 #+cormanlisp
1249 (defun home-subdirectory (directory)
1250   (declare (type string directory))
1251   (concatenate 'string "C:\\" directory))
1252
1253
1254 ;;; The following function is available for users to add
1255 ;;;   (setq mk:*central-registry* (defsys-env-search-path))
1256 ;;; to Lisp init files in order to use the value of the DEFSYSPATH
1257 ;;; instead of directly coding it in the file.
1258
1259 #+:allegro
1260 (defun defsys-env-search-path ()
1261   "This function grabs the value of the DEFSYSPATH environment variable
1262    and breaks the search path into a list of paths."
1263   (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
1264                      :test #'string-equal))
1265
1266
1267 ;;; Change this variable to set up the location of a central
1268 ;;; repository for system definitions if you want one.
1269 ;;; This is a defvar to allow users to change the value in their
1270 ;;; lisp init files without worrying about it reverting if they
1271 ;;; reload defsystem for some reason.
1272
1273 ;;; Note that if a form is included in the registry list, it will be evaluated
1274 ;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check.
1275
1276 (defvar *central-registry*
1277   `(;; Current directory
1278     "./"
1279     #+:LUCID     (working-directory)
1280     #+ACLPC      (current-directory)
1281     #+:allegro   (excl:current-directory)
1282     #+:clisp     (ext:default-directory)
1283     #+:sbcl      (progn *default-pathname-defaults*)
1284     #+(or :cmu :scl)       (ext:default-directory)
1285     ;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu>
1286     ;; Somehow it is better to qualify default-directory in CMU with
1287     ;; the appropriate package (i.e. "EXTENSIONS".)
1288     ;; Same for Allegro.
1289     #+(and :lispworks (not :lispworks4) (not :lispworks5))
1290     ,(multiple-value-bind (major minor)
1291                           #-:lispworks-personal-edition
1292                           (system::lispworks-version)
1293                           #+:lispworks-personal-edition
1294                           (values system::*major-version-number*
1295                                   system::*minor-version-number*)
1296        (if (or (> major 3)
1297                (and (= major 3) (> minor 2))
1298                (and (= major 3) (= minor 2)
1299                     (equal (lisp-implementation-version) "3.2.1")))
1300            `(make-pathname :directory
1301                            ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
1302                                          (find-package "SYSTEM")))
1303            (find-symbol "*CURRENT-WORKING-DIRECTORY*"
1304                         (find-package "LW"))))
1305     #+(or :lispworks4 :lispworks5)
1306     (hcl:get-working-directory)
1307     ;; Home directory
1308     #-sbcl
1309     (mk::home-subdirectory "lisp/systems/")
1310
1311     ;; Global registry
1312     #+unix (pathname "/usr/local/lisp/Registry/")
1313     )
1314   "Central directory of system definitions.
1315 May be either a single directory pathname, or a list of directory
1316 pathnames to be checked after the local directory.")
1317
1318
1319 (defun add-registry-location (pathname)
1320   "Adds a path to the central registry."
1321   (pushnew pathname *central-registry* :test #'equal))
1322
1323
1324 (defun registry-pathname (registry)
1325   "Return the pathname represented by the element of *CENTRAL-REGISTRY*."
1326   (typecase registry
1327     (string (pathname registry))
1328     (pathname registry)
1329     (otherwise (pathname (eval registry)))))
1330
1331
1332 (defun print-central-registry-directories (&optional (stream *standard-output*))
1333   (dolist (registry *central-registry*)
1334     (print (registry-pathname registry) stream)))
1335
1336
1337 (defun list-central-registry-directories ()
1338   (mapcar #'registry-pathname *central-registry*))
1339
1340
1341 (defvar *bin-subdir* ".bin/"
1342   "The subdirectory of an AFS directory where the binaries are really kept.")
1343
1344
1345 ;;; These variables set up defaults for operate-on-system, and are used
1346 ;;; for communication in lieu of parameter passing. Yes, this is bad,
1347 ;;; but it keeps the interface small. Also, in the case of the -if-no-binary
1348 ;;; variables, parameter passing would require multiple value returns
1349 ;;; from some functions. Why make life complicated?
1350
1351 (defvar *tell-user-when-done* nil
1352   "If T, system will print ...DONE at the end of an operation")
1353
1354 (defvar *oos-verbose* nil
1355   "Operate on System Verbose Mode")
1356
1357 (defvar *oos-test* nil
1358   "Operate on System Test Mode")
1359
1360 (defvar *load-source-if-no-binary* nil
1361   "If T, system will try loading the source if the binary is missing")
1362
1363 (defvar *bother-user-if-no-binary* t
1364   "If T, the system will ask the user whether to load the source if
1365    the binary is missing")
1366
1367 (defvar *load-source-instead-of-binary* nil
1368   "If T, the system will load the source file instead of the binary.")
1369
1370 (defvar *compile-during-load* :query
1371   "If T, the system will compile source files during load if the
1372 binary file is missing. If :query, it will ask the user for
1373 permission first.")
1374
1375 (defvar *minimal-load* nil
1376   "If T, the system tries to avoid reloading files that were already loaded
1377 and up to date.")
1378
1379 (defvar *files-missing-is-an-error* t
1380   "If both the source and binary files are missing, signal a continuable
1381    error instead of just a warning.")
1382
1383 (defvar *operations-propagate-to-subsystems* t
1384   "If T, operations like :COMPILE and :LOAD propagate to subsystems
1385    of a system that are defined either using a component-type of :system
1386    or by another defsystem form.")
1387
1388 ;;; Particular to CMULisp
1389
1390 (defvar *compile-error-file-type* "err"
1391   "File type of compilation error file in cmulisp")
1392
1393 (defvar *cmu-errors-to-terminal* t
1394   "Argument to :errors-to-terminal in compile-file in cmulisp")
1395
1396 (defvar *cmu-errors-to-file* t
1397   "If T, cmulisp will write an error file during compilation")
1398
1399
1400 ;;; ********************************
1401 ;;; Global Variables ***************
1402 ;;; ********************************
1403
1404 ;;; Massage people's *features* into better shape.
1405 (eval-when (compile load eval)
1406   (dolist (feature *features*)
1407     (when (and (symbolp feature)   ; 3600
1408                (equal (symbol-name feature) "CMU"))
1409       (pushnew :CMU *features*)))
1410
1411   #+Lucid
1412   (when (search "IBM RT PC" (machine-type))
1413     (pushnew :ibm-rt-pc *features*))
1414   )
1415
1416
1417 ;;; *filename-extensions* is a cons of the source and binary extensions.
1418 (defvar *filename-extensions*
1419   (car `(#+(and Symbolics Lispm)              ("lisp" . "bin")
1420          #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
1421          #+(and dec common vax ultrix)        ("lsp"  . "fas")
1422          #+ACLPC                              ("lsp"  . "fsl")
1423          #+CLISP                              ("lisp" . "fas")
1424          #+KCL                                ("lsp"  . "o")
1425          ;;#+ECL                                ("lsp"  . "so")
1426          #+IBCL                               ("lsp"  . "o")
1427          #+Xerox                              ("lisp" . "dfasl")
1428          ;; Lucid on Silicon Graphics
1429          #+(and Lucid MIPS)                   ("lisp" . "mbin")
1430          ;; the entry for (and lucid hp300) must precede
1431          ;; that of (and lucid mc68000) for hp9000/300's running lucid,
1432          ;; since *features* on hp9000/300's also include the :mc68000
1433          ;; feature.
1434          #+(and lucid hp300)                  ("lisp" . "6bin")
1435          #+(and Lucid MC68000)                ("lisp" . "lbin")
1436          #+(and Lucid Vax)                    ("lisp" . "vbin")
1437          #+(and Lucid Prime)                  ("lisp" . "pbin")
1438          #+(and Lucid SUNRise)                ("lisp" . "sbin")
1439          #+(and Lucid SPARC)                  ("lisp" . "sbin")
1440          #+(and Lucid :IBM-RT-PC)             ("lisp" . "bbin")
1441          ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
1442          #+(and Lucid PA)                     ("lisp" . "hbin")
1443          #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
1444          #+(or :cmu :scl)  ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
1445 ;        #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
1446 ;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
1447 ;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
1448          #+PRIME                              ("lisp" . "pbin")
1449          #+HP                                 ("l"    . "b")
1450          #+TI ("lisp" . #.(string (si::local-binary-file-type)))
1451          #+:gclisp                            ("LSP"  . "F2S")
1452          #+pyramid                            ("clisp" . "o")
1453
1454          ;; Harlequin LispWorks
1455          #+:lispworks         ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
1456 ;        #+(and :sun4 :lispworks)             ("lisp" . "wfasl")
1457 ;        #+(and :mips :lispworks)             ("lisp" . "mfasl")
1458          #+:mcl                               ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
1459          #+:coral                             ("lisp" . "fasl")
1460
1461          ;; Otherwise,
1462          ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
1463   "Filename extensions for Common Lisp.
1464 A cons of the form (Source-Extension . Binary-Extension). If the
1465 system is unknown (as in *features* not known), defaults to lisp and
1466 fasl.")
1467
1468 (defvar *system-extension*
1469   ;; MS-DOS systems can only handle three character extensions.
1470   #-ACLPC "system"
1471   #+ACLPC "sys"
1472   "The filename extension to use with systems.")
1473
1474
1475 ;;; The above variables and code should be extended to allow a list of
1476 ;;; valid extensions for each lisp implementation, instead of a single
1477 ;;; extension. When writing a file, the first extension should be used.
1478 ;;; But when searching for a file, every extension in the list should
1479 ;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and
1480 ;;; "lsp" (*load-source-types*) as source code extensions, and
1481 ;;; (c:backend-fasl-file-type c:*backend*)
1482 ;;; (c:backend-byte-fasl-file-type c:*backend*)
1483 ;;; and "fasl" as binary (object) file extensions (*load-object-types*).
1484
1485 ;;; Note that the above code is used below in the LANGUAGE defstruct.
1486
1487 ;;; There is no real support for this variable being nil, so don't change it.
1488 ;;; Note that in any event, the toplevel system (defined with defsystem)
1489 ;;; will have its dependencies delayed. Not having dependencies delayed
1490 ;;; might be useful if we define several systems within one defsystem.
1491
1492 (defvar *system-dependencies-delayed* t
1493   "If T, system dependencies are expanded at run time")
1494
1495
1496 ;;; Replace this with consp, dammit!
1497 (defun non-empty-listp (list)
1498   (and list (listp list)))
1499
1500
1501 ;;; ********************************
1502 ;;; Component Operation Definition *
1503 ;;; ********************************
1504 (eval-when (:compile-toplevel :load-toplevel :execute)
1505
1506 (defvar *version-dir* nil
1507   "The version subdir. bound in operate-on-system.")
1508
1509 (defvar *version-replace* nil
1510   "The version replace. bound in operate-on-system.")
1511
1512 (defvar *version* nil
1513   "Default version."))
1514
1515 (defvar *component-operations* (make-hash-table :test #'equal)
1516   "Hash table of (operation-name function) pairs.")
1517
1518 (defun component-operation (name &optional operation)
1519   (if operation
1520       (setf (gethash name *component-operations*) operation)
1521       (gethash name *component-operations*)))
1522
1523
1524 ;;; ********************************
1525 ;;; AFS @sys immitator *************
1526 ;;; ********************************
1527
1528 ;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.
1529 #-:mcl
1530 (eval-when (compile load eval)
1531   ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo").
1532   ;; For example,
1533   ;;    <cl> #@"foo"
1534   ;;    "foo/.bin/rt_mach/"
1535   (set-dispatch-macro-character
1536    #\# #\@
1537    #'(lambda (stream char arg)
1538        (declare (ignore char arg))
1539        `(afs-binary-directory ,(read stream t nil t)))))
1540
1541
1542 (defvar *find-irix-version-script*
1543     "\"1,4 d\\
1544 s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
1545 /./,$ d\\
1546 \"")
1547
1548
1549 (defun operating-system-version ()
1550   #+(and :sgi :excl)
1551   (let* ((full-version (software-version))
1552          (blank-pos (search " " full-version))
1553          (os (subseq full-version 0 blank-pos))
1554          (version-rest (subseq full-version
1555                                (1+ blank-pos)))
1556          os-version)
1557     (setq blank-pos (search " " version-rest))
1558     (setq version-rest (subseq version-rest
1559                                (1+ blank-pos)))
1560     (setq blank-pos (search " " version-rest))
1561     (setq os-version (subseq version-rest 0 blank-pos))
1562     (setq version-rest (subseq version-rest
1563                                (1+ blank-pos)))
1564     (setq blank-pos (search " " version-rest))
1565     (setq version-rest (subseq version-rest
1566                                (1+ blank-pos)))
1567     (concatenate 'string
1568       os " " os-version))      ; " " version-rest
1569   #+(and :sgi :cmu :sbcl)
1570   (concatenate 'string
1571     (software-type)
1572     (software-version))
1573   #+(and :lispworks :irix)
1574   (let ((soft-type (software-type)))
1575     (if (equalp soft-type "IRIX5")
1576         (progn
1577           (foreign:call-system
1578             (format nil "versions ~A | sed -e ~A > ~A"
1579                          "eoe1"
1580                          *find-irix-version-script*
1581                          "irix-version")
1582             "/bin/csh")
1583           (with-open-file (s "irix-version")
1584                           (format nil "IRIX ~S"
1585                                   (read s))))
1586       soft-type))
1587   #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
1588   (software-type))
1589
1590
1591 (defun compiler-version ()
1592   #+:lispworks (concatenate 'string
1593                 "lispworks" " " (lisp-implementation-version))
1594   #+excl      (concatenate 'string
1595                 "excl" " " excl::*common-lisp-version-number*)
1596   #+sbcl      (concatenate 'string
1597                            "sbcl" " " (lisp-implementation-version))
1598   #+cmu       (concatenate 'string
1599                 "cmu" " " (lisp-implementation-version))
1600   #+scl       (concatenate 'string
1601                 "scl" " " (lisp-implementation-version))
1602
1603   #+kcl       "kcl"
1604   #+IBCL      "ibcl"
1605   #+akcl      "akcl"
1606   #+gcl       "gcl"
1607   #+ecl       "ecl"
1608   #+lucid     "lucid"
1609   #+ACLPC     "aclpc"
1610   #+CLISP     "clisp"
1611   #+Xerox     "xerox"
1612   #+symbolics "symbolics"
1613   #+mcl       "mcl"
1614   #+coral     "coral"
1615   #+gclisp    "gclisp"
1616   )
1617
1618
1619 (defun afs-binary-directory (root-directory)
1620   ;; Function for obtaining the directory AFS's @sys feature would have
1621   ;; chosen when we're not in AFS. This function is useful as the argument
1622   ;; to :binary-pathname in defsystem. For example,
1623   ;; :binary-pathname (afs-binary-directory "scanner/")
1624   (let ((machine (machine-type-translation
1625                   #-(and :sgi :allegro-version>= (version>= 4 2))
1626                   (machine-type)
1627                   #+(and :sgi :allegro-version>= (version>= 4 2))
1628                   (machine-version)))
1629         (software (software-type-translation
1630                    #-(and :sgi (or :cmu :sbcl :scl
1631                                    (and :allegro-version>= (version>= 4 2))))
1632                    (software-type)
1633                    #+(and :sgi (or :cmu :sbcl :scl
1634                                    (and :allegro-version>= (version>= 4 2))))
1635                    (operating-system-version)))
1636         (lisp (compiler-type-translation (compiler-version))))
1637     ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
1638     (setq root-directory (namestring root-directory))
1639     (setq root-directory (ensure-trailing-slash root-directory))
1640     (format nil "~A~@[~A~]~@[~A/~]"
1641             root-directory
1642             *bin-subdir*
1643             (if *multiple-lisp-support*
1644                 (afs-component machine software lisp)
1645               (afs-component machine software)))))
1646
1647 (defun afs-source-directory (root-directory &optional version-flag)
1648   ;; Function for obtaining the directory AFS's @sys feature would have
1649   ;; chosen when we're not in AFS. This function is useful as the argument
1650   ;; to :source-pathname in defsystem.
1651   (setq root-directory (namestring root-directory))
1652   (setq root-directory (ensure-trailing-slash root-directory))
1653   (format nil "~A~@[~A/~]"
1654           root-directory
1655           (and version-flag (translate-version *version*))))
1656
1657
1658 (defun null-string (s)
1659   (when (stringp s)
1660     (string-equal s "")))
1661
1662
1663 (defun ensure-trailing-slash (dir)
1664   (if (and dir
1665            (not (null-string dir))
1666            (not (char= (char dir
1667                              (1- (length dir)))
1668                        #\/))
1669            (not (char= (char dir
1670                              (1- (length dir)))
1671                        #\\))
1672            )
1673       (concatenate 'string dir "/")
1674       dir))
1675
1676
1677 (defun afs-component (machine software &optional lisp)
1678   (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
1679             machine
1680             (or software "mach")
1681             lisp))
1682
1683
1684 (defvar *machine-type-alist* (make-hash-table :test #'equal)
1685   "Hash table for retrieving the machine-type")
1686
1687 (defun machine-type-translation (name &optional operation)
1688   (if operation
1689       (setf (gethash (string-upcase name) *machine-type-alist*) operation)
1690       (gethash (string-upcase name) *machine-type-alist*)))
1691
1692
1693 (machine-type-translation "IBM RT PC"                        "rt")
1694 (machine-type-translation "DEC 3100"                         "pmax")
1695 (machine-type-translation "DEC VAX-11"                       "vax")
1696 (machine-type-translation "DECstation"                       "pmax")
1697 (machine-type-translation "Sun3"                             "sun3")
1698 (machine-type-translation "Sun-4"                            "sun4")
1699 (machine-type-translation "MIPS Risc"                        "mips")
1700 (machine-type-translation "SGI"                              "sgi")
1701 (machine-type-translation "Silicon Graphics Iris 4D"         "sgi")
1702 (machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi")
1703 (machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi")
1704 (machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi")
1705 (machine-type-translation "IP22"                             "sgi")
1706 ;;; MIPS R4000 Processor Chip Revision: 3.0
1707 ;;; MIPS R4400 Processor Chip Revision: 5.0
1708 ;;; MIPS R4600 Processor Chip Revision: 1.0
1709 (machine-type-translation "IP20"                             "sgi")
1710 ;;; MIPS R4000 Processor Chip Revision: 3.0
1711 (machine-type-translation "IP17"                             "sgi")
1712 ;;; MIPS R4000 Processor Chip Revision: 2.2
1713 (machine-type-translation "IP12"                             "sgi")
1714 ;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
1715 (machine-type-translation "IP7"                              "sgi")
1716 ;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
1717
1718 (machine-type-translation "x86"                              "x86")
1719 ;;; ACL
1720 (machine-type-translation "IBM PC Compatible"                "x86")
1721 ;;; LW
1722 (machine-type-translation "I686"                             "x86")
1723 ;;; LW
1724 (machine-type-translation "PC/386"                           "x86")
1725 ;;; CLisp Win32
1726
1727 #+(and :lucid :sun :mc68000)
1728 (machine-type-translation "unknown"     "sun3")
1729
1730
1731 (defvar *software-type-alist* (make-hash-table :test #'equal)
1732   "Hash table for retrieving the software-type")
1733
1734 (defun software-type-translation (name &optional operation)
1735   (if operation
1736       (setf (gethash (string-upcase name) *software-type-alist*) operation)
1737       (gethash (string-upcase name) *software-type-alist*)))
1738
1739
1740 (software-type-translation "BSD UNIX"      "mach") ; "unix"
1741 (software-type-translation "Ultrix"        "mach") ; "ultrix"
1742 (software-type-translation "SunOS"         "SunOS")
1743 (software-type-translation "MACH/4.3BSD"   "mach")
1744 (software-type-translation "IRIX System V" "irix") ; (software-type)
1745 (software-type-translation "IRIX5"         "irix5")
1746 ;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version)
1747
1748 (software-type-translation "IRIX 5.2" "irix5")
1749 (software-type-translation "IRIX 5.3" "irix5")
1750 (software-type-translation "IRIX5.2"  "irix5")
1751 (software-type-translation "IRIX5.3"  "irix5")
1752
1753 (software-type-translation "Linux" "linux") ; Lispworks for Linux
1754 (software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL
1755 (software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32")
1756 (software-type-translation "Windows NT" "win32") ; LW for Windows
1757 (software-type-translation "ANSI C program" "ansi-c") ; CLISP
1758 (software-type-translation "C compiler" "ansi-c") ; CLISP for Win32
1759
1760 (software-type-translation nil             "")
1761
1762 #+:lucid
1763 (software-type-translation "Unix"
1764                            #+:lcl4.0 "4.0"
1765                            #+(and :lcl3.0 (not :lcl4.0)) "3.0")
1766
1767
1768 (defvar *compiler-type-alist* (make-hash-table :test #'equal)
1769   "Hash table for retrieving the Common Lisp type")
1770
1771 (defun compiler-type-translation (name &optional operation)
1772   (if operation
1773       (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
1774     (gethash (string-upcase name) *compiler-type-alist*)))
1775
1776
1777 (compiler-type-translation "lispworks 3.2.1"         "lispworks")
1778 (compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
1779 (compiler-type-translation "lispworks 4.2.0"         "lispworks")
1780
1781
1782 #+allegro
1783 (eval-when (:compile-toplevel :load-toplevel :execute)
1784   (unless (or (find :case-sensitive common-lisp:*features*)
1785               (find :case-insensitive common-lisp:*features*))
1786     (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
1787             (eq excl:*current-case-mode* :case-sensitive-upper))
1788         (push :case-sensitive common-lisp:*features*)
1789       (push :case-insensitive common-lisp:*features*))))
1790
1791
1792 #+(and allegro case-sensitive ics)
1793 (compiler-type-translation "excl 6.1" "excl-m")
1794 #+(and allegro case-sensitive (not ics))
1795 (compiler-type-translation "excl 6.1" "excl-m8")
1796
1797 #+(and allegro case-insensitive ics)
1798 (compiler-type-translation "excl 6.1" "excl-a")
1799 #+(and allegro case-insensitive (not ics))
1800 (compiler-type-translation "excl 6.1" "excl-a8")
1801
1802 (compiler-type-translation "excl 4.2" "excl")
1803 (compiler-type-translation "excl 4.1" "excl")
1804 (compiler-type-translation "cmu 17f" "cmu")
1805 (compiler-type-translation "cmu 17e" "cmu")
1806 (compiler-type-translation "cmu 17d" "cmu")
1807
1808
1809 ;;; ********************************
1810 ;;; System Names *******************
1811 ;;; ********************************
1812
1813 ;;; If you use strings for system names, be sure to use the same case
1814 ;;; as it appears on disk, if the filesystem is case sensitive.
1815
1816 (defun canonicalize-system-name (name)
1817   ;; Originally we were storing systems using GET. This meant that the
1818   ;; name of a system had to be a symbol, so we interned the symbols
1819   ;; in the keyword package to avoid package dependencies. Now that we're
1820   ;; storing the systems in a hash table, we've switched to using strings.
1821   ;; Since the hash table is case sensitive, we use uppercase strings.
1822   ;; (Names of modules and files may be symbols or strings.)
1823   #||(if (keywordp name)
1824       name
1825       (intern (string-upcase (string name)) "KEYWORD"))||#
1826   (if (stringp name) (string-upcase name) (string-upcase (string name))))
1827
1828
1829 (defvar *defined-systems* (make-hash-table :test #'equal)
1830   "Hash table containing the definitions of all known systems.")
1831
1832
1833 (defun get-system (name)
1834   "Returns the definition of the system named NAME."
1835   (gethash (canonicalize-system-name name) *defined-systems*))
1836
1837
1838 (defsetf get-system (name) (value)
1839   `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))
1840
1841
1842 (defun undefsystem (name)
1843   "Removes the definition of the system named NAME."
1844   (remhash (canonicalize-system-name name) *defined-systems*))
1845
1846
1847 (defun defined-systems ()
1848   "Returns a list of defined systems."
1849   (let ((result nil))
1850     (maphash #'(lambda (key value)
1851                  (declare (ignore key))
1852                  (push value result))
1853              *defined-systems*)
1854     result))
1855
1856
1857 (defun defined-names-and-systems ()
1858   "Returns a a-list of defined systems along with their names."
1859   (loop for sname being the hash-keys of *defined-systems*
1860         using (hash-value s)
1861         collect (cons sname s)))
1862
1863
1864 ;;; ********************************
1865 ;;; Directory Pathname Hacking *****
1866 ;;; ********************************
1867
1868 ;;; Unix example: An absolute directory starts with / while a
1869 ;;; relative directory doesn't. A directory ends with /, while
1870 ;;; a file's pathname doesn't. This is important 'cause
1871 ;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".
1872
1873 ;;; I haven't been able to test the fix to the problem with symbolics
1874 ;;; hosts. Essentially, append-directories seems to have been tacking
1875 ;;; the default host onto the front of the pathname (e.g., mk::source-pathname
1876 ;;; gets a "B:" on front) and this overrides the :host specified in the
1877 ;;; component. The value of :host should override that specified in
1878 ;;; the :source-pathname and the default file server. If this doesn't
1879 ;;; fix things, specifying the host in the root pathname "F:>root-dir>"
1880 ;;; may be a good workaround.
1881
1882 ;;; Need to verify that merging of pathnames where modules are located
1883 ;;; on different devices (in VMS-based VAXLisp) now works.
1884
1885 ;;; Merge-pathnames works for VMS systems. In VMS systems, the directory
1886 ;;; part is enclosed in square brackets, e.g.,
1887 ;;;     "[root.child.child_child]" or "[root.][child.][child_child]"
1888 ;;; To concatenate directories merge-pathnames works as follows:
1889 ;;;     (merge-pathnames "" "[root]")               ==> "[root]"
1890 ;;;     (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
1891 ;;;     (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
1892 ;;;     (merge-pathnames "[root]file.ext" "[son]")  ==> "[root]file.ext"
1893 ;;; Thus the problem with the #-VMS code was that it was merging x y into
1894 ;;; [[x]][y] instead of [x][y] or [x]y.
1895
1896 ;;; Miscellaneous notes:
1897 ;;;   On GCLisp, the following are equivalent:
1898 ;;;       "\\root\\subdir\\BAZ"
1899 ;;;       "/root/subdir/BAZ"
1900 ;;;   On VAXLisp, the following are equivalent:
1901 ;;;       "[root.subdir]BAZ"
1902 ;;;       "[root.][subdir]BAZ"
1903 ;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2
1904
1905 (defun new-append-directories (absolute-dir relative-dir)
1906   ;; Version of append-directories for CLtL2-compliant lisps. In particular,
1907   ;; they must conform to section 23.1.3 "Structured Directories". We are
1908   ;; willing to fix minor aberations in this function, but not major ones.
1909   ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
1910   ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
1911   (setf absolute-dir (or absolute-dir "")
1912         relative-dir (or relative-dir ""))
1913   (let* ((abs-dir (pathname absolute-dir))
1914          (rel-dir (pathname relative-dir))
1915          (host (pathname-host abs-dir))
1916          (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
1917                      (pathname-device rel-dir)
1918                    (pathname-device abs-dir)))
1919          (abs-directory (directory-to-list (pathname-directory abs-dir)))
1920          (abs-keyword (when (keywordp (car abs-directory))
1921                         (pop abs-directory)))
1922          ;; Stig (July 2001):
1923          ;; Somehow CLISP dies on the next line, but NIL is ok.
1924          (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
1925          (rel-directory (directory-to-list (pathname-directory rel-dir)))
1926          (rel-keyword (when (keywordp (car rel-directory))
1927                         (pop rel-directory)))
1928          ;; rtoy: Why should any Lisp want rel-file?  Shouldn't using
1929          ;; rel-name and rel-type work for every Lisp?
1930          #-(or :MCL :sbcl :clisp :cmu) (rel-file (file-namestring rel-dir))
1931          ;; Stig (July 2001);
1932          ;; These values seems to help clisp as well
1933          #+(or :MCL :sbcl :clisp :cmu) (rel-name (pathname-name rel-dir))
1934          #+(or :MCL :sbcl :clisp :cmu) (rel-type (pathname-type rel-dir))
1935          (directory nil))
1936
1937     ;; TI Common Lisp pathnames can return garbage for file names because
1938     ;; of bizarreness in the merging of defaults.  The following code makes
1939     ;; sure that the name is a valid name by comparing it with the
1940     ;; pathname-name.  It also strips TI specific extensions and handles
1941     ;; the necessary case conversion.  TI maps upper back into lower case
1942     ;; for unix files!
1943     #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal)
1944              (setf abs-name (string-right-trim ".\17" (string-upcase abs-name)))
1945              (setf abs-name nil))
1946     #+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal)
1947              (setf rel-file (string-right-trim ".\17" (string-upcase rel-file)))
1948              (setf rel-file nil))
1949     ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
1950     ;; and filename "foo". The namestring of a pathname with
1951     ;; directory '(:absolute :root "foo") ignores everything after the
1952     ;; :root.
1953     #+(and allegro-version>= (version>= 4 0))
1954     (when (eq (car abs-directory) :root) (pop abs-directory))
1955     #+(and allegro-version>= (version>= 4 0))
1956     (when (eq (car rel-directory) :root) (pop rel-directory))
1957
1958     (when (and abs-name (not (null-string abs-name))) ; was abs-name
1959       (cond ((and (null abs-directory) (null abs-keyword))
1960              #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
1961              (setf abs-directory (list abs-name)))
1962             (t
1963              (setf abs-directory (append abs-directory (list abs-name))))))
1964     (when (and (null abs-directory)
1965                (or (null abs-keyword)
1966                    ;; In Lucid, an abs-dir of nil gets a keyword of
1967                    ;; :relative since (pathname-directory (pathname ""))
1968                    ;; returns (:relative) instead of nil.
1969                    #+:lucid (eq abs-keyword :relative))
1970                rel-keyword)
1971       ;; The following feature switches seem necessary in CMUCL
1972       ;; Marco Antoniotti 19990707
1973       #+(or :sbcl :CMU)
1974       (if (typep abs-dir 'logical-pathname)
1975           (setf abs-keyword :absolute)
1976           (setf abs-keyword rel-keyword))
1977       #-(or :sbcl :CMU)
1978       (setf abs-keyword rel-keyword))
1979     (setf directory (append abs-directory rel-directory))
1980     (when abs-keyword (setf directory (cons abs-keyword directory)))
1981     (namestring
1982      (make-pathname :host host
1983                     :device device
1984                     :directory
1985                     directory
1986                     :name
1987                     #-(or :sbcl :MCL :clisp :cmu) rel-file
1988                     #+(or :sbcl :MCL :clisp :cmu) rel-name
1989
1990                     #+(or :sbcl :MCL :clisp :cmu) :type
1991                     #+(or :sbcl :MCL :clisp :cmu) rel-type
1992                     ))))
1993
1994
1995 (defun directory-to-list (directory)
1996   ;; The directory should be a list, but nonstandard implementations have
1997   ;; been known to use a vector or even a string.
1998   (cond ((listp directory)
1999          directory)
2000         ((stringp directory)
2001          (cond ((find #\; directory)
2002                 ;; It's probably a logical pathname, so split at the
2003                 ;; semicolons:
2004                 (split-string directory :item #\;))
2005                #+MCL
2006                ((and (find #\: directory)
2007                      (not (find #\/ directory)))
2008                 ;; It's probably a MCL pathname, so split at the colons.
2009                 (split-string directory :item #\:))
2010                (t
2011                 ;; It's probably a unix pathname, so split at the slash.
2012                 (split-string directory :item #\/))))
2013         (t
2014          (coerce directory 'list))))
2015
2016
2017 (defparameter *append-dirs-tests*
2018   '("~/foo/" "baz/bar.lisp"
2019      "~/foo" "baz/bar.lisp"
2020      "/foo/bar/" "baz/barf.lisp"
2021      "/foo/bar/" "/baz/barf.lisp"
2022      "foo/bar/" "baz/barf.lisp"
2023      "foo/bar" "baz/barf.lisp"
2024      "foo/bar" "/baz/barf.lisp"
2025      "foo/bar/" "/baz/barf.lisp"
2026      "/foo/bar/" nil
2027      "foo/bar/" nil
2028      "foo/bar" nil
2029      "foo" nil
2030      "foo" ""
2031      nil "baz/barf.lisp"
2032      nil "/baz/barf.lisp"
2033      nil nil))
2034
2035
2036 (defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
2037   (do* ((dir-list test-dirs (cddr dir-list))
2038         (abs-dir (car dir-list) (car dir-list))
2039         (rel-dir (cadr dir-list) (cadr dir-list)))
2040       ((null dir-list) (values))
2041     (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
2042             abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
2043
2044
2045 #||
2046 <cl> (test-new-append-directories)
2047
2048 ABS: "~/foo/"     REL: "baz/bar.lisp"    Result: "/usr0/mkant/foo/baz/bar.lisp"
2049 ABS: "~/foo"      REL: "baz/bar.lisp"    Result: "/usr0/mkant/foo/baz/bar.lisp"
2050 ABS: "/foo/bar/"  REL: "baz/barf.lisp"   Result: "/foo/bar/baz/barf.lisp"
2051 ABS: "/foo/bar/"  REL: "/baz/barf.lisp"  Result: "/foo/bar/baz/barf.lisp"
2052 ABS: "foo/bar/"   REL: "baz/barf.lisp"   Result: "foo/bar/baz/barf.lisp"
2053 ABS: "foo/bar"    REL: "baz/barf.lisp"   Result: "foo/bar/baz/barf.lisp"
2054 ABS: "foo/bar"    REL: "/baz/barf.lisp"  Result: "foo/bar/baz/barf.lisp"
2055 ABS: "foo/bar/"   REL: "/baz/barf.lisp"  Result: "foo/bar/baz/barf.lisp"
2056 ABS: "/foo/bar/"  REL: NIL               Result: "/foo/bar/"
2057 ABS: "foo/bar/"   REL: NIL               Result: "foo/bar/"
2058 ABS: "foo/bar"    REL: NIL               Result: "foo/bar/"
2059 ABS: "foo"        REL: NIL               Result: "foo/"
2060 ABS: "foo"        REL: ""                Result: "foo/"
2061 ABS: NIL          REL: "baz/barf.lisp"   Result: "baz/barf.lisp"
2062 ABS: NIL          REL: "/baz/barf.lisp"  Result: "/baz/barf.lisp"
2063 ABS: NIL          REL: NIL               Result: ""
2064
2065 ||#
2066
2067
2068 (defun append-directories (absolute-directory relative-directory)
2069   "There is no CL primitive for tacking a subdirectory onto a directory.
2070    We need such a function because defsystem has both absolute and
2071    relative pathnames in the modules. This is a somewhat ugly hack which
2072    seems to work most of the time. We assume that ABSOLUTE-DIRECTORY
2073    is a directory, with no filename stuck on the end. Relative-directory,
2074    however, may have a filename stuck on the end."
2075   (when (or absolute-directory relative-directory)
2076     (cond
2077      ;; KMR commented out because: when appending two logical pathnames,
2078      ;; using this code translates the first logical pathname then appends
2079      ;; the second logical pathname -- an error.
2080      #|
2081       ;; We need a reliable way to determine if a pathname is logical.
2082       ;; Allegro 4.1 does not recognize the syntax of a logical pathname
2083       ;;  as being logical unless its logical host is already defined.
2084
2085       #+(or (and allegro-version>= (version>= 4 1))
2086             :logical-pathnames-mk)
2087       ((and absolute-directory
2088             (logical-pathname-p absolute-directory)
2089             relative-directory)
2090        ;; For use with logical pathnames package.
2091        (append-logical-directories-mk absolute-directory relative-directory))
2092      |#
2093       ((namestring-probably-logical absolute-directory)
2094        ;; A simplistic stab at handling logical pathnames
2095        (append-logical-pnames absolute-directory relative-directory))
2096       (t
2097        ;; In VMS, merge-pathnames actually does what we want!!!
2098        #+:VMS
2099        (namestring (merge-pathnames (or absolute-directory "")
2100                                     (or relative-directory "")))
2101        #+:macl1.3.2
2102        (namestring (make-pathname :directory absolute-directory
2103                                   :name relative-directory))
2104        ;; Cross your fingers and pray.
2105        #-(or :VMS :macl1.3.2)
2106        (new-append-directories absolute-directory relative-directory)))))
2107
2108
2109 #+:logical-pathnames-mk
2110 (defun append-logical-directories-mk (absolute-dir relative-dir)
2111   (lp:append-logical-directories absolute-dir relative-dir))
2112
2113
2114 ;;; append-logical-pathnames-mk --
2115 ;;; The following is probably still bogus and it does not solve the
2116 ;;; problem of appending two logical pathnames.
2117 ;;; Anyway, as per suggetsion by KMR, the function is not called
2118 ;;; anymore.
2119 ;;; Hopefully this will not cause problems for ACL.
2120
2121 #+(and (and allegro-version>= (version>= 4 1))
2122        (not :logical-pathnames-mk))
2123 (defun append-logical-directories-mk (absolute-dir relative-dir)
2124   ;; We know absolute-dir and relative-dir are non nil.  Moreover
2125   ;; absolute-dir is a logical pathname.
2126   (setq absolute-dir (logical-pathname absolute-dir))
2127   (etypecase relative-dir
2128     (string (setq relative-dir (parse-namestring relative-dir)))
2129     (pathname #| do nothing |#))
2130
2131   (translate-logical-pathname
2132    (merge-pathnames relative-dir absolute-dir)))
2133
2134
2135 #| Old version 2002-03-02
2136 #+(and (and allegro-version>= (version>= 4 1))
2137        (not :logical-pathnames-mk))
2138 (defun append-logical-directories-mk (absolute-dir relative-dir)
2139   ;; We know absolute-dir and relative-dir are non nil.  Moreover
2140   ;; absolute-dir is a logical pathname.
2141   (setq absolute-dir (logical-pathname absolute-dir))
2142   (etypecase relative-dir
2143     (string (setq relative-dir (parse-namestring relative-dir)))
2144     (pathname #| do nothing |#))
2145
2146   (translate-logical-pathname
2147    (make-pathname
2148     :host (or (pathname-host absolute-dir)
2149               (pathname-host relative-dir))
2150     :directory (append (pathname-directory absolute-dir)
2151                        (cdr (pathname-directory relative-dir)))
2152     :name (or (pathname-name absolute-dir)
2153               (pathname-name relative-dir))
2154     :type (or (pathname-type absolute-dir)
2155               (pathname-type relative-dir))
2156     :version (or (pathname-version absolute-dir)
2157                  (pathname-version relative-dir)))))
2158
2159 ;; Old version
2160 #+(and (and allegro-version>= (version>= 4 1))
2161        (not :logical-pathnames-mk))
2162 (defun append-logical-directories-mk (absolute-dir relative-dir)
2163   (when (or absolute-dir relative-dir)
2164     (setq absolute-dir (logical-pathname (or absolute-dir ""))
2165           relative-dir (logical-pathname (or relative-dir "")))
2166     (translate-logical-pathname
2167      (make-pathname
2168       :host (or (pathname-host absolute-dir)
2169                 (pathname-host relative-dir))
2170       :directory (append (pathname-directory absolute-dir)
2171                          (cdr (pathname-directory relative-dir)))
2172       :name (or (pathname-name absolute-dir)
2173                 (pathname-name relative-dir))
2174       :type (or (pathname-type absolute-dir)
2175                 (pathname-type relative-dir))
2176       :version (or (pathname-version absolute-dir)
2177                    (pathname-version relative-dir))))))
2178 |#
2179
2180 ;;; determines if string or pathname object is logical
2181 #+:logical-pathnames-mk
2182 (defun logical-pathname-p (thing)
2183   (eq (lp:pathname-host-type thing) :logical))
2184
2185 ;;; From Kevin Layer for 4.1final.
2186 #+(and (and allegro-version>= (version>= 4 1))
2187        (not :logical-pathnames-mk))
2188 (defun logical-pathname-p (thing)
2189   (typep (parse-namestring thing) 'logical-pathname))
2190
2191 (defun pathname-logical-p (thing)
2192   (typecase thing
2193     (logical-pathname t)
2194     #+clisp ; CLisp has non conformant Logical Pathnames.
2195     (pathname (pathname-logical-p (namestring thing)))
2196     (string (and (= 1 (count #\: thing)) ; Shortcut.
2197                  (ignore-errors (translate-logical-pathname thing))
2198                  t))
2199     (t nil)))
2200
2201 ;;; This affects only one thing.
2202 ;;; 19990707 Marco Antoniotti
2203 ;;; old version
2204
2205 (defun namestring-probably-logical (namestring)
2206   (and (stringp namestring)
2207        ;; unix pathnames don't have embedded semicolons
2208        (find #\; namestring)))
2209 #||
2210 ;;; New version
2211 (defun namestring-probably-logical (namestring)
2212   (and (stringp namestring)
2213        (typep (parse-namestring namestring) 'logical-pathname)))
2214
2215
2216 ;;; New new version
2217 ;;; 20000321 Marco Antoniotti
2218 (defun namestring-probably-logical (namestring)
2219   (pathname-logical-p namestring))
2220 ||#
2221
2222
2223 #|| This is incorrect, as it strives to keep strings around, when it
2224     shouldn't.  MERGE-PATHNAMES already DTRT.
2225 (defun append-logical-pnames (absolute relative)
2226   (declare (type (or null string pathname) absolute relative))
2227   (let ((abs (if absolute
2228                  #-clisp (namestring absolute)
2229                  #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
2230                  ""))
2231         (rel (if relative (namestring relative) ""))
2232         )
2233     ;; Make sure the absolute directory ends with a semicolon unless
2234     ;; the pieces are null strings
2235     (unless (or (null-string abs) (null-string rel)
2236                 (char= (char abs (1- (length abs)))
2237                        #\;))
2238       (setq abs (concatenate 'string abs ";")))
2239     ;; Return the concatenate pathnames
2240     (concatenate 'string abs rel)))
2241 ||#
2242
2243
2244 (defun append-logical-pnames (absolute relative)
2245   (declare (type (or null string pathname) absolute relative))
2246   (let ((abs (if absolute
2247                  (pathname absolute)
2248                  (make-pathname :directory (list :absolute)
2249                                 :name nil
2250                                 :type nil)
2251                  ))
2252         (rel (if relative
2253                  (pathname relative)
2254                  (make-pathname :directory (list :relative)
2255                                 :name nil
2256                                 :type nil)
2257                  ))
2258         )
2259     ;; The following is messed up because CMUCL and LW use different
2260     ;; defaults for host (in particular LW uses NIL).  Thus
2261     ;; MERGE-PATHNAMES has legitimate different behaviors on both
2262     ;; implementations. Of course this is disgusting, but that is the
2263     ;; way it is and the rest tries to circumvent this crap.
2264     (etypecase abs
2265       (logical-pathname
2266        (etypecase rel
2267          (logical-pathname
2268           (namestring (merge-pathnames rel abs)))
2269          (pathname
2270           ;; The following potentially translates the logical pathname
2271           ;; very early, but we cannot avoid it.
2272           (namestring (merge-pathnames rel (translate-logical-pathname abs))))
2273          ))
2274       (pathname
2275        (namestring (merge-pathnames rel abs)))
2276       )))
2277
2278 #||
2279 ;;; This was a try at appending a subdirectory onto a directory.
2280 ;;; It failed. We're keeping this around to prevent future mistakes
2281 ;;; of a similar sort.
2282 (defun merge-directories (absolute-directory relative-directory)
2283   ;; replace concatenate with something more intelligent
2284   ;; i.e., concatenation won't work with some directories.
2285   ;; it should also behave well if the parent directory
2286   ;; has a filename at the end, or if the relative-directory ain't relative
2287   (when absolute-directory
2288     (setq absolute-directory (pathname-directory absolute-directory)))
2289   (concatenate 'string
2290                (or absolute-directory "")
2291                (or relative-directory "")))
2292 ||#
2293
2294 #||
2295 <cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
2296
2297 D
2298 <cl> (d "~/foo/" "baz/bar.lisp")
2299 "/usr0/mkant/foo/baz/bar.lisp"
2300
2301 <cl> (d "~/foo" "baz/bar.lisp")
2302 "/usr0/mkant/foo/baz/bar.lisp"
2303
2304 <cl> (d "/foo/bar/" "baz/barf.lisp")
2305 "/foo/bar/baz/barf.lisp"
2306
2307 <cl> (d "foo/bar/" "baz/barf.lisp")
2308 "foo/bar/baz/barf.lisp"
2309
2310 <cl> (d "foo/bar" "baz/barf.lisp")
2311 "foo/bar/baz/barf.lisp"
2312
2313 <cl> (d "foo/bar" "/baz/barf.lisp")
2314 "foo/bar//baz/barf.lisp"
2315
2316 <cl> (d "foo/bar" nil)
2317 "foo/bar/"
2318
2319 <cl> (d nil "baz/barf.lisp")
2320 "baz/barf.lisp"
2321
2322 <cl> (d nil nil)
2323 ""
2324
2325 ||#
2326
2327 ;;; The following is a change proposed by DTC for SCL.
2328 ;;; Maybe it could be used all the time.
2329
2330 #-scl
2331 (defun new-file-type (pathname type)
2332   ;; why not (make-pathname :type type :defaults pathname)?
2333   (make-pathname
2334    :host (pathname-host pathname)
2335    :device (pathname-device pathname)
2336    :directory (pathname-directory pathname)
2337    :name (pathname-name pathname)
2338    :type type
2339    :version (pathname-version pathname)))
2340
2341
2342 #+scl
2343 (defun new-file-type (pathname type)
2344   ;; why not (make-pathname :type type :defaults pathname)?
2345   (make-pathname
2346    :host (pathname-host pathname :case :common)
2347    :device (pathname-device pathname :case :common)
2348    :directory (pathname-directory pathname :case :common)
2349    :name (pathname-name pathname :case :common)
2350    :type (string-upcase type)
2351    :version (pathname-version pathname :case :common)))
2352
2353
2354
2355 ;;; ********************************
2356 ;;; Component Defstruct ************
2357 ;;; ********************************
2358
2359 (defvar *source-pathname-default* nil
2360   "Default value of :source-pathname keyword in DEFSYSTEM. Set this to
2361    \"\" to avoid having to type :source-pathname \"\" all the time.")
2362
2363 (defvar *binary-pathname-default* nil
2364   "Default value of :binary-pathname keyword in DEFSYSTEM.")
2365
2366
2367 (defstruct (topological-sort-node (:conc-name topsort-))
2368   (color :white :type (member :gray :black :white))
2369   )
2370
2371
2372 (defparameter *component-evaluated-slots*
2373   '(:source-root-dir :source-pathname :source-extension
2374     :binary-root-dir :binary-pathname :binary-extension))
2375
2376
2377 (defparameter *component-form-slots*
2378   '(:initially-do :finally-do :compile-form :load-form))
2379
2380
2381 (defstruct (component (:include topological-sort-node)
2382                       (:print-function print-component))
2383   (type :file     ; to pacify the CMUCL compiler (:type is alway supplied)
2384         :type (member :defsystem
2385                       :system
2386                       :subsystem
2387                       :module
2388                       :file
2389                       :private-file
2390                       ))
2391   (name nil :type (or symbol string))
2392   (indent 0 :type (mod 1024))           ; Number of characters of indent in
2393                                         ; verbose output to the user.
2394   host                                  ; The pathname host (i.e., "/../a").
2395   device                                ; The pathname device.
2396   source-root-dir                       ; Relative or absolute (starts
2397                                         ; with "/"), directory or file
2398                                         ; (ends with "/").
2399   (source-pathname *source-pathname-default*)
2400   source-extension                      ; A string, e.g., "lisp"
2401                                         ; if NIL, inherit
2402   (binary-pathname *binary-pathname-default*)
2403   binary-root-dir
2404   binary-extension                      ; A string, e.g., "fasl". If
2405                                         ; NIL, uses default for
2406                                         ; machine-type.
2407   package                               ; Package for use-package.
2408
2409   ;; The following three slots are used to provide for alternate compilation
2410   ;; and loading functions for the files contained within a component. If
2411   ;; a component has a compiler or a loader specified, those functions are
2412   ;; used. Otherwise the functions are derived from the language. If no
2413   ;; language is specified, it defaults to Common Lisp (:lisp). Other current
2414   ;; possible languages include :scheme (PseudoScheme) and :c, but the user
2415   ;; can define additional language mappings. Compilation functions should
2416   ;; accept a pathname argument and a :output-file keyword; loading functions
2417   ;; just a pathname argument. The default functions are #'compile-file and
2418   ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to
2419   ;; mix languages.
2420   (language nil :type (or null symbol))
2421   (compiler nil :type (or null symbol function))
2422   (loader   nil :type (or null symbol function))
2423   (compiler-options nil :type list)     ; A list of compiler options to
2424                                         ; use for compiling this
2425                                         ; component.  These must be
2426                                         ; keyword options supported by
2427                                         ; the compiler.
2428
2429   (components () :type list)            ; A list of components
2430                                         ; comprising this component's
2431                                         ; definition.
2432   (depends-on () :type list)            ; A list of the components
2433                                         ; this one depends on. may
2434                                         ; refer only to the components
2435                                         ; at the same level as this
2436                                         ; one.
2437   proclamations                         ; Compiler options, such as
2438                                         ; '(optimize (safety 3)).
2439   (initially-do (lambda () nil))        ; Form to evaluate before the
2440                                         ; operation.
2441   (finally-do (lambda () nil))          ; Form to evaluate after the operation.
2442   (compile-form (lambda () nil))        ; For foreign libraries.
2443   (load-form (lambda () nil))           ; For foreign libraries.
2444
2445   ;; load-time                          ; The file-write-date of the
2446                                         ; binary/source file loaded.
2447
2448   ;; If load-only is T, will not compile the file on operation :compile.
2449   ;; In other words, for files which are :load-only T, loading the file
2450   ;; satisfies any demand to recompile.
2451   load-only                             ; If T, will not compile this
2452                                         ; file on operation :compile.
2453   ;; If compile-only is T, will not load the file on operation :compile.
2454   ;; Either compiles or loads the file, but not both. In other words,
2455   ;; compiling the file satisfies the demand to load it. This is useful
2456   ;; for PCL defmethod and defclass definitions, which wrap a
2457   ;; (eval-when (compile load eval) ...) around the body of the definition.
2458   ;; This saves time in some lisps.
2459   compile-only                          ; If T, will not load this
2460                                         ; file on operation :compile.
2461   #|| ISI Extension ||#
2462   load-always                           ; If T, will force loading
2463                                         ; even if file has not
2464                                         ; changed.
2465   ;; PVE: add banner
2466   (banner nil :type (or null string))
2467
2468   (documentation nil :type (or null string)) ; Optional documentation slot
2469   (long-documentation nil :type (or null string)) ; Optional long documentation slot
2470
2471   ;; Added AUTHOR, MAINTAINER, VERSION and LICENCE slots.
2472   (author nil :type (or null string))
2473   (licence nil :type (or null string))
2474   (maintainer nil :type (or null string))
2475   (version nil :type (or null string))
2476
2477   ;; Added NON-REQUIRED-P slot.  Useful for optional items.
2478   (non-required-p nil :type boolean)    ; If T a missing file or
2479                                         ; sub-directory will not cause
2480                                         ; an error.
2481   )
2482
2483
2484 ;;; To allow dependencies from "foreign systems" like ASDF or one of
2485 ;;; the proprietary ones like ACL or LW.
2486
2487 (defstruct (foreign-system (:include component (type :system)))
2488   kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...)
2489   object ; The actual foreign system object.
2490   )
2491
2492
2493 (defun register-foreign-system (name &key representation kind)
2494   (declare (type (or symbol string) name))
2495   (let ((fs (make-foreign-system :name name
2496                                  :kind kind
2497                                  :object representation)))
2498     (setf (get-system name) fs)))
2499
2500
2501
2502 (define-condition missing-component (simple-condition)
2503   ((name :reader missing-component-name
2504          :initarg :name)
2505    (component :reader missing-component-component
2506               :initarg :component)
2507    )
2508   #-gcl (:default-initargs :component nil)
2509   (:report (lambda (mmc stream)
2510              (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
2511                      (missing-component-name mmc)
2512                      (missing-component-component mmc))))
2513   )
2514
2515 (define-condition missing-module (missing-component)
2516   ()
2517   (:report (lambda (mmc stream)
2518              (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
2519                      (missing-component-name mmc)
2520                      (missing-component-component mmc))))
2521   )
2522
2523 (define-condition missing-system (missing-module)
2524   ()
2525   (:report (lambda (msc stream)
2526              (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
2527                      (missing-component-name msc)
2528                      (missing-component-component msc))))
2529   )
2530
2531
2532
2533 (defvar *file-load-time-table* (make-hash-table :test #'equal)
2534   "Hash table of file-write-dates for the system definitions and files in the system definitions.")
2535
2536
2537 (defun component-load-time (component)
2538   (when component
2539     (etypecase component
2540       (string    (gethash component *file-load-time-table*))
2541       (pathname (gethash (namestring component) *file-load-time-table*))
2542       (component
2543        (ecase (component-type component)
2544          (:defsystem
2545           (let* ((name (component-name component))
2546                  (path (when name (compute-system-path name nil))))
2547             (declare (type (or string pathname null) path))
2548             (when path
2549               (gethash (namestring path) *file-load-time-table*))))
2550          ((:file :private-file)
2551           ;; Use only :source pathname to identify component's
2552           ;; load time.
2553           (let ((path (component-full-pathname component :source)))
2554             (when path
2555               (gethash path *file-load-time-table*)))))))))
2556
2557 #-(or :cmu)
2558 (defsetf component-load-time (component) (value)
2559   `(when ,component
2560     (etypecase ,component
2561       (string   (setf (gethash ,component *file-load-time-table*) ,value))
2562       (pathname (setf (gethash (namestring (the pathname ,component))
2563                                *file-load-time-table*)
2564                       ,value))
2565       (component
2566        (ecase (component-type ,component)
2567          (:defsystem
2568           (let* ((name (component-name ,component))
2569                  (path (when name (compute-system-path name nil))))
2570             (declare (type (or string pathname null) path))
2571             (when path
2572               (setf (gethash (namestring path) *file-load-time-table*)
2573                     ,value))))
2574          ((:file :private-file)
2575           ;; Use only :source pathname to identify file.
2576           (let ((path (component-full-pathname ,component :source)))
2577             (when path
2578               (setf (gethash path *file-load-time-table*)
2579                     ,value)))))))
2580     ,value))
2581
2582 #+(or :cmu)
2583 (defun (setf component-load-time) (value component)
2584   (declare
2585    (type (or null string pathname component) component)
2586    (type (or unsigned-byte null) value))
2587   (when component
2588     (etypecase component
2589       (string   (setf (gethash component *file-load-time-table*) value))
2590       (pathname (setf (gethash (namestring (the pathname component))
2591                                *file-load-time-table*)
2592                       value))
2593       (component
2594        (ecase (component-type component)
2595          (:defsystem
2596              (let* ((name (component-name component))
2597                     (path (when name (compute-system-path name nil))))
2598                (declare (type (or string pathname null) path))
2599                (when path
2600                  (setf (gethash (namestring path) *file-load-time-table*)
2601                        value))))
2602          ((:file :private-file)
2603           ;; Use only :source pathname to identify file.
2604           (let ((path (component-full-pathname component :source)))
2605             (when path
2606               (setf (gethash path *file-load-time-table*)
2607                     value)))))))
2608     value))
2609
2610
2611 ;;; compute-system-path --
2612
2613 (defun compute-system-path (module-name definition-pname)
2614   (let* ((module-string-name
2615           (etypecase module-name
2616             (symbol (string-downcase
2617                      (string module-name)))
2618             (string module-name)))
2619
2620          (file-pathname
2621           (make-pathname :name module-string-name
2622                          :type *system-extension*))
2623
2624          (lib-file-pathname
2625           (make-pathname :directory (list :relative module-string-name)
2626                          :name module-string-name
2627                          :type *system-extension*))
2628          )
2629     (or (when definition-pname          ; given pathname for system def
2630           (probe-file definition-pname))
2631         ;; Then the central registry. Note that we also check the current
2632         ;; directory in the registry, but the above check is hard-coded.
2633         (cond (*central-registry*
2634                (if (listp *central-registry*)
2635                    (dolist (registry *central-registry*)
2636                      (let* ((reg-path (registry-pathname registry))
2637                             (file (or (probe-file
2638                                        (append-directories
2639                                         reg-path file-pathname))
2640                                       (probe-file
2641                                        (append-directories
2642                                         reg-path lib-file-pathname)))))
2643                        (when file (return file))))
2644                    (or (probe-file (append-directories *central-registry*
2645                                                        file-pathname))
2646                        (probe-file (append-directories *central-registry*
2647                                                        lib-file-pathname))
2648                        ))
2649                )
2650               (t
2651                ;; No central registry. Assume current working directory.
2652                ;; Maybe this should be an error?
2653                (or (probe-file file-pathname)
2654                    (probe-file lib-file-pathname)))))
2655     ))
2656
2657
2658 (defun system-definition-pathname (system-name)
2659   (let ((system (ignore-errors (find-system system-name :error))))
2660     (if system
2661         (let ((system-def-pathname
2662                (make-pathname
2663                 :type "system"
2664                 :defaults (pathname (component-full-pathname system :source))))
2665               )
2666           (values system-def-pathname
2667                   (probe-file system-def-pathname)))
2668         (values nil nil))))
2669
2670
2671
2672
2673 #|
2674
2675  (defun compute-system-path (module-name definition-pname)
2676   (let* ((filename (format nil "~A.~A"
2677                            (if (symbolp module-name)
2678                                (string-downcase (string module-name))
2679                              module-name)
2680                            *system-extension*)))
2681     (or (when definition-pname          ; given pathname for system def
2682           (probe-file definition-pname))
2683         ;; Then the central registry. Note that we also check the current
2684         ;; directory in the registry, but the above check is hard-coded.
2685         (cond (*central-registry*
2686                (if (listp *central-registry*)
2687                    (dolist (registry *central-registry*)
2688                      (let ((file (probe-file
2689                                   (append-directories
2690                                    (registry-pathname registry) filename))))
2691                        (when file (return file))))
2692                  (probe-file (append-directories *central-registry*
2693                                                  filename))))
2694               (t
2695                ;; No central registry. Assume current working directory.
2696                ;; Maybe this should be an error?
2697                (probe-file filename))))))
2698 |#
2699
2700
2701 (defvar *reload-systems-from-disk* t
2702   "If T, always tries to reload newer system definitions from disk.
2703    Otherwise first tries to find the system definition in the current
2704    environment.")
2705
2706 (defun find-system (system-name &optional (mode :ask) definition-pname)
2707   "Returns the system named SYSTEM-NAME.
2708 If not already loaded, loads it, depending on the value of
2709 *RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK,
2710 :ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default.
2711 This allows OPERATE-ON-SYSTEM to work on non-loaded as well as
2712 loaded system definitions. DEFINITION-PNAME is the pathname for
2713 the system definition, if provided."
2714   (ecase mode
2715     (:ask
2716      (or (get-system system-name)
2717          (when (y-or-n-p-wait
2718                 #\y 20
2719                 "System ~A not loaded. Shall I try loading it? "
2720                 system-name)
2721            (find-system system-name :load definition-pname))))
2722     (:error
2723      (or (get-system system-name)
2724          (error 'missing-system :name system-name)))
2725     (:load-or-nil
2726      (let ((system (get-system system-name)))
2727        ;; (break "System ~S ~S." system-name system)
2728        (or (unless *reload-systems-from-disk* system)
2729            ;; If SYSTEM-NAME is a symbol, it will lowercase the
2730            ;; symbol's string.
2731            ;; If SYSTEM-NAME is a string, it doesn't change the case of the
2732            ;; string. So if case matters in the filename, use strings, not
2733            ;; symbols, wherever the system is named.
2734            (when (foreign-system-p system)
2735              (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
2736                    system)
2737              (return-from find-system nil))
2738            (let ((path (compute-system-path system-name definition-pname)))
2739              (when (and path
2740                         (or (null system)
2741                             (null (component-load-time path))
2742                             (< (component-load-time path)
2743                                (file-write-date path))))
2744                (tell-user-generic
2745                 (format nil "Loading system ~A from file ~A"
2746                         system-name
2747                         path))
2748                (load path)
2749                (setf system (get-system system-name))
2750                (when system
2751                  (setf (component-load-time path)
2752                        (file-write-date path))))
2753              system)
2754            system)))
2755     (:load
2756      (or (unless *reload-systems-from-disk* (get-system system-name))
2757          (when (foreign-system-p (get-system system-name))
2758            (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
2759                  (get-system system-name))
2760            (return-from find-system nil))
2761          (or (find-system system-name :load-or-nil definition-pname)
2762              (error "Can't find system named ~s." system-name))))))
2763
2764
2765 (defun print-component (component stream depth)
2766   (declare (ignore depth))
2767   (format stream "#<~:@(~A~): ~A>"
2768           (component-type component)
2769           (component-name component)))
2770
2771
2772 (defun describe-system (name &optional (stream *standard-output*))
2773   "Prints a description of the system to the stream. If NAME is the
2774    name of a system, gets it and prints a description of the system.
2775    If NAME is a component, prints a description of the component."
2776   (let ((system (if (typep name 'component) name (find-system name :load))))
2777     (format stream "~&~A ~A: ~
2778                     ~@[~&   Host: ~A~]~
2779                     ~@[~&   Device: ~A~]~
2780                     ~@[~&   Package: ~A~]~
2781                     ~&   Source: ~@[~A~] ~@[~A~] ~@[~A~]~
2782                     ~&   Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
2783                     ~@[~&   Depends On: ~A ~]~&   Components:~{~15T~A~&~}"
2784             (component-type system)
2785             (component-name system)
2786             (component-host system)
2787             (component-device system)
2788             (component-package system)
2789             (component-root-dir system :source)
2790             (component-pathname system :source)
2791             (component-extension system :source)
2792             (component-root-dir system :binary)
2793             (component-pathname system :binary)
2794             (component-extension system :binary)
2795             (component-depends-on system)
2796             (component-components system))
2797     #||(when recursive
2798       (dolist (component (component-components system))
2799         (describe-system component stream recursive)))||#
2800     system))
2801
2802
2803 (defun canonicalize-component-name (component)
2804   ;; Within the component, the name is a string.
2805   (if (typep (component-name component) 'string)
2806       ;; Unnecessary to change it, so just return it, same case
2807       (component-name component)
2808     ;; Otherwise, make it a downcase string -- important since file
2809     ;; names are often constructed from component names, and unix
2810     ;; prefers lowercase as a default.
2811     (setf (component-name component)
2812           (string-downcase (string (component-name component))))))
2813
2814
2815 (defun component-pathname (component type)
2816   (when component
2817     (ecase type
2818       (:source (component-source-pathname component))
2819       (:binary (component-binary-pathname component))
2820       (:error  (component-error-pathname component)))))
2821
2822
2823 (defun component-error-pathname (component)
2824   (let ((binary (component-pathname component :binary)))
2825     (new-file-type binary *compile-error-file-type*)))
2826
2827 (defsetf component-pathname (component type) (value)
2828   `(when ,component
2829      (ecase ,type
2830        (:source (setf (component-source-pathname ,component) ,value))
2831        (:binary (setf (component-binary-pathname ,component) ,value)))))
2832
2833
2834 (defun component-root-dir (component type)
2835   (when component
2836     (ecase type
2837       (:source (component-source-root-dir component))
2838       ((:binary :error) (component-binary-root-dir component))
2839       )))
2840
2841 (defsetf component-root-dir (component type) (value)
2842   `(when ,component
2843      (ecase ,type
2844        (:source (setf (component-source-root-dir ,component) ,value))
2845        (:binary (setf (component-binary-root-dir ,component) ,value)))))
2846
2847
2848 (defvar *source-pathnames-table* (make-hash-table :test #'equal)
2849   "Table which maps from components to full source pathnames.")
2850
2851
2852 (defvar *binary-pathnames-table* (make-hash-table :test #'equal)
2853   "Table which maps from components to full binary pathnames.")
2854
2855
2856 (defparameter *reset-full-pathname-table* t
2857   "If T, clears the full-pathname tables before each call to OPERATE-ON-SYSTEM.
2858 Setting this to NIL may yield faster performance after multiple calls
2859 to LOAD-SYSTEM and COMPILE-SYSTEM, but could result in changes to
2860 system and language definitions to not take effect, and so should be
2861 used with caution.")
2862
2863
2864 (defun clear-full-pathname-tables ()
2865   (clrhash *source-pathnames-table*)
2866   (clrhash *binary-pathnames-table*))
2867
2868
2869 (defun component-full-pathname (component type &optional (version *version*))
2870   (when component
2871     (case type
2872       (:source
2873        (let ((old (gethash component *source-pathnames-table*)))
2874          (or old
2875              (let ((new (component-full-pathname-i component type version)))
2876                (setf (gethash component *source-pathnames-table*) new)
2877                new))))
2878       (:binary
2879         (let ((old (gethash component *binary-pathnames-table*)))
2880          (or old
2881              (let ((new (component-full-pathname-i component type version)))
2882                (setf (gethash component *binary-pathnames-table*) new)
2883                new))))
2884       (otherwise
2885        (component-full-pathname-i component type version)))))
2886
2887
2888 (defun component-full-pathname-i (component type
2889                                             &optional (version *version*)
2890                                             &aux version-dir version-replace)
2891   ;; If the pathname-type is :binary and the root pathname is null,
2892   ;; distribute the binaries among the sources (= use :source pathname).
2893   ;; This assumes that the component's :source pathname has been set
2894   ;; before the :binary one.
2895   (if version
2896       (multiple-value-setq (version-dir version-replace)
2897         (translate-version version))
2898       (setq version-dir *version-dir* version-replace *version-replace*))
2899   ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace)
2900   (let ((pathname
2901          (append-directories
2902           (if version-replace
2903               version-dir
2904               (append-directories (component-root-dir component type)
2905                                   version-dir))
2906           (component-pathname component type))))
2907
2908     ;; When a logical pathname is used, it must first be translated to
2909     ;; a physical pathname. This isn't strictly correct. What should happen
2910     ;; is we fill in the appropriate slots of the logical pathname, and
2911     ;; then return the logical pathname for use by compile-file & friends.
2912     ;; But calling translate-logical-pathname to return the actual pathname
2913     ;; should do for now.
2914
2915     ;; (format t "pathname = ~A~%" pathname)
2916     ;; (format t "type = ~S~%" (component-extension component type))
2917
2918     ;; 20000303 Marco Antoniotti
2919     ;; Changed the following according to suggestion by Ray Toy.  I
2920     ;; just collapsed the tests for "logical-pathname-ness" into a
2921     ;; single test (heavy, but probably very portable) and added the
2922     ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES
2923     ;; beacuse of possible null names (e.g. :defsystem components)
2924     ;; causing problems with the subsequenct call to NAMESTRING.
2925     ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname)
2926
2927     ;; 20050309 Marco Antoniotti
2928     ;; The treatment of PATHNAME-HOST and PATHNAME-DEVICE in the call
2929     ;; to MAKE-PATHNAME in the T branch is bogus.   COMPONENT-DEVICE
2930     ;; and COMPONENT-HOST must respect the ANSI definition, hence,
2931     ;; they cannot be PATHNAMEs.  The simplification of the code is
2932     ;; useful.  SCL compatibility may be broken, but I doubt it will.
2933
2934     ;; 20050310 Marco Antoniotti
2935     ;; After a suggestion by David Tolpin, the code is simplified even
2936     ;; more, and the logic should be now more clear: use the user
2937     ;; supplied pieces of the pathname if non nil.
2938
2939     ;; 20050613 Marco Antoniotti
2940     ;; Added COMPONENT-NAME extraction to :NAME part, in case the
2941     ;; PATHNAME-NAME is NIL.
2942
2943     (cond ((pathname-logical-p pathname) ; See definition of test above.
2944            (setf pathname
2945                  (merge-pathnames pathname
2946                                   (make-pathname
2947                                    :name (component-name component)
2948                                    :type (component-extension component
2949                                                               type))))
2950            (namestring (translate-logical-pathname pathname)))
2951           (t
2952            (namestring
2953             (make-pathname :host (or (component-host component)
2954                                      (pathname-host pathname))
2955
2956                            :directory (pathname-directory pathname
2957                                                           #+scl :case
2958                                                           #+scl :common
2959                                                           )
2960
2961                            :name (or (pathname-name pathname
2962                                                     #+scl :case
2963                                                     #+scl :common
2964                                                     )
2965                                      (component-name component))
2966
2967                            :type
2968                            #-scl (component-extension component type)
2969                            #+scl (string-upcase
2970                                   (component-extension component type))
2971
2972                            :device
2973                            #+sbcl
2974                            :unspecific
2975                            #-(or :sbcl)
2976                            (or (component-device component)
2977                                (pathname-device pathname
2978                                                 #+scl :case
2979                                                 #+scl :common
2980                                                 ))
2981                            ;; :version :newest
2982                            ))))))
2983
2984
2985 #-lispworks
2986 (defun translate-version (version)
2987   ;; Value returns the version directory and whether it replaces
2988   ;; the entire root (t) or is a subdirectory.