Fix ticket:62: Needed an IN-PACKAGE.
[projects/cmucl/cmucl.git] / src / contrib / defsystem / defsystem.lisp
36d9b3bc 1;;; -*- Mode: Lisp; Package: make -*-
2;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-
4;;; DEFSYSTEM 3.6 Interim.
6;;; defsystem.lisp --
98bb168c 7
8;;; ****************************************************************
9;;; MAKE -- A Portable Defsystem Implementation ********************
10;;; ****************************************************************
36d9b3bc 12;;; This is a portable system definition facility for Common Lisp.
98bb168c 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"
36d9b3bc 17;;; and "load-system" functions were taken from Xerox Corp.'s PCL
98bb168c 18;;; system.
20;;; This system improves on both PCL and Symbolics defsystem utilities
36d9b3bc 21;;; by performing a topological sort of the graph of file-dependency
98bb168c 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).
36d9b3bc 28;;; Originally written by Mark Kantrowitz, School of Computer Science,
98bb168c 29;;; Carnegie Mellon University, October 1989.
36d9b3bc 31;;; MK:DEFSYSTEM 3.6 Interim
33;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
34;;; 1999 - 2005 Mark Kantrowitz and Marco Antoniotti. All
35;;; rights reserved.
37;;; Use, copying, modification, merging, publishing, distribution
38;;; and/or sale of this software, source and/or binary files and
39;;; associated documentation files (the "Software") and of derivative
40;;; works based upon this Software are permitted, as long as the
41;;; following conditions are met:
43;;; o this copyright notice is included intact and is prominently
44;;; visible in the Software
45;;; o if modifications have been made to the source code of the
46;;; this package that have not been adopted for inclusion in the
47;;; official version of the Software as maintained by the Copyright
48;;; holders, then the modified package MUST CLEARLY identify that
49;;; such package is a non-standard and non-official version of
50;;; the Software. Furthermore, it is strongly encouraged that any
51;;; modifications made to the Software be sent via e-mail to the
52;;; MK-DEFSYSTEM maintainers for consideration of inclusion in the
53;;; official MK-DEFSYSTEM package.
63;;; Except as contained in this notice, the names of M. Kantrowitz and
64;;; M. Antoniotti shall not be used in advertising or otherwise to promote
65;;; the sale, use or other dealings in this Software without prior written
66;;; authorization from M. Kantrowitz and M. Antoniotti.
69;;; Please send bug reports, comments and suggestions to <>.
98bb168c 70\f
71;;; ********************************
72;;; Change Log *********************
73;;; ********************************
75;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in
36d9b3bc 76;;; September and October 1990, but not documented until January 1991.
98bb168c 77;;;
78;;; akd = Abdel Kader Diagne <>
79;;; as = Andreas Stolcke <stolcke@ICSI.Berkeley.EDU>
80;;; bha = Brian Anderson <>
81;;; brad = Brad Miller <>
82;;; bw = Robert Wilhelm <>
83;;; djc = Daniel J. Clancy <>
84;;; fdmm = Fernando D. Mato Mira <>
85;;; gc = Guillaume Cartier <>
86;;; gi = Gabriel Inaebnit <>
87;;; gpw = George Williams <>
88;;; hkt = Rick Taube <>
89;;; ik = Ik Su Yoo <>
90;;; jk = John_Kolojejchick@MORK.CIMDS.RI.CMU.EDU
91;;; kt = Kevin Thompson <>
92;;; kc = Kaelin Colclasure <>
36d9b3bc 93;;; kmr = Kevin M. Rosenberg <>
98bb168c 94;;; lmh = Liam M. Healy <>
95;;; mc = Matthew Cornell <>
96;;; oc = Oliver Christ <>
97;;; rs = Ralph P. Sobek <>
98;;; rs2 = Richard Segal <>
99;;; sb = Sean Boisen <>
100;;; ss = Steve Strassman <>
101;;; tar = Thomas A. Russ <>
102;;; toni = Anton Beschta <>
103;;; yc = Yang Chen <>
105;;; Thanks to Steve Strassmann <> and
36d9b3bc 106;;; Sean Boisen <sboisen@BBN.COM> for detailed bug reports and
98bb168c 107;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit
108;;; <> for help with VAXLisp bugs.
110;;; 05-NOV-90 hkt Changed canonicalize-system-name to make system
111;;; names package independent. Interns them in the
112;;; keyword package. Thus either strings or symbols may
113;;; be used to name systems from the user's point of view.
114;;; 05-NOV-90 hkt Added definition FIND-SYSTEM to allow OOS to
115;;; work on systems whose definition hasn't been loaded yet.
116;;; 05-NOV-90 hkt Added definitions COMPILE-SYSTEM and LOAD-SYSTEM
117;;; as alternates to OOS for naive users.
118;;; 05-NOV-90 hkt Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT]
119;;; into USER package instead of import.
120;;; 15-NOV-90 mk Changed package name to "MAKE", eliminating "DEFSYSTEM"
121;;; to avoid conflicts with allegro, symbolics packages
122;;; named "DEFSYSTEM".
36d9b3bc 123;;; 30-JAN-91 mk Modified append-directories to work with the
98bb168c 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.
36d9b3bc 163;;; Added :delete-binaries command.
98bb168c 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
36d9b3bc 200;;; a system depends on another, it can now recompile the
98bb168c 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
36d9b3bc 210;;; for PCL defmethod and defclass definitions, which wrap
98bb168c 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
36d9b3bc 219;;; modules. It's named :COMPILE-ONLY instead to match
98bb168c 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.
36d9b3bc 234;;; 12-MAR-91 brad Patches for Allegro 4.0.1 on Sparc.
98bb168c 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.
36d9b3bc 256;;; 21-MAR-91 gi Fixed bug in defined-systems.
98bb168c 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
36d9b3bc 273;;; want to load the source.
98bb168c 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
36d9b3bc 330;;; REQUIRE on ACL.
98bb168c 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
36d9b3bc 346;;; have a clean, easy to extend interface for telling
347;;; defsystem which language to assume for compilation.
98bb168c 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.
36d9b3bc 355;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed make-pathnames call fix
98bb168c 356;;; in NEW-APPEND-DIRECTORIES.
36d9b3bc 357;;; 16-DEC-94 fdmm Added HOME-SUBDIRECTORY to fix CMU's ignorance about `~'
98bb168c 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
36d9b3bc 368;;; pathnames.
98bb168c 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.
36d9b3bc 374;;; The system name specified in the :depends-on was a
98bb168c 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,
36d9b3bc 382;;; but a user error. It was intended as a feature to
98bb168c 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
36d9b3bc 389;;; in *modules* is now case-insensitive. The result of
98bb168c 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
36d9b3bc 399;;; of the same system.
98bb168c 400;;; 7-MAR-95 mk Added simplistic handling of logical pathnames. Also
401;;; modified new-append-directories so that it'll try to
36d9b3bc 402;;; split up pathname directories that are strings into a
98bb168c 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.
36d9b3bc 407;;; For example,
98bb168c 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.
36d9b3bc 431;;; 7-MAR-95 ss Miscellaneous fixes for MCL 2.0 final.
98bb168c 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
36d9b3bc 450;;; definition.
451;;; Where this comes in real handy is if one has a
98bb168c 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
36d9b3bc 487;;; which are absolute and which are relative.
98bb168c 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
36d9b3bc 505;;; COMMON-LISP::*UNIX-HOST*. So I haven't "fixed" this
98bb168c 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)
36d9b3bc 530;;; idiosyncracies.
98bb168c 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
36d9b3bc 535;;; code for multiple versions of it, and want less verbose
98bb168c 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.
36d9b3bc 544;;; 19990610 ma Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed.
546;;; 19991211 ma NEW VERSION 4.0 started.
547;;; 19991211 ma Merged in changes requested by T. Russ of
548;;; ISI. Please refer to the special "ISI" comments to
549;;; understand these changes
550;;; 20000228 ma The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM,
551;;; COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer
552;;; imported in the COMMON-LISP-USER package.
553;;; Cfr. the definitions of *EXPORTS* and
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
562;;; ISI Comments
564;;; 19991211 Marco Antoniotti
565;;; These comments come from the "ISI Branch". I believe I did
566;;; include the :load-always extension correctly. The other commets
567;;; seem superseded by other changes made to the system in the
568;;; following years. Some others are now useless with newer systems
569;;; (e.g. filename truncation for new Windows based CL
570;;; implementations.)
572;;; 1-OCT-92 tar Fixed problem with TI Lisp machines and append-directory.
573;;; 1-OCT-92 tar Made major modifications to compile-file-operation and
574;;; load-file-operation to reduce the number of probe-file
575;;; and write-date inquiries. This makes the system run much
576;;; faster through slow network connections.
577;;; 13-OCT-92 tar Added :load-always slot to components. If this slot is
578;;; specified as non-NIL, always loads the component.
579;;; This does not trigger dependent compilation.
580;;; (This can be useful when macro definitions needed
581;;; during compilation are changed by later files. In
582;;; this case, not reloading up-to-date files can
583;;; cause different results.)
584;;; 28-OCT-93 tar Allegro 4.2 causes an error on (pathname-device nil)
585;;; 14-SEP-94 tar Disable importing of symbols into (CL-)USER package
586;;; to minimize conflicts with other defsystem utilities.
587;;; 10-NOV-94 tar Added filename truncation code to support Franz Allegro
588;;; PC with it's 8 character filename limitation.
589;;; 15-MAY-98 tar Changed host attribute for pathnames to support LispWorks
590;;; (Windows) pathnames which reference other Drives. Also
591;;; updated file name convention.
592;;; 9-NOV-98 tar Updated new-append-directories for Lucid 5.0
98bb168c 594
596;;; ********************************
597;;; Ports **************************
598;;; ********************************
600;;; DEFSYSTEM has been tested (successfully) in the following lisps:
601;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
602;;; CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach)
603;;; CMU Common Lisp 17f (Python 1.0)
604;;; Franz Allegro Common Lisp 3.1.12 (ExCL 3/30/90)
605;;; Franz Allegro Common Lisp 4.0/4.1/4.2
606;;; Franz Allegro Common Lisp for Windows (2.0)
607;;; Lucid Common Lisp (Version 2.1 6-DEC-87)
36d9b3bc 608;;; Lucid Common Lisp (3.0 [SPARC,SUN3])
98bb168c 609;;; Lucid Common Lisp (4.0 [SPARC,SUN3])
610;;; VAXLisp (v2.2) [VAX/VMS]
611;;; VAXLisp (v3.1)
612;;; Harlequin LispWorks
614;;; Symbolics XL12000 (Genera 8.3)
36d9b3bc 615;;; Scieneer Common Lisp (SCL) 1.1
616;;; Macintosh Common Lisp
617;;; ECL
98bb168c 618;;;
619;;; DEFSYSTEM needs to be tested in the following lisps:
36d9b3bc 620;;; OpenMCL
98bb168c 621;;; Symbolics Common Lisp (8.0)
622;;; KCL (June 3, 1987 or later)
623;;; AKCL (1.86, June 30, 1987 or later)
624;;; TI (Release 4.1 or later)
625;;; Ibuki Common Lisp (01/01, October 15, 1987)
626;;; Golden Common Lisp (3.1 IBM-PC)
627;;; HP Common Lisp (same as Lucid?)
628;;; Procyon Common Lisp
630;;; ********************************
631;;; To Do **************************
36d9b3bc 632;;; ********************************
98bb168c 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
36d9b3bc 639;;; right now. Instead, I installed a temporary improvement by memoizing
98bb168c 640;;; COMPONENT-FULL-PATHNAME to cache previous calls to the function on
641;;; a component by component and type by type basis. The cache is
642;;; cleared before each call to OOS, in case filename extensions change.
643;;; But DEFSYSTEM should really be reworked to avoid this problem and
644;;; ensure greater portability and to also handle logical pathnames.
646;;; Also, PROBE-FILE and FILE-WRITE-DATE are other sources of slowness.
647;;; Perhaps by also memoizing FILE-WRITE-DATE and reimplementing PROBE-FILE
648;;; in terms of FILE-WRITE-DATE, can achieve a further speed-up. This was
649;;; suggested by Steven Feist (
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
36d9b3bc 653;;; (namestring #l"foo:bar;baz.lisp")
98bb168c 654;;; does not work properly.
656;;; Create separate stand-alone documentation for defsystem, and also
657;;; a test suite.
659;;; Change SYSTEM to be a class instead of a struct, and make it a little
660;;; more generic, so that it permits alternate system definitions.
661;;; Replace OPERATE-ON-SYSTEM with MAP-SYSTEM (args: function, system-name,
662;;; &rest options)
664;;; Add a patch directory mechanism. Perhaps have several directories
665;;; with code in them, and the first one with the specified file wins?
666;;; LOAD-PATCHES function.
668;;; Need way to load old binaries even if source is newer.
670;;; Allow defpackage forms/package definitions in the defsystem? If
671;;; a package not defined, look for and load a file named package.pkg?
673;;; need to port for GNU CL (ala kcl)?
675;;; Someone asked whether one can have :file components at top-level. I believe
676;;; this is the case, but should double-check that it is possible (and if
677;;; not, make it so).
679;;; A common error/misconception seems to involve assuming that :system
680;;; components should include the name of the system file, and that
36d9b3bc 681;;; defsystem will automatically load the file containing the system
682;;; definition and propagate operations to it. Perhaps this would be a
98bb168c 683;;; nice feature to add.
685;;; If a module is :load-only t, then it should not execute its :finally-do
686;;; and :initially-do clauses during compilation operations, unless the
687;;; module's files happen to be loaded during the operation.
689;;; System Class. Customizable delimiters.
691;;; Load a system (while not loading anything already loaded)
692;;; and inform the user of out of date fasls with the choice
693;;; to load the old fasl or recompile and then load the new
694;;; fasl?
36d9b3bc 695;;;
98bb168c 696;;; modify compile-file-operation to handle a query keyword....
698;;; Perhaps systems should keep around the file-write-date of the system
699;;; definition file, to prevent excessive reloading of the system definition?
701;;; load-file-operation needs to be completely reworked to simplify the
702;;; logic of when files get loaded or not.
704;;; Need to revamp output: Nesting and indenting verbose output doesn't
705;;; seem cool, especially when output overflows the 80-column margins.
707;;; Document various ways of writing a system. simple (short) form
708;;; (where :components is just a list of filenames) in addition to verbose.
709;;; Put documentation strings in code.
711;;; :load-time for modules and systems -- maybe record the time the system
712;;; was loaded/compiled here and print it in describe-system?
36d9b3bc 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,
98bb168c 716;;; hardcopy-system, edit-system, etc.
36d9b3bc 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
98bb168c 721;;; uniform underlying format (i.e., pull the relevant code out of
722;;; logical-pathnames.lisp and clean it up a bit).
724;;; Verify that Mac pathnames now work with append-directories.
726;;; A common human error is to violate the modularization by making a file
727;;; in one module depend on a file in another module, instead of making
728;;; one module depend on the other. This is caught because the dependency
729;;; isn't found. However, is there any way to provide a more informative
730;;; error message? Probably not, especially if the system has multiple
731;;; files of the same name.
36d9b3bc 732;;;
98bb168c 733;;; For a module none of whose files needed to be compiled, have it print out
734;;; "no files need recompilation".
36d9b3bc 735;;;
98bb168c 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
36d9b3bc 739;;; the version numbers of the associated files.
98bb168c 741;;; Add idea of a patch directory.
36d9b3bc 742;;;
98bb168c 743;;; In verbose printout, have it log a date/time at start and end of
36d9b3bc 744;;; compilation:
745;;; Compiling system "test" on 31-Jan-91 21:46:47
98bb168c 746;;; by Defsystem version v2.0 01-FEB-91.
36d9b3bc 747;;;
98bb168c 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
36d9b3bc 753;;;
98bb168c 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,
36d9b3bc 761;;; while making defsystem much more complex than it already is.
98bb168c 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?
36d9b3bc 767;;;
98bb168c 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 <> 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
36d9b3bc 778;;; depends directly or indirectly on a module (or file) that is newer.
98bb168c 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
36d9b3bc 788;;; should be sufficient.) This will affect not just the
789;;; compile-file-operation, but also the load-file-operation because of
98bb168c 790;;; compilation during load. Also, since FWDs will be used more prevalently,
791;;; we probably should couple this change with the inclusion of load-times
792;;; in the component defstruct. This is a tricky and involved change, and
793;;; requires more thought, since there are subtle cases where it might not
794;;; be correct. For now, the change will have to wait until the DEFSYSTEM
795;;; redesign.
797;;; ********************************************************************
798;;; How to Use this System *********************************************
799;;; ********************************************************************
801;;; To use this system,
36d9b3bc 802;;; 1. If you want to have a central registry of system definitions,
98bb168c 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.
36d9b3bc 808;;; For more information, see the documentation and examples in
98bb168c 809;;;
811;;; ********************************
812;;; Usage Comments *****************
813;;; ********************************
36d9b3bc 815;;; If you use symbols in the system definition file, they get interned in
98bb168c 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
36d9b3bc 819;;; names of components in the system definition file. In the major overhaul,
98bb168c 820;;; perhaps the user should be precluded from using symbols for such
821;;; identifiers.
823;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp",
36d9b3bc 824;;; file name expansion is much slower than if you use the full pathname,
98bb168c 825;;; as in "/user/USERID/lisp".
829;;; ****************************************************************
830;;; Lisp Code ******************************************************
831;;; ****************************************************************
833;;; ********************************
834;;; Massage CLtL2 onto *features* **
835;;; ********************************
836;;; Let's be smart about CLtL2 compatible Lisps:
837(eval-when (compile load eval)
36d9b3bc 838 #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl)
98bb168c 839 (pushnew :cltl2 *features*))
841;;; ********************************
842;;; Provide/Require/*modules* ******
843;;; ********************************
845;;; Since CLtL2 has dropped require and provide from the language, some
846;;; lisps may not have the functions PROVIDE and REQUIRE and the
847;;; global *MODULES*. So if lisp::provide and user::provide are not
848;;; defined, we define our own.
850;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions
851;;; and variables not being declared or bound, apparently because it
852;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns
853;;; T, so it doesn't really bother when compiling the body of the unless.
854;;; The new compiler does this properly, so I'm not going to bother
855;;; working around this.
857;;; Some Lisp implementations return bogus warnings about assuming
859;;; and MODULE-FILES being undefined. Don't worry about them.
861;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code
36d9b3bc 862;;; necessary?
864#-(or :CMU
865 :vms
866 :mcl
867 :lispworks
868 :clisp
869 :gcl
870 :sbcl
871 :cormanlisp
872 :scl
98bb168c 873 (and allegro-version>= (version>= 4 1)))
36d9b3bc 874(eval-when #-(or :lucid)
875 (:compile-toplevel :load-toplevel :execute)
876 #+(or :lucid)
877 (compile load eval)
879 (unless (or (fboundp 'lisp::require)
880 (fboundp 'user::require)
98bb168c 882 #+(and :excl (and allegro-version>= (version>= 4 0)))
883 (fboundp 'cltl1::require)
36d9b3bc 884
885 #+:lispworks
886 (fboundp 'system::require))
888 #-:lispworks
98bb168c 889 (in-package "LISP")
36d9b3bc 890 #+:lispworks
98bb168c 891 (in-package "SYSTEM")
893 (export '(*modules* provide require))
895 ;; Documentation strings taken almost literally from CLtL1.
36d9b3bc 896
897 (defvar *modules* ()
98bb168c 898 "List of names of the modules that have been loaded into Lisp so far.
899 It is used by PROVIDE and REQUIRE.")
901 ;; We provide two different ways to define modules. The default way
902 ;; is to put either a source or binary file with the same name
903 ;; as the module in the library directory. The other way is to define
904 ;; the list of files in the module with defmodule.
906 ;; The directory listed in *library* is implementation dependent,
907 ;; and is intended to be used by Lisp manufacturers as a place to
36d9b3bc 908 ;; store their implementation dependent packages.
98bb168c 909 ;; Lisp users should use systems and *central-registry* to store
910 ;; their packages -- it is intended that *central-registry* is
911 ;; set by the user, while *library* is set by the lisp.
913 (defvar *library* nil ; "/usr/local/lisp/Modules/"
914 "Directory within the file system containing files, where the name
915 of a file is the same as the name of the module it contains.")
917 (defvar *module-files* (make-hash-table :test #'equal)
918 "Hash table mapping from module names to list of files for the
919 module. REQUIRE loads these files in order.")
36d9b3bc 920
98bb168c 921 (defun canonicalize-module-name (name)
922 ;; if symbol, string-downcase the printrep to make nicer filenames.
923 (if (stringp name) name (string-downcase (string name))))
925 (defmacro defmodule (name &rest files)
926 "Defines a module NAME to load the specified FILES in order."
927 `(setf (gethash (canonicalize-module-name ,name) *module-files*)
928 ',files))
929 (defun module-files (name)
930 (gethash name *module-files*))
36d9b3bc 932 (defun provide (name)
98bb168c 933 "Adds a new module name to the list of modules maintained in the
36d9b3bc 934 variable *modules*, thereby indicating that the module has been
98bb168c 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=)
36d9b3bc 940 ;; Module not present. Add it and return T to signify that it
98bb168c 941 ;; was added.
942 (push module *modules*)
943 t)))
36d9b3bc 945 (defun require (name &optional pathname)
98bb168c 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)))
36d9b3bc 960 (unless pathname
98bb168c 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.
36d9b3bc 968 ;; We assume that the lisp will default the file type
98bb168c 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.
36d9b3bc 978 (dolist (pname pathname t)
979 (load pname :verbose nil))))))
980 ) ; eval-when
98bb168c 981
982;;; ********************************
983;;; Set up Package *****************
984;;; ********************************
987;;; Unfortunately, lots of lisps have their own defsystems, some more
988;;; primitive than others, all uncompatible, and all in the DEFSYSTEM
989;;; package. To avoid name conflicts, we've decided to name this the
990;;; MAKE package. A nice side-effect is that the short nickname
991;;; MK is my initials.
36d9b3bc 993#+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
994(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
996#-(or :sbcl :cltl2 :lispworks :ecl :scl)
98bb168c 997(in-package "MAKE" :nicknames '("MK"))
999;;; For CLtL2 compatible lisps...
36d9b3bc 1000#+(and :excl :allegro-v4.0 :cltl2)
1001(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
98bb168c 1002 (:import-from cltl1 *modules* provide require))
36d9b3bc 1004;;; *** Marco Antoniotti <> 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) )
98bb168c 1010#+(and :excl :allegro-version>= (version>= 4 2))
36d9b3bc 1011(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp))
1014(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
1015 (:import-from "SYSTEM" *modules* provide require)
36d9b3bc 1019#+:mcl
1020(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
98bb168c 1021 (:import-from ccl *modules* provide require))
36d9b3bc 1022
1023;;; *** Marco Antoniotti <> 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)))
98bb168c 1030(eval-when (compile load eval)
36d9b3bc 1031 (unless (find-package "MAKE")
98bb168c 1032 (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))
36d9b3bc 1034;;; *** Marco Antoniotti <> 19951012
1035;;; Here I add the proper defpackage for CMU
1037(defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
1038 (:nicknames "MK")
1041 "FIND-SYSTEM"))
36d9b3bc 1042
1044(defpackage "MAKE" (:use "COMMON-LISP")
1045 (:nicknames "MK"))
1048(defpackage :make (:use :common-lisp)
1049 (:nicknames :mk))
1051#+(or :cltl2 :lispworks :scl)
98bb168c 1052(eval-when (compile load eval)
1053 (in-package "MAKE"))
1a44615f 1055#+(or ecl cmu)
36d9b3bc 1056(in-package "MAKE")
1058;;; *** Marco Antoniotti <> 19970105
1059;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
1060#+(and :excl :allegro-v4.0 :cltl2)
98bb168c 1061(cltl1:provide 'make)
36d9b3bc 1062#+(and :excl :allegro-v4.0 :cltl2)
1063(provide 'make)
1066(cl:provide 'make)
1068#+(and :mcl (not :openmcl))
98bb168c 1069(ccl:provide 'make)
36d9b3bc 1070
98bb168c 1071#+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)))
1072(provide 'make)
36d9b3bc 1073
98bb168c 1075(provide 'make)
36d9b3bc 1076
98bb168c 1077#-(or :cltl2 :lispworks)
6a53ead7 1078(progn
1079 (provide 'make)
1080 (provide 'defsystem))
98bb168c 1081
1082(pushnew :mk-defsystem *features*)
36d9b3bc 1084;;; Some compatibility issues. Mostly for CormanLisp.
1085;;; 2002-02-20 Marco Antoniotti
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 )))
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)))))
98bb168c 1108;;; The external interface consists of *exports* and *other-exports*.
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
36d9b3bc 1112;;; then a succeeding export as well.
98bb168c 1114(eval-when (compile load eval)
36d9b3bc 1115 (defvar *special-exports* nil)
1116 (defvar *exports* nil)
1117 (defvar *other-exports* nil)
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*
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
1136 system-definition-pathname
1138 missing-component
1139 missing-component-name
1140 missing-component-component
1141 missing-module
1142 missing-system
1144 register-foreign-system
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*
1167 run-unix-program
1168 *default-shell*
1169 run-shell-command
1170 )))
1171 )
98bb168c 1172
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.
36d9b3bc 1177#|
1178#-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
98bb168c 1179(eval-when (compile load eval)
1180 (import *exports* #-(or :cltl2 :lispworks) "USER"
1181 #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
36d9b3bc 1182 (import *special-exports* #-(or :cltl2 :lispworks) "USER"
98bb168c 1183 #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
36d9b3bc 1184#+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
98bb168c 1185(eval-when (compile load eval)
36d9b3bc 1186 (import *exports* #-(or :cltl2 :lispworks) "USER"
98bb168c 1187 #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
36d9b3bc 1188 (shadowing-import *special-exports*
1189 #-(or :cltl2 :lispworks) "USER"
98bb168c 1190 #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
36d9b3bc 1191|#
98bb168c 1192
36d9b3bc 1193#-(or :PCL :CLOS :scl)
1194(when (find-package "PCL")
98bb168c 1195 (pushnew :pcl *modules*)
1196 (pushnew :pcl *features*))
36d9b3bc 1198
98bb168c 1199;;; ********************************
1200;;; Defsystem Version **************
1201;;; ********************************
36d9b3bc 1202(defparameter *defsystem-version* "3.6 Interim, 2008-12-18"
1203 "Current version number/date for MK:DEFSYSTEM.")
98bb168c 1205
1206;;; ********************************
1207;;; Customizable System Parameters *
1208;;; ********************************
36d9b3bc 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.
1216This is useful for lisps that treat REQUIRE specially in the compiler.")
98bb168c 1218
1219(defvar *multiple-lisp-support* t
1220 "If T, afs-binary-directory will try to return a name dependent
36d9b3bc 1221on the particular lisp compiler version being used.")
98bb168c 1223
36d9b3bc 1224;;; home-subdirectory --
98bb168c 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.
36d9b3bc 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.
98bb168c 1237(defun home-subdirectory (directory)
1238 (concatenate 'string
36d9b3bc 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 "~/"))
98bb168c 1245 directory))
36d9b3bc 1247
1249(defun home-subdirectory (directory)
1250 (declare (type string directory))
1251 (concatenate 'string "C:\\" directory))
98bb168c 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.
36d9b3bc 1258
98bb168c 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))
36d9b3bc 1266
98bb168c 1267;;; Change this variable to set up the location of a central
1268;;; repository for system definitions if you want one.
36d9b3bc 1269;;; This is a defvar to allow users to change the value in their
98bb168c 1270;;; lisp init files without worrying about it reverting if they
1271;;; reload defsystem for some reason.
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.
36d9b3bc 1276(defvar *central-registry*
98bb168c 1277 `(;; Current directory
1278 "./"
36d9b3bc 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 <>
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)
98bb168c 1297 (and (= major 3) (> minor 2))
1298 (and (= major 3) (= minor 2)
1299 (equal (lisp-implementation-version) "3.2.1")))
36d9b3bc 1300 `(make-pathname :directory
98bb168c 1301 ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
1302 (find-package "SYSTEM")))
36d9b3bc 1303 (find-symbol "*CURRENT-WORKING-DIRECTORY*"
1304 (find-package "LW"))))
1305 #+(or :lispworks4 :lispworks5)
1306 (hcl:get-working-directory)
98bb168c 1307 ;; Home directory
36d9b3bc 1308 #-sbcl
98bb168c 1309 (mk::home-subdirectory "lisp/systems/")
1311 ;; Global registry
36d9b3bc 1312 #+unix (pathname "/usr/local/lisp/Registry/")
1313 )
1314 "Central directory of system definitions.
1315May be either a single directory pathname, or a list of directory
1316pathnames to be checked after the local directory.")
1319(defun add-registry-location (pathname)
1320 "Adds a path to the central registry."
1321 (pushnew pathname *central-registry* :test #'equal))
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)))))
1332(defun print-central-registry-directories (&optional (stream *standard-output*))
1333 (dolist (registry *central-registry*)
1334 (print (registry-pathname registry) stream)))
1337(defun list-central-registry-directories ()
1338 (mapcar #'registry-pathname *central-registry*))
98bb168c 1340
1341(defvar *bin-subdir* ".bin/"
1342 "The subdirectory of an AFS directory where the binaries are really kept.")
36d9b3bc 1344
1345;;; These variables set up defaults for operate-on-system, and are used
98bb168c 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?
36d9b3bc 1350
98bb168c 1351(defvar *tell-user-when-done* nil
1352 "If T, system will print ...DONE at the end of an operation")
36d9b3bc 1353
1354(defvar *oos-verbose* nil
98bb168c 1355 "Operate on System Verbose Mode")
36d9b3bc 1356
1357(defvar *oos-test* nil
98bb168c 1358 "Operate on System Test Mode")
36d9b3bc 1359
98bb168c 1360(defvar *load-source-if-no-binary* nil
1361 "If T, system will try loading the source if the binary is missing")
36d9b3bc 1362
98bb168c 1363(defvar *bother-user-if-no-binary* t
36d9b3bc 1364 "If T, the system will ask the user whether to load the source if
98bb168c 1365 the binary is missing")
36d9b3bc 1366
98bb168c 1367(defvar *load-source-instead-of-binary* nil
1368 "If T, the system will load the source file instead of the binary.")
36d9b3bc 1369
98bb168c 1370(defvar *compile-during-load* :query
1371 "If T, the system will compile source files during load if the
36d9b3bc 1372binary file is missing. If :query, it will ask the user for
1373permission first.")
98bb168c 1375(defvar *minimal-load* nil
1376 "If T, the system tries to avoid reloading files that were already loaded
36d9b3bc 1377and up to date.")
98bb168c 1378
1379(defvar *files-missing-is-an-error* t
36d9b3bc 1380 "If both the source and binary files are missing, signal a continuable
98bb168c 1381 error instead of just a warning.")
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.")
1388;;; Particular to CMULisp
36d9b3bc 1389
98bb168c 1390(defvar *compile-error-file-type* "err"
1391 "File type of compilation error file in cmulisp")
36d9b3bc 1392
98bb168c 1393(defvar *cmu-errors-to-terminal* t
1394 "Argument to :errors-to-terminal in compile-file in cmulisp")
36d9b3bc 1395
98bb168c 1396(defvar *cmu-errors-to-file* t
1397 "If T, cmulisp will write an error file during compilation")
36d9b3bc 1399
98bb168c 1400;;; ********************************
1401;;; Global Variables ***************
1402;;; ********************************
1404;;; Massage people's *features* into better shape.
36d9b3bc 1405(eval-when (compile load eval)
98bb168c 1406 (dolist (feature *features*)
1407 (when (and (symbolp feature) ; 3600
1408 (equal (symbol-name feature) "CMU"))
1409 (pushnew :CMU *features*)))
36d9b3bc 1410
98bb168c 1411 #+Lucid
1412 (when (search "IBM RT PC" (machine-type))
1413 (pushnew :ibm-rt-pc *features*))
1414 )
36d9b3bc 1416
98bb168c 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")
36d9b3bc 1423 #+CLISP ("lisp" . "fas")
98bb168c 1424 #+KCL ("lsp" . "o")
36d9b3bc 1425 ;;#+ECL ("lsp" . "so")
98bb168c 1426 #+IBCL ("lsp" . "o")
1427 #+Xerox ("lisp" . "dfasl")
1428 ;; Lucid on Silicon Graphics
36d9b3bc 1429 #+(and Lucid MIPS) ("lisp" . "mbin")
98bb168c 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")
36d9b3bc 1436 #+(and Lucid Vax) ("lisp" . "vbin")
98bb168c 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
36d9b3bc 1442 #+(and Lucid PA) ("lisp" . "hbin")
1443 #+excl ("cl" . ,(pathname-type (compile-file-pathname "")))
1444 #+(or :cmu :scl) ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
98bb168c 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")
36d9b3bc 1453
98bb168c 1454 ;; Harlequin LispWorks
1455 #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
1456; #+(and :sun4 :lispworks) ("lisp" . "wfasl")
1457; #+(and :mips :lispworks) ("lisp" . "mfasl")
36d9b3bc 1458 #+:mcl ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
1459 #+:coral ("lisp" . "fasl")
98bb168c 1460
36d9b3bc 1461 ;; Otherwise,
1462 ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
1463 "Filename extensions for Common Lisp.
1464A cons of the form (Source-Extension . Binary-Extension). If the
1465system is unknown (as in *features* not known), defaults to lisp and
98bb168c 1467
1468(defvar *system-extension*
1469 ;; MS-DOS systems can only handle three character extensions.
1470 #-ACLPC "system"
36d9b3bc 1471 #+ACLPC "sys"
98bb168c 1472 "The filename extension to use with systems.")
98bb168c 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
36d9b3bc 1479;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and
1480;;; "lsp" (*load-source-types*) as source code extensions, and
98bb168c 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*).
1485;;; Note that the above code is used below in the LANGUAGE defstruct.
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.
36d9b3bc 1491
1492(defvar *system-dependencies-delayed* t
98bb168c 1493 "If T, system dependencies are expanded at run time")
36d9b3bc 1495
98bb168c 1496;;; Replace this with consp, dammit!
1497(defun non-empty-listp (list)
1498 (and list (listp list)))
36d9b3bc 1500
98bb168c 1501;;; ********************************
1502;;; Component Operation Definition *
1503;;; ********************************
36d9b3bc 1504(eval-when (:compile-toplevel :load-toplevel :execute)
98bb168c 1506(defvar *version-dir* nil
1507 "The version subdir. bound in operate-on-system.")
36d9b3bc 1508
98bb168c 1509(defvar *version-replace* nil
1510 "The version replace. bound in operate-on-system.")
36d9b3bc 1511
98bb168c 1512(defvar *version* nil
36d9b3bc 1513 "Default version."))
98bb168c 1514
1515(defvar *component-operations* (make-hash-table :test #'equal)
1516 "Hash table of (operation-name function) pairs.")
36d9b3bc 1517
98bb168c 1518(defun component-operation (name &optional operation)
1519 (if operation
1520 (setf (gethash name *component-operations*) operation)
1521 (gethash name *component-operations*)))
36d9b3bc 1523
98bb168c 1524;;; ********************************
1525;;; AFS @sys immitator *************
1526;;; ********************************
1528;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.
36d9b3bc 1529#-:mcl
98bb168c 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/"
36d9b3bc 1535 (set-dispatch-macro-character
1536 #\# #\@
98bb168c 1537 #'(lambda (stream char arg)
1538 (declare (ignore char arg))
1539 `(afs-binary-directory ,(read stream t nil t)))))
36d9b3bc 1541
1542(defvar *find-irix-version-script*
98bb168c 1543 "\"1,4 d\\
1544s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
1545/./,$ d\\
36d9b3bc 1548
98bb168c 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))
36d9b3bc 1554 (version-rest (subseq full-version
98bb168c 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
36d9b3bc 1569 #+(and :sgi :cmu :sbcl)
98bb168c 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
36d9b3bc 1577 (foreign:call-system
98bb168c 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))
36d9b3bc 1590
98bb168c 1591(defun compiler-version ()
36d9b3bc 1592 #+:lispworks (concatenate 'string
98bb168c 1593 "lispworks" " " (lisp-implementation-version))
36d9b3bc 1594 #+excl (concatenate 'string
1595 "excl" " " excl::*common-lisp-version-number*)
1596 #+sbcl (concatenate 'string
1597 "sbcl" " " (lisp-implementation-version))
1598 #+cmu (concatenate 'string
98bb168c 1599 "cmu" " " (lisp-implementation-version))
36d9b3bc 1600 #+scl (concatenate 'string
1601 "scl" " " (lisp-implementation-version))
98bb168c 1603 #+kcl "kcl"
36d9b3bc 1604 #+IBCL "ibcl"
98bb168c 1605 #+akcl "akcl"
1606 #+gcl "gcl"
36d9b3bc 1607 #+ecl "ecl"
98bb168c 1608 #+lucid "lucid"
1609 #+ACLPC "aclpc"
1610 #+CLISP "clisp"
98bb168c 1611 #+Xerox "xerox"
1612 #+symbolics "symbolics"
1613 #+mcl "mcl"
1614 #+coral "coral"
1615 #+gclisp "gclisp"
1616 )
36d9b3bc 1617
98bb168c 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)))
36d9b3bc 1629 (software (software-type-translation
1630 #-(and :sgi (or :cmu :sbcl :scl
1631 (and :allegro-version>= (version>= 4 2))))
98bb168c 1632 (software-type)
36d9b3bc 1633 #+(and :sgi (or :cmu :sbcl :scl
98bb168c 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))
36d9b3bc 1640 (format nil "~A~@[~A~]~@[~A/~]"
98bb168c 1641 root-directory
1642 *bin-subdir*
1643 (if *multiple-lisp-support*
1644 (afs-component machine software lisp)
1645 (afs-component machine software)))))
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))
36d9b3bc 1653 (format nil "~A~@[~A/~]"
98bb168c 1654 root-directory
1655 (and version-flag (translate-version *version*))))
36d9b3bc 1657
98bb168c 1658(defun null-string (s)
1659 (when (stringp s)
1660 (string-equal s "")))
36d9b3bc 1662
98bb168c 1663(defun ensure-trailing-slash (dir)
36d9b3bc 1664 (if (and dir
98bb168c 1665 (not (null-string dir))
1666 (not (char= (char dir
1667 (1- (length dir)))
36d9b3bc 1668 #\/))
1669 (not (char= (char dir
1670 (1- (length dir)))
1671 #\\))
1672 )
98bb168c 1673 (concatenate 'string dir "/")
1674 dir))
36d9b3bc 1676
98bb168c 1677(defun afs-component (machine software &optional lisp)
36d9b3bc 1678 (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
1679 machine
98bb168c 1680 (or software "mach")
1681 lisp))
36d9b3bc 1683
98bb168c 1684(defvar *machine-type-alist* (make-hash-table :test #'equal)
1685 "Hash table for retrieving the machine-type")
36d9b3bc 1686
98bb168c 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*)))
36d9b3bc 1692
98bb168c 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")
36d9b3bc 1705(machine-type-translation "IP22" "sgi")
98bb168c 1706;;; MIPS R4000 Processor Chip Revision: 3.0
1707;;; MIPS R4400 Processor Chip Revision: 5.0
1708;;; MIPS R4600 Processor Chip Revision: 1.0
36d9b3bc 1709(machine-type-translation "IP20" "sgi")
98bb168c 1710;;; MIPS R4000 Processor Chip Revision: 3.0
36d9b3bc 1711(machine-type-translation "IP17" "sgi")
98bb168c 1712;;; MIPS R4000 Processor Chip Revision: 2.2
36d9b3bc 1713(machine-type-translation "IP12" "sgi")
98bb168c 1714;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
36d9b3bc 1715(machine-type-translation "IP7" "sgi")
98bb168c 1716;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
36d9b3bc 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
98bb168c 1727#+(and :lucid :sun :mc68000)
1728(machine-type-translation "unknown" "sun3")
36d9b3bc 1729
98bb168c 1730
1731(defvar *software-type-alist* (make-hash-table :test #'equal)
1732 "Hash table for retrieving the software-type")
36d9b3bc 1733
98bb168c 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*)))
36d9b3bc 1739
98bb168c 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)
36d9b3bc 1748(software-type-translation "IRIX 5.2" "irix5")
1749(software-type-translation "IRIX 5.3" "irix5")
98bb168c 1750(software-type-translation "IRIX5.2" "irix5")
1751(software-type-translation "IRIX5.3" "irix5")
36d9b3bc 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
98bb168c 1760(software-type-translation nil "")
36d9b3bc 1763(software-type-translation "Unix"
98bb168c 1764 #+:lcl4.0 "4.0"
1765 #+(and :lcl3.0 (not :lcl4.0)) "3.0")
36d9b3bc 1767
98bb168c 1768(defvar *compiler-type-alist* (make-hash-table :test #'equal)
1769 "Hash table for retrieving the Common Lisp type")
36d9b3bc 1770
98bb168c 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*)))
36d9b3bc 1776
98bb168c 1777(compiler-type-translation "lispworks 3.2.1" "lispworks")
1778(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
36d9b3bc 1779(compiler-type-translation "lispworks 4.2.0" "lispworks")
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*))))
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")
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")
98bb168c 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")
36d9b3bc 1808
98bb168c 1809;;; ********************************
1810;;; System Names *******************
1811;;; ********************************
1813;;; If you use strings for system names, be sure to use the same case
36d9b3bc 1814;;; as it appears on disk, if the filesystem is case sensitive.
98bb168c 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.)
36d9b3bc 1823 #||(if (keywordp name)
98bb168c 1824 name
36d9b3bc 1825 (intern (string-upcase (string name)) "KEYWORD"))||#
98bb168c 1826 (if (stringp name) (string-upcase name) (string-upcase (string name))))
36d9b3bc 1828
98bb168c 1829(defvar *defined-systems* (make-hash-table :test #'equal)
1830 "Hash table containing the definitions of all known systems.")
36d9b3bc 1832
98bb168c 1833(defun get-system (name)
1834 "Returns the definition of the system named NAME."
1835 (gethash (canonicalize-system-name name) *defined-systems*))
36d9b3bc 1837
98bb168c 1838(defsetf get-system (name) (value)
1839 `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))
36d9b3bc 1841
98bb168c 1842(defun undefsystem (name)
1843 "Removes the definition of the system named NAME."
36d9b3bc 1844 (remhash (canonicalize-system-name name) *defined-systems*))
98bb168c 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))
36d9b3bc 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)))
98bb168c 1864;;; ********************************
1865;;; Directory Pathname Hacking *****
1866;;; ********************************
36d9b3bc 1868;;; Unix example: An absolute directory starts with / while a
98bb168c 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/".
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.
1882;;; Need to verify that merging of pathnames where modules are located
1883;;; on different devices (in VMS-based VAXLisp) now works.
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
36d9b3bc 1894;;; [[x]][y] instead of [x][y] or [x]y.
98bb168c 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
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.
36d9b3bc 1909 ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
98bb168c 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)))
36d9b3bc 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
98bb168c 1925 (rel-directory (directory-to-list (pathname-directory rel-dir)))
1926 (rel-keyword (when (keywordp (car rel-directory))
1927 (pop rel-directory)))
36d9b3bc 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))
98bb168c 1935 (directory nil))
36d9b3bc 1936
98bb168c 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
36d9b3bc 1941 ;; the necessary case conversion. TI maps upper back into lower case
98bb168c 1942 ;; for unix files!
36d9b3bc 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))
98bb168c 1949 ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
36d9b3bc 1950 ;; and filename "foo". The namestring of a pathname with
98bb168c 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))
36d9b3bc 1957
98bb168c 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))))))
36d9b3bc 1964 (when (and (null abs-directory)
1965 (or (null abs-keyword)
1966 ;; In Lucid, an abs-dir of nil gets a keyword of
98bb168c 1967 ;; :relative since (pathname-directory (pathname ""))
1968 ;; returns (:relative) instead of nil.
1969 #+:lucid (eq abs-keyword :relative))
1970 rel-keyword)
36d9b3bc 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)
98bb168c 1978 (setf abs-keyword rel-keyword))
1979 (setf directory (append abs-directory rel-directory))
1980 (when abs-keyword (setf directory (cons abs-keyword directory)))
36d9b3bc 1981 (namestring
98bb168c 1982 (make-pathname :host host
1983 :device device
36d9b3bc 1984 :directory
1985 directory
1986 :name
1987 #-(or :sbcl :MCL :clisp :cmu) rel-file
1988 #+(or :sbcl :MCL :clisp :cmu) rel-name
1990 #+(or :sbcl :MCL :clisp :cmu) :type
1991 #+(or :sbcl :MCL :clisp :cmu) rel-type
1992 ))))
98bb168c 1994
1995(defun directory-to-list (directory)
1996 ;; The directory should be a list, but nonstandard implementations have
36d9b3bc 1997 ;; been known to use a vector or even a string.
1998 (cond ((listp directory)
98bb168c 1999 directory)
2000 ((stringp directory)
2001 (cond ((find #\; directory)
36d9b3bc 2002 ;; It's probably a logical pathname, so split at the
98bb168c 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))))
36d9b3bc 2017(defparameter *append-dirs-tests*
98bb168c 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))
36d9b3bc 2035
98bb168c 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))))
36d9b3bc 2044
2046<cl> (test-new-append-directories)
98bb168c 2047
2048ABS: "~/foo/" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp"
2049ABS: "~/foo" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp"
2050ABS: "/foo/bar/" REL: "baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp"
2051ABS: "/foo/bar/" REL: "/baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp"
2052ABS: "foo/bar/" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
2053ABS: "foo/bar" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
2054ABS: "foo/bar" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
2055ABS: "foo/bar/" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
2056ABS: "/foo/bar/" REL: NIL Result: "/foo/bar/"
2057ABS: "foo/bar/" REL: NIL Result: "foo/bar/"
2058ABS: "foo/bar" REL: NIL Result: "foo/bar/"
2059ABS: "foo" REL: NIL Result: "foo/"
2060ABS: "foo" REL: "" Result: "foo/"
2061ABS: NIL REL: "baz/barf.lisp" Result: "baz/barf.lisp"
2062ABS: NIL REL: "/baz/barf.lisp" Result: "/baz/barf.lisp"
2063ABS: NIL REL: NIL Result: ""
36d9b3bc 2065||#
98bb168c 2066
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)
36d9b3bc 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.
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)))))
98bb168c 2108
2110(defun append-logical-directories-mk (absolute-dir relative-dir)
2111 (lp:append-logical-directories absolute-dir relative-dir))
36d9b3bc 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.
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 |#))
2131 (translate-logical-pathname
2132 (merge-pathnames relative-dir absolute-dir)))
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 |#))
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)))))
2159;; Old version
98bb168c 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))))))
36d9b3bc 2178|#
98bb168c 2179
2180;;; determines if string or pathname object is logical
2182(defun logical-pathname-p (thing)
2183 (eq (lp:pathname-host-type thing) :logical))
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))
36d9b3bc 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)))
2201;;; This affects only one thing.
2202;;; 19990707 Marco Antoniotti
2203;;; old version
98bb168c 2205(defun namestring-probably-logical (namestring)
2206 (and (stringp namestring)
2207 ;; unix pathnames don't have embedded semicolons
2208 (find #\; namestring)))
36d9b3bc 2209#||
2210;;; New version
2211(defun namestring-probably-logical (namestring)
2212 (and (stringp namestring)
2213 (typep (parse-namestring namestring) 'logical-pathname)))
98bb168c 2215
36d9b3bc 2216;;; New new version
2217;;; 20000321 Marco Antoniotti
2218(defun namestring-probably-logical (namestring)
2219 (pathname-logical-p namestring))
2223#|| This is incorrect, as it strives to keep strings around, when it
2224 shouldn't. MERGE-PATHNAMES already DTRT.
98bb168c 2225(defun append-logical-pnames (absolute relative)
36d9b3bc 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 )
98bb168c 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)))
36d9b3bc 2241||#
98bb168c 2242
36d9b3bc 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 )))
98bb168c 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.
36d9b3bc 2285 ;; it should also behave well if the parent directory
98bb168c 2286 ;; has a filename at the end, or if the relative-directory ain't relative
36d9b3bc 2287 (when absolute-directory
98bb168c 2288 (setq absolute-directory (pathname-directory absolute-directory)))
36d9b3bc 2289 (concatenate 'string
98bb168c 2290 (or absolute-directory "")
2291 (or relative-directory "")))
36d9b3bc 2292||#
98bb168c 2293
36d9b3bc 2294#||
98bb168c 2295<cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
2298<cl> (d "~/foo/" "baz/bar.lisp")
36d9b3bc 2299"/usr0/mkant/foo/baz/bar.lisp"
98bb168c 2300
2301<cl> (d "~/foo" "baz/bar.lisp")
36d9b3bc 2302"/usr0/mkant/foo/baz/bar.lisp"
98bb168c 2303
2304<cl> (d "/foo/bar/" "baz/barf.lisp")
2307<cl> (d "foo/bar/" "baz/barf.lisp")
2310<cl> (d "foo/bar" "baz/barf.lisp")
2313<cl> (d "foo/bar" "/baz/barf.lisp")
2316<cl> (d "foo/bar" nil)
2319<cl> (d nil "baz/barf.lisp")
2322<cl> (d nil nil)
36d9b3bc 2325||#
98bb168c 2326
36d9b3bc 2327;;; The following is a change proposed by DTC for SCL.
2328;;; Maybe it could be used all the time.
98bb168c 2329
36d9b3bc 2330#-scl
98bb168c 2331(defun new-file-type (pathname type)
36d9b3bc 2332 ;; why not (make-pathname :type type :defaults pathname)?
98bb168c 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)))
36d9b3bc 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)))
98bb168c 2354
2355;;; ********************************
2356;;; Component Defstruct ************
2357;;; ********************************
36d9b3bc 2358
98bb168c 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.")
36d9b3bc 2362
98bb168c 2363(defvar *binary-pathname-default* nil
2364 "Default value of :binary-pathname keyword in DEFSYSTEM.")
36d9b3bc 2366
98bb168c 2367(defstruct (topological-sort-node (:conc-name topsort-))
36d9b3bc 2368 (color :white :type (member :gray :black :white))
2369 )
2372(defparameter *component-evaluated-slots*
2373 '(:source-root-dir :source-pathname :source-extension
2374 :binary-root-dir :binary-pathname :binary-extension))
2377(defparameter *component-form-slots*
2378 '(:initially-do :finally-do :compile-form :load-form))
98bb168c 2380
2381(defstruct (component (:include topological-sort-node)
2382 (:print-function print-component))
36d9b3bc 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 "/").
98bb168c 2399 (source-pathname *source-pathname-default*)
36d9b3bc 2400 source-extension ; A string, e.g., "lisp"
2401 ; if NIL, inherit
98bb168c 2402 (binary-pathname *binary-pathname-default*)
2403 binary-root-dir
36d9b3bc 2404 binary-extension ; A string, e.g., "fasl". If
2405 ; NIL, uses default for
2406 ; machine-type.
2407 package ; Package for use-package.
98bb168c 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
36d9b3bc 2415 ;; can define additional language mappings. Compilation functions should
98bb168c 2416 ;; accept a pathname argument and a :output-file keyword; loading functions
2417 ;; just a pathname argument. The default functions are #'compile-file and
36d9b3bc 2418 ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to
98bb168c 2419 ;; mix languages.
36d9b3bc 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.
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.
2445 ;; load-time ; The file-write-date of the
2446 ; binary/source file loaded.
98bb168c 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.
36d9b3bc 2451 load-only ; If T, will not compile this
2452 ; file on operation :compile.
98bb168c 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
36d9b3bc 2456 ;; for PCL defmethod and defclass definitions, which wrap a
98bb168c 2457 ;; (eval-when (compile load eval) ...) around the body of the definition.
2458 ;; This saves time in some lisps.
36d9b3bc 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))
2468 (documentation nil :type (or null string)) ; Optional documentation slot
2469 (long-documentation nil :type (or null string)) ; Optional long documentation slot
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))
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 )
2484;;; To allow dependencies from "foreign systems" like ASDF or one of
2485;;; the proprietary ones like ACL or LW.
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 )
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)))
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 )
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 )
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 )
98bb168c 2532
2533(defvar *file-load-time-table* (make-hash-table :test #'equal)
36d9b3bc 2534 "Hash table of file-write-dates for the system definitions and files in the system definitions.")
98bb168c 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*))
36d9b3bc 2542 (component
98bb168c 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*)))))))))
36d9b3bc 2556
2557#-(or :cmu)
98bb168c 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))
36d9b3bc 2565 (component
98bb168c 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))
36d9b3bc 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))
2611;;; compute-system-path --
98bb168c 2613(defun compute-system-path (module-name definition-pname)
36d9b3bc 2614 (let* ((module-string-name
2615 (etypecase module-name
2616 (symbol (string-downcase
2617 (string module-name)))
2618 (string module-name)))
2620 (file-pathname
2621 (make-pathname :name module-string-name
2622 :type *system-extension*))
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 ))
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))))
2675 (defun compute-system-path (module-name definition-pname)
2676 (let* ((filename (format nil "~A.~A"
98bb168c 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.
36d9b3bc 2685 (cond (*central-registry*
98bb168c 2686 (if (listp *central-registry*)
2687 (dolist (registry *central-registry*)
36d9b3bc 2688 (let ((file (probe-file
2689 (append-directories
2690 (registry-pathname registry) filename))))
98bb168c 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))))))
36d9b3bc 2698|#
98bb168c 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.")
36d9b3bc 2706(defun find-system (system-name &optional (mode :ask) definition-pname)
2707 "Returns the system named SYSTEM-NAME.
2708If 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.
2711This allows OPERATE-ON-SYSTEM to work on non-loaded as well as
2712loaded system definitions. DEFINITION-PNAME is the pathname for
2713the system definition, if provided."
98bb168c 2714 (ecase mode
36d9b3bc 2715 (:ask
98bb168c 2716 (or (get-system system-name)
36d9b3bc 2717 (when (y-or-n-p-wait
98bb168c 2718 #\y 20
2719 "System ~A not loaded. Shall I try loading it? "
2720 system-name)
2721 (find-system system-name :load definition-pname))))
36d9b3bc 2722 (:error
98bb168c 2723 (or (get-system system-name)
36d9b3bc 2724 (error 'missing-system :name system-name)))
2725 (:load-or-nil
98bb168c 2726 (let ((system (get-system system-name)))
36d9b3bc 2727 ;; (break "System ~S ~S." system-name system)
98bb168c 2728 (or (unless *reload-systems-from-disk* system)
36d9b3bc 2729 ;; If SYSTEM-NAME is a symbol, it will lowercase the
2730 ;; symbol's string.
98bb168c 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.
36d9b3bc 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))
98bb168c 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))))
36d9b3bc 2744 (tell-user-generic
2745 (format nil "Loading system ~A from file ~A"
98bb168c 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)))
36d9b3bc 2755 (:load
98bb168c 2756 (or (unless *reload-systems-from-disk* (get-system system-name))
36d9b3bc 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))
98bb168c 2761 (or (find-system system-name :load-or-nil definition-pname)
2762 (error "Can't find system named ~s." system-name))))))
36d9b3bc 2764
98bb168c 2765(defun print-component (component stream depth)
2766 (declare (ignore depth))
2767 (format stream "#<~:@(~A~): ~A>"
2768 (component-type component)
2769 (component-name component)))
36d9b3bc 2771
98bb168c 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~]~
36d9b3bc 2783 ~@[~& Depends On: ~A ~]~& Components:~{~15T~A~&~}"
98bb168c 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))
36d9b3bc 2797 #||(when recursive
98bb168c 2798 (dolist (component (component-components system))
36d9b3bc 2799 (describe-system component stream recursive)))||#
98bb168c 2800 system))
36d9b3bc 2802
98bb168c 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.
36d9b3bc 2811 (setf (component-name component)
98bb168c 2812 (string-downcase (string (component-name component))))))
36d9b3bc 2814
98bb168c 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)))))
36d9b3bc 2821
98bb168c 2823(defun component-error-pathname (component)
2824 (let ((binary (component-pathname component :binary)))
36d9b3bc 2825 (new-file-type binary *compile-error-file-type*)))
98bb168c 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)))))
36d9b3bc 2833
98bb168c 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 )))
36d9b3bc 2840
98bb168c 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)))))
36d9b3bc 2847
98bb168c 2848(defvar *source-pathnames-table* (make-hash-table :test #'equal)
2849 "Table which maps from components to full source pathnames.")
36d9b3bc 2850
98bb168c 2852(defvar *binary-pathnames-table* (make-hash-table :test #'equal)
2853 "Table which maps from components to full binary pathnames.")
36d9b3bc 2854
98bb168c 2856(defparameter *reset-full-pathname-table* t
36d9b3bc 2857 "If T, clears the full-pathname tables before each call to OPERATE-ON-SYSTEM.
2858Setting this to NIL may yield faster performance after multiple calls
2859to LOAD-SYSTEM and COMPILE-SYSTEM, but could result in changes to
2860system and language definitions to not take effect, and so should be
2861used with caution.")
98bb168c 2864(defun clear-full-pathname-tables ()
2865 (clrhash *source-pathnames-table*)
2866 (clrhash *binary-pathnames-table*))
36d9b3bc 2868
98bb168c 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)))))
36d9b3bc 2887
2888(defun component-full-pathname-i (component type
2889 &optional (version *version*)
98bb168c 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)
36d9b3bc 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)
98bb168c 2900 (let ((pathname
36d9b3bc 2901 (append-directories
98bb168c 2902 (if version-replace
2903 version-dir
36d9b3bc 2904 (append-directories (component-root-dir component type)
2905 version-dir))
98bb168c 2906 (component-pathname component type))))
36d9b3bc 2907
98bb168c 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.
98bb168c 2914
36d9b3bc 2915 ;; (format t "pathname = ~A~%" pathname)
2916 ;; (format t "type = ~S~%" (component-extension component type))
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)
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.
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.
2939 ;; 20050613 Marco Antoniotti
2940 ;; Added COMPONENT-NAME extraction to :NAME part, in case the
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))
2956 :directory (pathname-directory pathname
2957 #+scl :case
2958 #+scl :common
2959 )
2961 :name (or (pathname-name pathname
2962 #+scl :case
2963 #+scl :common
2964 )
2965 (component-name component))
2967 :type
2968 #-scl (component-extension component type)
2969 #+scl (string-upcase
2970 (component-extension component type))
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 ))))))
98bb168c 2986(defun translate-version (version)
36d9b3bc 2987 ;; Value returns the version directory and whether it replaces
98bb168c 2988 ;; the entire root (t) or is a subdirectory.
2989 ;; Version may be nil to signify no subdirectory,
2990 ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
2991 ;; specifies a subdirectory of the root, or
2992 ;; a string, which replaces the root.
36d9b3bc 2993 (cond ((null version)
98bb168c 2994 (values "" nil))
2995 ((symbolp version)
2996 (values (let ((sversion (string version)))
2997 (if (find-if #'lower-case-p sversion)
2998 sversion
36d9b3bc 2999 (string-downcase sversion)))
98bb168c 3000 nil))
3001 ((stringp version)
3002 (values version t))
3003 (t (error "~&; Illegal version ~S" version))))
36d9b3bc 3005
3006;;; Looks like LW has a bug in MERGE-PATHNAMES.
3008;;; (merge-pathnames "" "LP:foo;bar;") ==> "LP:"
3010;;; Which is incorrect.
3011;;; The change here ensures that the result of TRANSLATE-VERSION is
3012;;; appropriate.
3015(defun translate-version (version)
3016 ;; Value returns the version directory and whether it replaces
3017 ;; the entire root (t) or is a subdirectory.
3018 ;; Version may be nil to signify no subdirectory,
3019 ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
3020 ;; specifies a subdirectory of the root, or
3021 ;; a string, which replaces the root.
3022 (cond ((null version)
3023 (values (pathname "") nil))
3024 ((symbolp version)
3025 (values (let ((sversion (string version)))
3026 (if (find-if #'lower-case-p sversion)
3027 (pathname sversion)
3028 (pathname (string-downcase sversion))))
3029 nil))
3030 ((stringp version)
3031 (values (pathname version) t))
3032 (t (error "~&; Illegal version ~S" version))))
98bb168c 3035(defun component-extension (component type &key local)
3036 (ecase type
3037 (:source (or (component-source-extension component)
36d9b3bc 3038 (unless local
3039 (default-source-extension component)) ; system default
3040 ;; (and (component-language component))
3041 ))
98bb168c 3042 (:binary (or (component-binary-extension component)
3043 (unless local
36d9b3bc 3044 (default-binary-extension component)) ; system default
3045 ;; (and (component-language component))
3046 ))
98bb168c 3047 (:error *compile-error-file-type*)))
36d9b3bc 3048
98bb168c 3050(defsetf component-extension (component type) (value)
3051 `(ecase ,type
3052 (:source (setf (component-source-extension ,component) ,value))
3053 (:binary (setf (component-binary-extension ,component) ,value))
3054 (:error (setf *compile-error-file-type* ,value))))
36d9b3bc 3056
98bb168c 3057;;; ********************************
3058;;; System Definition **************
3059;;; ********************************
36d9b3bc 3060
98bb168c 3061(defun create-component (type name definition-body &optional parent (indent 0))
36d9b3bc 3062 (let ((component (apply #'make-component
3063 :type type
3064 :name name
3065 :indent indent
3066 definition-body)))
98bb168c 3067 ;; Set up :load-only attribute
3068 (unless (find :load-only definition-body)
36d9b3bc 3069 ;; If the :load-only attribute wasn't specified,
98bb168c 3070 ;; inherit it from the parent. If no parent, default it to nil.
36d9b3bc 3071 (setf (component-load-only component)
98bb168c 3072 (when parent
3073 (component-load-only parent))))
3074 ;; Set up :compile-only attribute
3075 (unless (find :compile-only definition-body)
36d9b3bc 3076 ;; If the :compile-only attribute wasn't specified,
98bb168c 3077 ;; inherit it from the parent. If no parent, default it to nil.
36d9b3bc 3078 (setf (component-compile-only component)
98bb168c 3079 (when parent
3080 (component-compile-only parent))))