;;; -*- Mode: Lisp; Package: make -*- ;;; -*- Mode: CLtL; Syntax: Common-Lisp -*- ;;; DEFSYSTEM 3.6 Interim. ;;; defsystem.lisp -- ;;; **************************************************************** ;;; MAKE -- A Portable Defsystem Implementation ******************** ;;; **************************************************************** ;;; This is a portable system definition facility for Common Lisp. ;;; Though home-grown, the syntax was inspired by fond memories of the ;;; defsystem facility on Symbolics 3600's. The exhaustive lists of ;;; filename extensions for various lisps and the idea to have one ;;; "operate-on-system" function instead of separate "compile-system" ;;; and "load-system" functions were taken from Xerox Corp.'s PCL ;;; system. ;;; This system improves on both PCL and Symbolics defsystem utilities ;;; by performing a topological sort of the graph of file-dependency ;;; constraints. Thus, the components of the system need not be listed ;;; in any special order, because the defsystem command reorganizes them ;;; based on their constraints. It includes all the standard bells and ;;; whistles, such as not recompiling a binary file that is up to date ;;; (unless the user specifies that all files should be recompiled). ;;; Originally written by Mark Kantrowitz, School of Computer Science, ;;; Carnegie Mellon University, October 1989. ;;; MK:DEFSYSTEM 3.6 Interim ;;; ;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved. ;;; 1999 - 2005 Mark Kantrowitz and Marco Antoniotti. All ;;; rights reserved. ;;; Use, copying, modification, merging, publishing, distribution ;;; and/or sale of this software, source and/or binary files and ;;; associated documentation files (the "Software") and of derivative ;;; works based upon this Software are permitted, as long as the ;;; following conditions are met: ;;; o this copyright notice is included intact and is prominently ;;; visible in the Software ;;; o if modifications have been made to the source code of the ;;; this package that have not been adopted for inclusion in the ;;; official version of the Software as maintained by the Copyright ;;; holders, then the modified package MUST CLEARLY identify that ;;; such package is a non-standard and non-official version of ;;; the Software. Furthermore, it is strongly encouraged that any ;;; modifications made to the Software be sent via e-mail to the ;;; MK-DEFSYSTEM maintainers for consideration of inclusion in the ;;; official MK-DEFSYSTEM package. ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. ;;; IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; Except as contained in this notice, the names of M. Kantrowitz and ;;; M. Antoniotti shall not be used in advertising or otherwise to promote ;;; the sale, use or other dealings in this Software without prior written ;;; authorization from M. Kantrowitz and M. Antoniotti. ;;; Please send bug reports, comments and suggestions to . ;;; ******************************** ;;; Change Log ********************* ;;; ******************************** ;;; ;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in ;;; September and October 1990, but not documented until January 1991. ;;; ;;; akd = Abdel Kader Diagne ;;; as = Andreas Stolcke ;;; bha = Brian Anderson ;;; brad = Brad Miller ;;; bw = Robert Wilhelm ;;; djc = Daniel J. Clancy ;;; fdmm = Fernando D. Mato Mira ;;; gc = Guillaume Cartier ;;; gi = Gabriel Inaebnit ;;; gpw = George Williams ;;; hkt = Rick Taube ;;; ik = Ik Su Yoo ;;; jk = John_Kolojejchick@MORK.CIMDS.RI.CMU.EDU ;;; kt = Kevin Thompson ;;; kc = Kaelin Colclasure ;;; kmr = Kevin M. Rosenberg ;;; lmh = Liam M. Healy ;;; mc = Matthew Cornell ;;; oc = Oliver Christ ;;; rs = Ralph P. Sobek ;;; rs2 = Richard Segal ;;; sb = Sean Boisen ;;; ss = Steve Strassman ;;; tar = Thomas A. Russ ;;; toni = Anton Beschta ;;; yc = Yang Chen ;;; ;;; Thanks to Steve Strassmann and ;;; Sean Boisen for detailed bug reports and ;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit ;;; for help with VAXLisp bugs. ;;; ;;; 05-NOV-90 hkt Changed canonicalize-system-name to make system ;;; names package independent. Interns them in the ;;; keyword package. Thus either strings or symbols may ;;; be used to name systems from the user's point of view. ;;; 05-NOV-90 hkt Added definition FIND-SYSTEM to allow OOS to ;;; work on systems whose definition hasn't been loaded yet. ;;; 05-NOV-90 hkt Added definitions COMPILE-SYSTEM and LOAD-SYSTEM ;;; as alternates to OOS for naive users. ;;; 05-NOV-90 hkt Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT] ;;; into USER package instead of import. ;;; 15-NOV-90 mk Changed package name to "MAKE", eliminating "DEFSYSTEM" ;;; to avoid conflicts with allegro, symbolics packages ;;; named "DEFSYSTEM". ;;; 30-JAN-91 mk Modified append-directories to work with the ;;; logical-pathnames system. ;;; 30-JAN-91 mk Append-directories now works with Sun CL4.0. Also, fixed ;;; bug wrt Lucid 4.0's pathnames (which changed from lcl3.0 ;;; -- 4.0 uses a list for the directory slot, whereas ;;; 3.0 required a string). Possible fix to symbolics bug. ;;; 30-JAN-91 mk Defined NEW-REQUIRE to make redefinition of REQUIRE ;;; cleaner. Replaced all calls to REQUIRE in this file with ;;; calls to NEW-REQUIRE, which should avoid compiler warnings. ;;; 30-JAN-91 mk In VAXLisp, when we redefine lisp:require, the compiler ;;; no longer automatically executes require forms when it ;;; encounters them in a file. The user can always wrap an ;;; (eval-when (compile load eval) ...) around the require ;;; form. Alternately, see commented out code near the ;;; redefinition of lisp:require which redefines it as a ;;; macro instead. ;;; 30-JAN-91 mk Added parameter :version to operate-on-system. If it is ;;; a number, that number is used as part of the binary ;;; directory name as the place to store and load files. ;;; If NIL (the default), uses regular binary directory. ;;; If T, tries to find the most recent version of the ;;; binary directory. ;;; 30-JAN-91 mk Added global variable *use-timeouts* (default: t), which ;;; specifies whether timeouts should be used in ;;; Y-OR-N-P-WAIT. This is provided for users whose lisps ;;; don't handle read-char-no-hang properly, so that they ;;; can set it to NIL to disable the timeouts. Usually the ;;; reason for this is the lisp is run on top of UNIX, ;;; which buffers input LINES (and provides input editing). ;;; To get around this we could always turn CBREAK mode ;;; on and off, but there's no way to do this in a portable ;;; manner. ;;; 30-JAN-91 mk Fixed bug where in :test t mode it was actually providing ;;; the system, instead of faking it. ;;; 30-JAN-91 mk Changed storage of system definitions to a hash table. ;;; Changed canonicalize-system-name to coerce the system ;;; names to uppercase strings. Since we're no longer using ;;; get, there's no need to intern the names as symbols, ;;; and strings don't have packages to cause problems. ;;; Added UNDEFSYSTEM, DEFINED-SYSTEMS, and DESCRIBE-SYSTEM. ;;; Added :delete-binaries command. ;;; 31-JAN-91 mk Franz Allegro CL has a defsystem in the USER package, ;;; so we need to do a shadowing import to avoid name ;;; conflicts. ;;; 31-JAN-91 mk Fixed bug in compile-and-load-operation where it was ;;; only loading newly compiled files. ;;; 31-JAN-91 mk Added :load-time slot to components to record the ;;; file-write-date of the binary/source file that was loaded. ;;; Now knows "when" (which date version) the file was loaded. ;;; Added keyword :minimal-load and global *minimal-load* ;;; to enable defsystem to avoid reloading unmodified files. ;;; Note that if B depends on A, but A is up to date and ;;; loaded and the user specified :minimal-load T, then A ;;; will not be loaded even if B needs to be compiled. So ;;; if A is an initializations file, say, then the user should ;;; not specify :minimal-load T. ;;; 31-JAN-91 mk Added :load-only slot to components. If this slot is ;;; specified as non-NIL, skips over any attempts to compile ;;; the files in the component. (Loading the file satisfies ;;; the need to recompile.) ;;; 31-JAN-91 mk Eliminated use of set-alist-lookup and alist-lookup, ;;; replacing it with hash tables. It was too much bother, ;;; and rather brittle too. ;;; 31-JAN-91 mk Defined #@ macro character for use with AFS @sys ;;; feature simulator. #@"directory" is then synonymous ;;; with (afs-binary-directory "directory"). ;;; 31-JAN-91 mk Added :private-file type of module. It is similar to ;;; :file, but has an absolute pathname. This allows you ;;; to specify a different version of a file in a system ;;; (e.g., if you're working on the file in your home ;;; directory) without completely rewriting the system ;;; definition. ;;; 31-JAN-91 mk Operations on systems, such as :compile and :load, ;;; now propagate to subsystems the system depends on ;;; if *operations-propagate-to-subsystems* is T (the default) ;;; and the systems were defined using either defsystem ;;; or as a :system component of another system. Thus if ;;; a system depends on another, it can now recompile the ;;; other. ;;; 01-FEB-91 mk Added default definitions of PROVIDE/REQUIRE/*MODULES* ;;; for lisps that have thrown away these definitions in ;;; accordance with CLtL2. ;;; 01-FEB-91 mk Added :compile-only slot to components. Analogous to ;;; :load-only. If :compile-only is T, will not load the ;;; file on operation :compile. Either compiles or loads ;;; the file, but not both. In other words, compiling the ;;; file satisfies the demand to load it. This is useful ;;; for PCL defmethod and defclass definitions, which wrap ;;; an (eval-when (compile load eval) ...) around the body ;;; of the definition -- we save time by not loading the ;;; compiled code, since the eval-when forces it to be ;;; loaded. Note that this may not be entirely safe, since ;;; CLtL2 has added a :load keyword to compile-file, and ;;; some lisps may maintain a separate environment for ;;; the compiler. This feature is for the person who asked ;;; that a :COMPILE-SATISFIES-LOAD keyword be added to ;;; modules. It's named :COMPILE-ONLY instead to match ;;; :LOAD-ONLY. ;;; 11-FEB-91 mk Now adds :mk-defsystem to features list, to allow ;;; special cased loading of defsystem if not already ;;; present. ;;; 19-FEB-91 duff Added filename extension for hp9000/300's running Lucid. ;;; 26-FEB-91 mk Distinguish between toplevel systems (defined with ;;; defsystem) and systems defined as a :system module ;;; of a defsystem. The former can depend only on systems, ;;; while the latter can depend on anything at the same ;;; level. ;;; 12-MAR-91 mk Added :subsystem component type to be a system with ;;; pathnames relative to its parent component. ;;; 12-MAR-91 mk Uncommented :device :absolute for CMU pathnames, so ;;; that the leading slash is included. ;;; 12-MAR-91 brad Patches for Allegro 4.0.1 on Sparc. ;;; 12-MAR-91 mk Changed definition of format-justified-string so that ;;; it no longer depends on the ~<~> format directives, ;;; because Allegro 4.0.1 has a bug which doesn't support ;;; them. Anyway, the new definition is twice as fast ;;; and conses half as much as FORMAT. ;;; 12-MAR-91 toni Remove nils from list in expand-component-components. ;;; 12-MAR-91 bw If the default-package and system have the same name, ;;; and the package is not loaded, this could lead to ;;; infinite loops, so we bomb out with an error. ;;; Fixed bug in default packages. ;;; 13-MAR-91 mk Added global *providing-blocks-load-propagation* to ;;; control whether system dependencies are loaded if they ;;; have already been provided. ;;; 13-MAR-91 brad In-package is a macro in CLtL2 lisps, so we change ;;; the package manually in operate-on-component. ;;; 15-MAR-91 mk Modified *central-registry* to be either a single ;;; directory pathname, or a list of directory pathnames ;;; to be checked in order. ;;; 15-MAR-91 rs Added afs-source-directory to handle versions when ;;; compiling C code under lisp. Other minor changes to ;;; translate-version and operate-on-system. ;;; 21-MAR-91 gi Fixed bug in defined-systems. ;;; 22-MAR-91 mk Replaced append-directories with new version that works ;;; by actually appending the directories, after massaging ;;; them into the proper format. This should work for all ;;; CLtL2-compliant lisps. ;;; 09-APR-91 djc Missing package prefix for lp:pathname-host-type. ;;; Modified component-full-pathname to work for logical ;;; pathnames. ;;; 09-APR-91 mk Added *dont-redefine-require* to control whether ;;; REQUIRE is redefined. Fixed minor bugs in redefinition ;;; of require. ;;; 12-APR-91 mk (pathname-host nil) causes an error in MCL 2.0b1 ;;; 12-APR-91 mc Ported to MCL2.0b1. ;;; 16-APR-91 mk Fixed bug in needs-loading where load-time and ;;; file-write-date got swapped. ;;; 16-APR-91 mk If the component is load-only, defsystem shouldn't ;;; tell you that there is no binary and ask you if you ;;; want to load the source. ;;; 17-APR-91 mc Two additional operations for MCL. ;;; 21-APR-91 mk Added feature requested by ik. *files-missing-is-an-error* ;;; new global variable which controls whether files (source ;;; and binary) missing cause a continuable error or just a ;;; warning. ;;; 21-APR-91 mk Modified load-file-operation to allow compilation of source ;;; files during load if the binary files are old or ;;; non-existent. This adds a :compile-during-load keyword to ;;; oos, and load-system. Global *compile-during-load* sets ;;; the default (currently :query). ;;; 21-APR-91 mk Modified find-system so that there is a preference for ;;; loading system files from disk, even if the system is ;;; already defined in the environment. ;;; 25-APR-91 mk Removed load-time slot from component defstruct and added ;;; function COMPONENT-LOAD-TIME to store the load times in a ;;; hash table. This is safer than the old definition because ;;; it doesn't wipe out load times every time the system is ;;; redefined. ;;; 25-APR-91 mk Completely rewrote load-file-operation. Fixed some bugs ;;; in :compile-during-load and in the behavior of defsystem ;;; when multiple users are compiling and loading a system ;;; instead of just a single user. ;;; 16-MAY-91 mk Modified FIND-SYSTEM to do the right thing if the system ;;; definition file cannot be found. ;;; 16-MAY-91 mk Added globals *source-pathname-default* and ;;; *binary-pathname-default* to contain default values for ;;; :source-pathname and :binary-pathname. For example, set ;;; *source-pathname-default* to "" to avoid having to type ;;; :source-pathname "" all the time. ;;; 27-MAY-91 mk Fixed bug in new-append-directories where directory ;;; components of the form "foo4.0" would appear as "foo4", ;;; since pathname-name truncates the type. Changed ;;; pathname-name to file-namestring. ;;; 3-JUN-91 gc Small bug in new-append-directories; replace (when ;;; abs-name) with (when (not (null-string abs-name))) ;;; 4-JUN-91 mk Additional small change to new-append-directories for ;;; getting the device from the relative pname if the abs ;;; pname is "". This is to fix a small behavior in CMU CL old ;;; compiler. Also changed (when (not (null-string abs-name))) ;;; to have an (and abs-name) in there. ;;; 8-JAN-92 sb Added filename extension for defsystem under Lucid Common ;;; Lisp/SGO 3.0.1+. ;;; 8-JAN-92 mk Changed the definition of prompt-string to work around an ;;; AKCL bug. Essentially, AKCL doesn't default the colinc to ;;; 1 if the colnum is provided, so we hard code it. ;;; 8-JAN-92 rs (pathname-directory (pathname "")) returns '(:relative) in ;;; Lucid, instead of NIL. Changed new-append-directories and ;;; test-new-append-directories to reflect this. ;;; 8-JAN-92 mk Fixed problem related to *load-source-if-no-binary*. ;;; compile-and-load-source-if-no-binary wasn't checking for ;;; the existence of the binary if this variable was true, ;;; causing the file to not be compiled. ;;; 8-JAN-92 mk Fixed problem with null-string being called on a pathname ;;; by returning NIL if the argument isn't a string. ;;; 3-NOV-93 mk In Allegro 4.2, pathname device is :unspecific by default. ;;; 11-NOV-93 fdmm Fixed package definition lock problem when redefining ;;; REQUIRE on ACL. ;;; 11-NOV-93 fdmm Added machine and software types for SGI and IRIX. It is ;;; important to distinguish the OS version and CPU type in ;;; SGI+ACL, since ACL 4.1 on IRIX 4.x and ACL 4.2 on IRIX 5.x ;;; have incompatible .fasl files. ;;; 01-APR-94 fdmm Fixed warning problem when redefining REQUIRE on LispWorks. ;;; 01-NOV-94 fdmm Replaced (software-type) call in ACL by code extracting ;;; the interesting parts from (software-version) [deleted ;;; machine name and id]. ;;; 03-NOV-94 fdmm Added a hook (*compile-file-function*), that is funcalled ;;; by compile-file-operation, so as to support other languages ;;; running on top of Common Lisp. ;;; The default is to compile Common Lisp. ;;; 03-NOV-94 fdmm Added SCHEME-COMPILE-FILE, so that defsystem can now ;;; compile Pseudoscheme files. ;;; 04-NOV-94 fdmm Added the exported generic function SET-LANGUAGE, to ;;; have a clean, easy to extend interface for telling ;;; defsystem which language to assume for compilation. ;;; Currently supported arguments: :common-lisp, :scheme. ;;; 11-NOV-94 kc Ported to Allegro CL for Windows 2.0 (ACLPC) and CLISP. ;;; 18-NOV-94 fdmm Changed the entry *filename-extensions* for LispWorks ;;; to support any platform. ;;; Added entries for :mcl and :clisp too. ;;; 16-DEC-94 fdmm Added and entry for CMU CL on SGI to *filename-extensions*. ;;; 16-DEC-94 fdmm Added OS version identification for CMU CL on SGI. ;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed make-pathnames call fix ;;; in NEW-APPEND-DIRECTORIES. ;;; 16-DEC-94 fdmm Added HOME-SUBDIRECTORY to fix CMU's ignorance about `~' ;;; when specifying registries. ;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed :device fix in make-pathnames call ;;; in COMPONENT-FULL-PATHNAME. This fix was also reported ;;; by kc on 12-NOV-94. CMU CL 17 now supports CLtL2 pathnames. ;;; 16-DEC-94 fdmm Removed a quote before the call to read in the readmacro ;;; #@. This fixes a really annoying misfeature (couldn't do ;;; #@(concatenate 'string "foo/" "bar"), for example). ;;; 03-JAN-95 fdmm Do not include :pcl in *features* if :clos is there. ;;; 2-MAR-95 mk Modified fdmm's *central-registry* change to use ;;; user-homedir-pathname and to be a bit more generic in the ;;; pathnames. ;;; 2-MAR-95 mk Modified fdmm's updates to *filename-extensions* to handle ;;; any CMU CL binary extensions. ;;; 2-MAR-95 mk Make kc's port to ACLPC a little more generic. ;;; 2-MAR-95 mk djc reported a bug, in which GET-SYSTEM was not returning ;;; a system despite the system's just having been loaded. ;;; The system name specified in the :depends-on was a ;;; lowercase string. I am assuming that the system name ;;; in the defsystem form was a symbol (I haven't verified ;;; that this was the case with djc, but it is the only ;;; reasonable conclusion). So, CANONICALIZE-SYSTEM-NAME ;;; was storing the system in the hash table as an ;;; uppercase string, but attempting to retrieve it as a ;;; lowercase string. This behavior actually isn't a bug, ;;; but a user error. It was intended as a feature to ;;; allow users to use strings for system names when ;;; they wanted to distinguish between two different systems ;;; named "foo.system" and "Foo.system". However, this ;;; user error indicates that this was a bad design decision. ;;; Accordingly, CANONICALIZE-SYSTEM-NAME now uppercases ;;; even strings for retrieving systems, and the comparison ;;; in *modules* is now case-insensitive. The result of ;;; this change is if the user cannot have distinct ;;; systems in "Foo.system" and "foo.system" named "Foo" and ;;; "foo", because they will clobber each other. There is ;;; still case-sensitivity on the filenames (i.e., if the ;;; system file is named "Foo.system" and you use "foo" in ;;; the :depends-on, it won't find it). We didn't take the ;;; further step of requiring system filenames to be lowercase ;;; because we actually find this kind of case-sensitivity ;;; to be useful, when maintaining two different versions ;;; of the same system. ;;; 7-MAR-95 mk Added simplistic handling of logical pathnames. Also ;;; modified new-append-directories so that it'll try to ;;; split up pathname directories that are strings into a ;;; list of the directory components. Such directories aren't ;;; ANSI CL, but some non-conforming implementations do it. ;;; 7-MAR-95 mk Added :proclamations to defsystem form, which can be used ;;; to set the compiler optimization level before compilation. ;;; For example, ;;; :proclamations '(optimize (safety 3) (speed 3) (space 0)) ;;; 7-MAR-95 mk Defsystem now tells the user when it reloads the system ;;; definition. ;;; 7-MAR-95 mk Fixed problem pointed out by yc. If ;;; *source-pathname-default* is "" and there is no explicit ;;; :source-pathname specified for a file, the file could ;;; wind up with an empty file name. In other words, this ;;; global default shouldn't apply to :file components. Added ;;; explicit test for null strings, and when present replaced ;;; them with NIL (for binary as well as source, and also for ;;; :private-file components). ;;; 7-MAR-95 tar Fixed defsystem to work on TI Explorers (TI CL). ;;; 7-MAR-95 jk Added machine-type-translation for Decstation 5000/200 ;;; under Allegro 3.1 ;;; 7-MAR-95 as Fixed bug in AKCL-1-615 in which defsystem added a ;;; subdirectory "RELATIVE" to all filenames. ;;; 7-MAR-95 mk Added new test to test-new-append-directories to catch the ;;; error fixed by as. Essentially, this error occurs when the ;;; absolute-pathname has no directory (i.e., it has a single ;;; pathname component as in "foo" and not "foo/bar"). If ;;; RELATIVE ever shows up in the Result, we now know to ;;; add an extra conditionalization to prevent abs-keyword ;;; from being set to :relative. ;;; 7-MAR-95 ss Miscellaneous fixes for MCL 2.0 final. ;;; *compile-file-verbose* not in MCL, *version variables ;;; need to occur before AFS-SOURCE-DIRECTORY definition, ;;; and certain code needed to be in the CCL: package. ;;; 8-MAR-95 mk Y-OR-N-P-WAIT uses a busy-waiting. On Lisp systems where ;;; the time functions cons, such as CMU CL, this can cause a ;;; lot of ugly garbage collection messages. Modified the ;;; waiting to include calls to SLEEP, which should reduce ;;; some of the consing. ;;; 8-MAR-95 mk Replaced fdmm's SET-LANGUAGE enhancement with a more ;;; general extension, along the lines suggested by akd. ;;; Defsystem now allows components to specify a :language ;;; slot, such as :language :lisp, :language :scheme. This ;;; slot is inherited (with the default being :lisp), and is ;;; used to obtain compilation and loading functions for ;;; components, as well as source and binary extensions. The ;;; compilation and loading functions can be overridden by ;;; specifying a :compiler or :loader in the system ;;; definition. Also added :documentation slot to the system ;;; definition. ;;; Where this comes in real handy is if one has a ;;; compiler-compiler implemented in Lisp, and wants the ;;; system to use the compiler-compiler to create a parser ;;; from a grammar and then compile parser. To do this one ;;; would create a module with components that looked ;;; something like this: ;;; ((:module cc :components ("compiler-compiler")) ;;; (:module gr :compiler 'cc :loader #'ignore ;;; :source-extension "gra" ;;; :binary-extension "lisp" ;;; :depends-on (cc) ;;; :components ("sample-grammar")) ;;; (:module parser :depends-on (gr) ;;; :components ("sample-grammar"))) ;;; Defsystem would then compile and load the compiler, use ;;; it (the function cc) to compile the grammar into a parser, ;;; and then compile the parser. The only tricky part is ;;; cc is defined by the system, and one can't include #'cc ;;; in the system definition. However, one could include ;;; a call to mk:define-language in the compiler-compiler file, ;;; and define :cc as a language. This is the prefered method. ;;; 8-MAR-95 mk New definition of topological-sort suggested by rs2. This ;;; version avoids the call to SORT, but in practice isn't ;;; much faster. However, it avoids the need to maintain a ;;; TIME slot in the topsort-node structure. ;;; 8-MAR-95 mk rs2 also pointed out that the calls to MAKE-PATHNAME and ;;; NAMESTRING in COMPONENT-FULL-PATHNAME are a major reason ;;; why defsystem is slow. Accordingly, I've changed ;;; COMPONENT-FULL-PATHNAME to include a call to NAMESTRING ;;; (and removed all other calls to NAMESTRING), and also made ;;; a few changes to minimize the number of calls to ;;; COMPONENT-FULL-PATHNAME, such as memoizing it. See To Do ;;; below for other related comments. ;;; 8-MAR-95 mk Added special hack requested by Steve Strassman, which ;;; allows one to specify absolute pathnames in the shorthand ;;; for a list of components, and have defsystem recognize ;;; which are absolute and which are relative. ;;; I actually think this would be a good idea, but I haven't ;;; tested it, so it is disabled by default. Search for ;;; *enable-straz-absolute-string-hack* to enable it. ;;; 8-MAR-95 kt Fixed problem with EXPORT in AKCL 1.603, in which it wasn't ;;; properly exporting the value of the global export ;;; variables. ;;; 8-MAR-95 mk Added UNMUNGE-LUCID to fix nasty problem with COMPILE-FILE ;;; in Lucid. Lucid apparently tries to merge the :output-file ;;; with the source file when the :output-file is a relative ;;; pathname. Wierd, and definitely non-standard. ;;; 9-MAR-95 mk Changed ALLEGRO-MAKE-SYSTEM-FASL to also include the files ;;; in any systems the system depends on, as per a ;;; request of oc. ;;; 9-MAR-95 mk Some version of CMU CL couldn't hack a call to ;;; MAKE-PATHNAME with :host NIL. I'm not sure which version ;;; it is, but the current version doesn't have this problem. ;;; If given :host nil, it defaults the host to ;;; COMMON-LISP::*UNIX-HOST*. So I haven't "fixed" this ;;; problem. ;;; 9-MAR-95 mk Integrated top-level commands for Allegro designed by bha ;;; into the code, with slight modifications. ;;; 9-MAR-95 mk Instead of having COMPUTE-SYSTEM-PATH check the current ;;; directory in a hard-coded fashion, include the current ;;; directory in the *central-registry*, as suggested by ;;; bha and others. ;;; 9-MAR-95 bha Support for Logical Pathnames in Allegro. ;;; 9-MAR-95 mk Added modified version of bha's DEFSYSPATH idea. ;;; 13-MAR-95 mk Added a macro for the simple serial case, where a system ;;; (or module) is simple a list of files, each of which ;;; depends on the previous one. If the value of :components ;;; is a list beginning with :serial, it expands each ;;; component and makes it depend on the previous component. ;;; For example, (:serial "foo" "bar" "baz") would create a ;;; set of components where "baz" depended on "bar" and "bar" ;;; on "foo". ;;; 13-MAR-95 mk *** Now version 3.0. This version is a interim bug-fix and ;;; update, since I do not have the time right now to complete ;;; the complete overhaul and redesign. ;;; Major changes in 3.0 include CMU CL 17, CLISP, ACLPC, TI, ;;; LispWorks and ACL(SGI) support, bug fixes for ACL 4.1/4.2. ;;; 14-MAR-95 fdmm Finally added the bit of code to discriminate cleanly ;;; among different lisps without relying on (software-version) ;;; idiosyncracies. ;;; You can now customize COMPILER-TYPE-TRANSLATION so that ;;; AFS-BINARY-DIRECTORY can return a different value for ;;; different lisps on the same platform. ;;; If you use only one compiler, do not care about supporting ;;; code for multiple versions of it, and want less verbose ;;; directory names, just set *MULTIPLE-LISP-SUPPORT* to nil. ;;; 17-MAR-95 lmh Added EVAL-WHEN for one of the MAKE-PACKAGE calls. ;;; CMU CL's RUN-PROGRAM is in the extensions package. ;;; ABSOLUTE-FILE-NAMESTRING-P was missing :test keyword ;;; Rearranged conditionalization in DIRECTORY-TO-LIST to ;;; suppress compiler warnings in CMU CL. ;;; 17-MAR-95 mk Added conditionalizations to avoid certain CMU CL compiler ;;; warnings reported by lmh. ;;; 19990610 ma Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed. ;;; 19991211 ma NEW VERSION 4.0 started. ;;; 19991211 ma Merged in changes requested by T. Russ of ;;; ISI. Please refer to the special "ISI" comments to ;;; understand these changes ;;; 20000228 ma The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM, ;;; COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer ;;; imported in the COMMON-LISP-USER package. ;;; Cfr. the definitions of *EXPORTS* and ;;; *SPECIAL-EXPORTS*. ;;; 2000-07-21 rlt Add COMPILER-OPTIONS to defstruct to allow user to ;;; specify special compiler options for a particular ;;; component. ;;; 2002-01-08 kmr Changed allegro symbols to lowercase to support ;;; case-sensitive images ;;;--------------------------------------------------------------------------- ;;; ISI Comments ;;; ;;; 19991211 Marco Antoniotti ;;; These comments come from the "ISI Branch". I believe I did ;;; include the :load-always extension correctly. The other commets ;;; seem superseded by other changes made to the system in the ;;; following years. Some others are now useless with newer systems ;;; (e.g. filename truncation for new Windows based CL ;;; implementations.) ;;; 1-OCT-92 tar Fixed problem with TI Lisp machines and append-directory. ;;; 1-OCT-92 tar Made major modifications to compile-file-operation and ;;; load-file-operation to reduce the number of probe-file ;;; and write-date inquiries. This makes the system run much ;;; faster through slow network connections. ;;; 13-OCT-92 tar Added :load-always slot to components. If this slot is ;;; specified as non-NIL, always loads the component. ;;; This does not trigger dependent compilation. ;;; (This can be useful when macro definitions needed ;;; during compilation are changed by later files. In ;;; this case, not reloading up-to-date files can ;;; cause different results.) ;;; 28-OCT-93 tar Allegro 4.2 causes an error on (pathname-device nil) ;;; 14-SEP-94 tar Disable importing of symbols into (CL-)USER package ;;; to minimize conflicts with other defsystem utilities. ;;; 10-NOV-94 tar Added filename truncation code to support Franz Allegro ;;; PC with it's 8 character filename limitation. ;;; 15-MAY-98 tar Changed host attribute for pathnames to support LispWorks ;;; (Windows) pathnames which reference other Drives. Also ;;; updated file name convention. ;;; 9-NOV-98 tar Updated new-append-directories for Lucid 5.0 ;;; ;;; ******************************** ;;; Ports ************************** ;;; ******************************** ;;; ;;; DEFSYSTEM has been tested (successfully) in the following lisps: ;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) ;;; CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach) ;;; CMU Common Lisp 17f (Python 1.0) ;;; Franz Allegro Common Lisp 3.1.12 (ExCL 3/30/90) ;;; Franz Allegro Common Lisp 4.0/4.1/4.2 ;;; Franz Allegro Common Lisp for Windows (2.0) ;;; Lucid Common Lisp (Version 2.1 6-DEC-87) ;;; Lucid Common Lisp (3.0 [SPARC,SUN3]) ;;; Lucid Common Lisp (4.0 [SPARC,SUN3]) ;;; VAXLisp (v2.2) [VAX/VMS] ;;; VAXLisp (v3.1) ;;; Harlequin LispWorks ;;; CLISP (CLISP3 [SPARC]) ;;; Symbolics XL12000 (Genera 8.3) ;;; Scieneer Common Lisp (SCL) 1.1 ;;; Macintosh Common Lisp ;;; ECL ;;; ;;; DEFSYSTEM needs to be tested in the following lisps: ;;; OpenMCL ;;; Symbolics Common Lisp (8.0) ;;; KCL (June 3, 1987 or later) ;;; AKCL (1.86, June 30, 1987 or later) ;;; TI (Release 4.1 or later) ;;; Ibuki Common Lisp (01/01, October 15, 1987) ;;; Golden Common Lisp (3.1 IBM-PC) ;;; HP Common Lisp (same as Lucid?) ;;; Procyon Common Lisp ;;; ******************************** ;;; To Do ************************** ;;; ******************************** ;;; ;;; COMPONENT-FULL-PATHNAME is a major source of slowness in the system ;;; because of all the calls to the expensive operations MAKE-PATHNAME ;;; and NAMESTRING. To improve performance, DEFSYSTEM should be reworked ;;; to avoid any need to call MAKE-PATHNAME and NAMESTRING, as the logical ;;; pathnames package does. Unfortunately, I don't have the time to do this ;;; right now. Instead, I installed a temporary improvement by memoizing ;;; COMPONENT-FULL-PATHNAME to cache previous calls to the function on ;;; a component by component and type by type basis. The cache is ;;; cleared before each call to OOS, in case filename extensions change. ;;; But DEFSYSTEM should really be reworked to avoid this problem and ;;; ensure greater portability and to also handle logical pathnames. ;;; ;;; Also, PROBE-FILE and FILE-WRITE-DATE are other sources of slowness. ;;; Perhaps by also memoizing FILE-WRITE-DATE and reimplementing PROBE-FILE ;;; in terms of FILE-WRITE-DATE, can achieve a further speed-up. This was ;;; suggested by Steven Feist (feist@ils.nwu.edu). ;;; ;;; True CLtL2 logical pathnames support -- can't do it, because CLtL2 ;;; doesn't have all the necessary primitives, and even in Allegro CL 4.2 ;;; (namestring #l"foo:bar;baz.lisp") ;;; does not work properly. ;;; ;;; Create separate stand-alone documentation for defsystem, and also ;;; a test suite. ;;; ;;; Change SYSTEM to be a class instead of a struct, and make it a little ;;; more generic, so that it permits alternate system definitions. ;;; Replace OPERATE-ON-SYSTEM with MAP-SYSTEM (args: function, system-name, ;;; &rest options) ;;; ;;; Add a patch directory mechanism. Perhaps have several directories ;;; with code in them, and the first one with the specified file wins? ;;; LOAD-PATCHES function. ;;; ;;; Need way to load old binaries even if source is newer. ;;; ;;; Allow defpackage forms/package definitions in the defsystem? If ;;; a package not defined, look for and load a file named package.pkg? ;;; ;;; need to port for GNU CL (ala kcl)? ;;; ;;; Someone asked whether one can have :file components at top-level. I believe ;;; this is the case, but should double-check that it is possible (and if ;;; not, make it so). ;;; ;;; A common error/misconception seems to involve assuming that :system ;;; components should include the name of the system file, and that ;;; defsystem will automatically load the file containing the system ;;; definition and propagate operations to it. Perhaps this would be a ;;; nice feature to add. ;;; ;;; If a module is :load-only t, then it should not execute its :finally-do ;;; and :initially-do clauses during compilation operations, unless the ;;; module's files happen to be loaded during the operation. ;;; ;;; System Class. Customizable delimiters. ;;; ;;; Load a system (while not loading anything already loaded) ;;; and inform the user of out of date fasls with the choice ;;; to load the old fasl or recompile and then load the new ;;; fasl? ;;; ;;; modify compile-file-operation to handle a query keyword.... ;;; ;;; Perhaps systems should keep around the file-write-date of the system ;;; definition file, to prevent excessive reloading of the system definition? ;;; ;;; load-file-operation needs to be completely reworked to simplify the ;;; logic of when files get loaded or not. ;;; ;;; Need to revamp output: Nesting and indenting verbose output doesn't ;;; seem cool, especially when output overflows the 80-column margins. ;;; ;;; Document various ways of writing a system. simple (short) form ;;; (where :components is just a list of filenames) in addition to verbose. ;;; Put documentation strings in code. ;;; ;;; :load-time for modules and systems -- maybe record the time the system ;;; was loaded/compiled here and print it in describe-system? ;;; ;;; Make it easy to define new functions that operate on a system. For ;;; example, a function that prints out a list of files that have changed, ;;; hardcopy-system, edit-system, etc. ;;; ;;; If a user wants to have identical systems for different lisps, do we ;;; force the user to use logical pathnames? Or maybe we should write a ;;; generic-pathnames package that parses any pathname format into a ;;; uniform underlying format (i.e., pull the relevant code out of ;;; logical-pathnames.lisp and clean it up a bit). ;;; ;;; Verify that Mac pathnames now work with append-directories. ;;; ;;; A common human error is to violate the modularization by making a file ;;; in one module depend on a file in another module, instead of making ;;; one module depend on the other. This is caught because the dependency ;;; isn't found. However, is there any way to provide a more informative ;;; error message? Probably not, especially if the system has multiple ;;; files of the same name. ;;; ;;; For a module none of whose files needed to be compiled, have it print out ;;; "no files need recompilation". ;;; ;;; Write a system date/time to a file? (version information) I.e., if the ;;; filesystem supports file version numbers, write an auxiliary file to ;;; the system definition file that specifies versions of the system and ;;; the version numbers of the associated files. ;;; ;;; Add idea of a patch directory. ;;; ;;; In verbose printout, have it log a date/time at start and end of ;;; compilation: ;;; Compiling system "test" on 31-Jan-91 21:46:47 ;;; by Defsystem version v2.0 01-FEB-91. ;;; ;;; Define other :force options: ;;; :query allows user to specify that a file not normally compiled ;;; should be. OR ;;; :confirm allows user to specify that a file normally compiled ;;; shouldn't be. AND ;;; ;;; We currently assume that compilation-load dependencies and if-changed ;;; dependencies are identical. However, in some cases this might not be ;;; true. For example, if we change a macro we have to recompile functions ;;; that depend on it (except in lisps that automatically do this, such ;;; as the new CMU Common Lisp), but not if we change a function. Splitting ;;; these apart (with appropriate defaulting) would be nice, but not worth ;;; doing immediately since it may save only a couple of file recompilations, ;;; while making defsystem much more complex than it already is. ;;; ;;; Current dependencies are limited to siblings. Maybe we should allow ;;; nephews and uncles? So long as it is still a DAG, we can sort it. ;;; Answer: No. The current setup enforces a structure on the modularity. ;;; Otherwise, why should we have modules if we're going to ignore it? ;;; ;;; Currently a file is recompiled more or less if the source is newer ;;; than the binary or if the file depends on a file that has changed ;;; (i.e., was recompiled in this session of a system operation). ;;; Neil Goldman has pointed out that whether a file ;;; needs recompilation is really independent of the current session of ;;; a system operation, and depends only on the file-write-dates of the ;;; source and binary files for a system. Thus a file should require ;;; recompilation in the following circumstances: ;;; 1. If a file's source is newer than its binary, or ;;; 2. If a file's source is not newer than its binary, but the file ;;; depends directly or indirectly on a module (or file) that is newer. ;;; For a regular file use the file-write-date (FWD) of the source or ;;; binary, whichever is more recent. For a load-only file, use the only ;;; available FWD. For a module, use the most recent (max) FWD of any of ;;; its components. ;;; The impact of this is that instead of using a boolean CHANGED variable ;;; throughout the code, we need to allow CHANGED to be NIL/T/ or ;;; maybe just the FWD timestamp, and to use the value of CHANGED in ;;; needs-compilation decisions. (Use of NIL/T as values is an optimization. ;;; The FWD timestamp which indicates the most recent time of any changes ;;; should be sufficient.) This will affect not just the ;;; compile-file-operation, but also the load-file-operation because of ;;; compilation during load. Also, since FWDs will be used more prevalently, ;;; we probably should couple this change with the inclusion of load-times ;;; in the component defstruct. This is a tricky and involved change, and ;;; requires more thought, since there are subtle cases where it might not ;;; be correct. For now, the change will have to wait until the DEFSYSTEM ;;; redesign. ;;; ******************************************************************** ;;; How to Use this System ********************************************* ;;; ******************************************************************** ;;; To use this system, ;;; 1. If you want to have a central registry of system definitions, ;;; modify the value of the variable *central-registry* below. ;;; 2. Load this file (defsystem.lisp) in either source or compiled form, ;;; 3. Load the file containing the "defsystem" definition of your system, ;;; 4. Use the function "operate-on-system" to do things to your system. ;;; For more information, see the documentation and examples in ;;; lisp-utilities.ps. ;;; ******************************** ;;; Usage Comments ***************** ;;; ******************************** ;;; If you use symbols in the system definition file, they get interned in ;;; the COMMON-LISP-USER package, which can lead to name conflicts when ;;; the system itself seeks to export the same symbol to the COMMON-LISP-USER ;;; package. The workaround is to use strings instead of symbols for the ;;; names of components in the system definition file. In the major overhaul, ;;; perhaps the user should be precluded from using symbols for such ;;; identifiers. ;;; ;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp", ;;; file name expansion is much slower than if you use the full pathname, ;;; as in "/user/USERID/lisp". ;;; ;;; **************************************************************** ;;; Lisp Code ****************************************************** ;;; **************************************************************** ;;; ******************************** ;;; Massage CLtL2 onto *features* ** ;;; ******************************** ;;; Let's be smart about CLtL2 compatible Lisps: (eval-when (compile load eval) #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl) (pushnew :cltl2 *features*)) ;;; ******************************** ;;; Provide/Require/*modules* ****** ;;; ******************************** ;;; Since CLtL2 has dropped require and provide from the language, some ;;; lisps may not have the functions PROVIDE and REQUIRE and the ;;; global *MODULES*. So if lisp::provide and user::provide are not ;;; defined, we define our own. ;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions ;;; and variables not being declared or bound, apparently because it ;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns ;;; T, so it doesn't really bother when compiling the body of the unless. ;;; The new compiler does this properly, so I'm not going to bother ;;; working around this. ;;; Some Lisp implementations return bogus warnings about assuming ;;; *MODULE-FILES* and *LIBRARY* to be special, and CANONICALIZE-MODULE-NAME ;;; and MODULE-FILES being undefined. Don't worry about them. ;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code ;;; necessary? #-(or :CMU :vms :mcl :lispworks :clisp :gcl :sbcl :cormanlisp :scl (and allegro-version>= (version>= 4 1))) (eval-when #-(or :lucid) (:compile-toplevel :load-toplevel :execute) #+(or :lucid) (compile load eval) (unless (or (fboundp 'lisp::require) (fboundp 'user::require) #+(and :excl (and allegro-version>= (version>= 4 0))) (fboundp 'cltl1::require) #+:lispworks (fboundp 'system::require)) #-:lispworks (in-package "LISP") #+:lispworks (in-package "SYSTEM") (export '(*modules* provide require)) ;; Documentation strings taken almost literally from CLtL1. (defvar *modules* () "List of names of the modules that have been loaded into Lisp so far. It is used by PROVIDE and REQUIRE.") ;; We provide two different ways to define modules. The default way ;; is to put either a source or binary file with the same name ;; as the module in the library directory. The other way is to define ;; the list of files in the module with defmodule. ;; The directory listed in *library* is implementation dependent, ;; and is intended to be used by Lisp manufacturers as a place to ;; store their implementation dependent packages. ;; Lisp users should use systems and *central-registry* to store ;; their packages -- it is intended that *central-registry* is ;; set by the user, while *library* is set by the lisp. (defvar *library* nil ; "/usr/local/lisp/Modules/" "Directory within the file system containing files, where the name of a file is the same as the name of the module it contains.") (defvar *module-files* (make-hash-table :test #'equal) "Hash table mapping from module names to list of files for the module. REQUIRE loads these files in order.") (defun canonicalize-module-name (name) ;; if symbol, string-downcase the printrep to make nicer filenames. (if (stringp name) name (string-downcase (string name)))) (defmacro defmodule (name &rest files) "Defines a module NAME to load the specified FILES in order." `(setf (gethash (canonicalize-module-name ,name) *module-files*) ',files)) (defun module-files (name) (gethash name *module-files*)) (defun provide (name) "Adds a new module name to the list of modules maintained in the variable *modules*, thereby indicating that the module has been loaded. Name may be a string or symbol -- strings are case-senstive, while symbols are treated like lowercase strings. Returns T if NAME was not already present, NIL otherwise." (let ((module (canonicalize-module-name name))) (unless (find module *modules* :test #'string=) ;; Module not present. Add it and return T to signify that it ;; was added. (push module *modules*) t))) (defun require (name &optional pathname) "Tests whether a module is already present. If the module is not present, loads the appropriate file or set of files. The pathname argument, if present, is a single pathname or list of pathnames whose files are to be loaded in order, left to right. If the pathname is nil, the system first checks if a module was defined using defmodule and uses the pathnames so defined. If that fails, it looks in the library directory for a file with name the same as that of the module. Returns T if it loads the module." (let ((module (canonicalize-module-name name))) (unless (find module *modules* :test #'string=) ;; Module is not already present. (when (and pathname (not (listp pathname))) ;; If there's a pathname or pathnames, ensure that it's a list. (setf pathname (list pathname))) (unless pathname ;; If there's no pathname, try for a defmodule definition. (setf pathname (module-files module))) (unless pathname ;; If there's still no pathname, try the library directory. (when *library* (setf pathname (concatenate 'string *library* module)) ;; Test if the file exists. ;; We assume that the lisp will default the file type ;; appropriately. If it doesn't, use #+".fasl" or some ;; such in the concatenate form above. (if (probe-file pathname) ;; If it exists, ensure we've got a list (setf pathname (list pathname)) ;; If the library file doesn't exist, we don't want ;; a load error. (setf pathname nil)))) ;; Now that we've got the list of pathnames, let's load them. (dolist (pname pathname t) (load pname :verbose nil)))))) ) ; eval-when ;;; ******************************** ;;; Set up Package ***************** ;;; ******************************** ;;; Unfortunately, lots of lisps have their own defsystems, some more ;;; primitive than others, all uncompatible, and all in the DEFSYSTEM ;;; package. To avoid name conflicts, we've decided to name this the ;;; MAKE package. A nice side-effect is that the short nickname ;;; MK is my initials. #+(or clisp cormanlisp ecl (and gcl defpackage) sbcl) (defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK")) #-(or :sbcl :cltl2 :lispworks :ecl :scl) (in-package "MAKE" :nicknames '("MK")) ;;; For CLtL2 compatible lisps... #+(and :excl :allegro-v4.0 :cltl2) (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) (:import-from cltl1 *modules* provide require)) ;;; *** Marco Antoniotti 19970105 ;;; In Allegro 4.1, 'provide' and 'require' are not external in ;;; 'CLTL1'. However they are in 'COMMON-LISP'. Hence the change. #+(and :excl :allegro-v4.1 :cltl2) (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) ) #+(and :excl :allegro-version>= (version>= 4 2)) (defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)) #+:lispworks (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") (:import-from "SYSTEM" *modules* provide require) ;madhu 080819 (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM" "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*")) #+:mcl (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") (:import-from ccl *modules* provide require)) ;;; *** Marco Antoniotti 19951012 ;;; The code below, is originally executed also for CMUCL. However I ;;; believe this is wrong, since CMUCL comes with its own defpackage. ;;; I added the extra :CMU in the 'or'. #+(and :cltl2 (not (or :cmu :clisp :sbcl (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl))) (eval-when (compile load eval) (unless (find-package "MAKE") (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP")))) ;;; *** Marco Antoniotti 19951012 ;;; Here I add the proper defpackage for CMU #+:CMU (defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS") (:nicknames "MK")) #+:sbcl (defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK")) #+:scl (defpackage :make (:use :common-lisp) (:nicknames :mk)) #+(or :cltl2 :lispworks :scl) (eval-when (compile load eval) (in-package "MAKE")) #+ecl (in-package "MAKE") ;;; *** Marco Antoniotti 19970105 ;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1 #+(and :excl :allegro-v4.0 :cltl2) (cltl1:provide 'make) #+(and :excl :allegro-v4.0 :cltl2) (provide 'make) #+:openmcl (cl:provide 'make) #+(and :mcl (not :openmcl)) (ccl:provide 'make) #+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl))) (provide 'make) #+:lispworks (provide 'make) #-(or :cltl2 :lispworks) (provide 'make) (pushnew :mk-defsystem *features*) ;;; Some compatibility issues. Mostly for CormanLisp. ;;; 2002-02-20 Marco Antoniotti #+cormanlisp (defun compile-file-pathname (pathname-designator) (merge-pathnames (make-pathname :type "fasl") (etypecase pathname-designator (pathname pathname-designator) (string (parse-namestring pathname-designator)) ;; We need FILE-STREAM here as well. ))) #+cormanlisp (defun file-namestring (pathname-designator) (let ((p (etypecase pathname-designator (pathname pathname-designator) (string (parse-namestring pathname-designator)) ;; We need FILE-STREAM here as well. ))) (namestring (make-pathname :directory () :name (pathname-name p) :type (pathname-type p) :version (pathname-version p))))) ;;; The external interface consists of *exports* and *other-exports*. ;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in ;;; the compile form, so that you can't use a defvar with a default value and ;;; then a succeeding export as well. (eval-when (compile load eval) (defvar *special-exports* nil) (defvar *exports* nil) (defvar *other-exports* nil) (export (setq *exports* '(operate-on-system oos afs-binary-directory afs-source-directory files-in-system))) (export (setq *special-exports* '())) (export (setq *other-exports* '(*central-registry* *bin-subdir* add-registry-location list-central-registry-directories print-central-registry-directories find-system defsystem compile-system load-system hardcopy-system system-definition-pathname missing-component missing-component-name missing-component-component missing-module missing-system register-foreign-system machine-type-translation software-type-translation compiler-type-translation ;; require define-language allegro-make-system-fasl files-which-need-compilation undefsystem defined-systems describe-system clean-system edit-system ;hardcopy-system system-source-size make-system-tag-table *defsystem-version* *compile-during-load* *minimal-load* *dont-redefine-require* *files-missing-is-an-error* *reload-systems-from-disk* *source-pathname-default* *binary-pathname-default* *multiple-lisp-support* run-unix-program *default-shell* run-shell-command ))) ) ;;; We import these symbols into the USER package to make them ;;; easier to use. Since some lisps have already defined defsystem ;;; in the user package, we may have to shadowing-import it. #| #-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics) (eval-when (compile load eval) (import *exports* #-(or :cltl2 :lispworks) "USER" #+(or :cltl2 :lispworks) "COMMON-LISP-USER") (import *special-exports* #-(or :cltl2 :lispworks) "USER" #+(or :cltl2 :lispworks) "COMMON-LISP-USER")) #+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics) (eval-when (compile load eval) (import *exports* #-(or :cltl2 :lispworks) "USER" #+(or :cltl2 :lispworks) "COMMON-LISP-USER") (shadowing-import *special-exports* #-(or :cltl2 :lispworks) "USER" #+(or :cltl2 :lispworks) "COMMON-LISP-USER")) |# #-(or :PCL :CLOS :scl) (when (find-package "PCL") (pushnew :pcl *modules*) (pushnew :pcl *features*)) ;;; ******************************** ;;; Defsystem Version ************** ;;; ******************************** (defparameter *defsystem-version* "3.6 Interim, 2005-09-01; madhu 080910" "Current version number/date for MK:DEFSYSTEM.") ;;; ******************************** ;;; Customizable System Parameters * ;;; ******************************** (defvar *dont-redefine-require* #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil) #+(or clisp sbcl) t #+allegro t #-(or cmu sbcl clisp allegro) nil "If T, prevents the redefinition of REQUIRE. This is useful for lisps that treat REQUIRE specially in the compiler.") (defvar *multiple-lisp-support* t "If T, afs-binary-directory will try to return a name dependent on the particular lisp compiler version being used.") ;;; home-subdirectory -- ;;; HOME-SUBDIRECTORY is used only in *central-registry* below. ;;; Note that CMU CL 17e does not understand the ~/ shorthand for home ;;; directories. ;;; ;;; Note: ;;; 20020220 Marco Antoniotti ;;; The #-cormanlisp version is the original one, which is broken anyway, since ;;; it is UNIX dependent. ;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing ;;; the ANSI USER-HOMEDIR-PATHNAME function. #-cormanlisp (defun home-subdirectory (directory) (concatenate 'string #+(or :sbcl :cmu :scl) "home:" #-(or :sbcl :cmu :scl) (let ((homedir (user-homedir-pathname))) (or (and homedir (namestring homedir)) "~/")) directory)) #+cormanlisp (defun home-subdirectory (directory) (declare (type string directory)) (concatenate 'string "C:\\" directory)) ;;; The following function is available for users to add ;;; (setq mk:*central-registry* (defsys-env-search-path)) ;;; to Lisp init files in order to use the value of the DEFSYSPATH ;;; instead of directly coding it in the file. #+:allegro (defun defsys-env-search-path () "This function grabs the value of the DEFSYSPATH environment variable and breaks the search path into a list of paths." (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:) :test #'string-equal)) ;;; Change this variable to set up the location of a central ;;; repository for system definitions if you want one. ;;; This is a defvar to allow users to change the value in their ;;; lisp init files without worrying about it reverting if they ;;; reload defsystem for some reason. ;;; Note that if a form is included in the registry list, it will be evaluated ;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check. (defvar *central-registry* `(;; Current directory "./" #+:LUCID (working-directory) #+ACLPC (current-directory) #+:allegro (excl:current-directory) #+:clisp (ext:default-directory) #+:sbcl (progn *default-pathname-defaults*) #+(or :cmu :scl) (ext:default-directory) ;; *** Marco Antoniotti ;; Somehow it is better to qualify default-directory in CMU with ;; the appropriate package (i.e. "EXTENSIONS".) ;; Same for Allegro. #+(and :lispworks (not :lispworks4) (not :lispworks5)) ,(multiple-value-bind (major minor) #-:lispworks-personal-edition (system::lispworks-version) #+:lispworks-personal-edition (values system::*major-version-number* system::*minor-version-number*) (if (or (> major 3) (and (= major 3) (> minor 2)) (and (= major 3) (= minor 2) (equal (lisp-implementation-version) "3.2.1"))) `(make-pathname :directory ,(find-symbol "*CURRENT-WORKING-DIRECTORY*" (find-package "SYSTEM"))) (find-symbol "*CURRENT-WORKING-DIRECTORY*" (find-package "LW")))) #+(or :lispworks4 :lispworks5) (hcl:get-working-directory) ;; Home directory #-sbcl (mk::home-subdirectory "lisp/systems/") ;; Global registry #+unix (pathname "/usr/local/lisp/Registry/") ) "Central directory of system definitions. May be either a single directory pathname, or a list of directory pathnames to be checked after the local directory.") (defun add-registry-location (pathname) "Adds a path to the central registry." (pushnew pathname *central-registry* :test #'equal)) (defun registry-pathname (registry) "Return the pathname represented by the element of *CENTRAL-REGISTRY*." (typecase registry (string (pathname registry)) (pathname registry) (otherwise (pathname (eval registry))))) (defun print-central-registry-directories (&optional (stream *standard-output*)) (dolist (registry *central-registry*) (print (registry-pathname registry) stream))) (defun list-central-registry-directories () (mapcar #'registry-pathname *central-registry*)) (defvar *bin-subdir* ".bin/" "The subdirectory of an AFS directory where the binaries are really kept.") ;;; These variables set up defaults for operate-on-system, and are used ;;; for communication in lieu of parameter passing. Yes, this is bad, ;;; but it keeps the interface small. Also, in the case of the -if-no-binary ;;; variables, parameter passing would require multiple value returns ;;; from some functions. Why make life complicated? (defvar *tell-user-when-done* nil "If T, system will print ...DONE at the end of an operation") (defvar *oos-verbose* nil "Operate on System Verbose Mode") (defvar *oos-test* nil "Operate on System Test Mode") (defvar *load-source-if-no-binary* nil "If T, system will try loading the source if the binary is missing") (defvar *bother-user-if-no-binary* t "If T, the system will ask the user whether to load the source if the binary is missing") (defvar *load-source-instead-of-binary* nil "If T, the system will load the source file instead of the binary.") (defvar *compile-during-load* :query "If T, the system will compile source files during load if the binary file is missing. If :query, it will ask the user for permission first.") (defvar *minimal-load* nil "If T, the system tries to avoid reloading files that were already loaded and up to date.") (defvar *files-missing-is-an-error* t "If both the source and binary files are missing, signal a continuable error instead of just a warning.") (defvar *operations-propagate-to-subsystems* t "If T, operations like :COMPILE and :LOAD propagate to subsystems of a system that are defined either using a component-type of :system or by another defsystem form.") ;;; Particular to CMULisp (defvar *compile-error-file-type* "err" "File type of compilation error file in cmulisp") (defvar *cmu-errors-to-terminal* t "Argument to :errors-to-terminal in compile-file in cmulisp") (defvar *cmu-errors-to-file* t "If T, cmulisp will write an error file during compilation") ;;; ******************************** ;;; Global Variables *************** ;;; ******************************** ;;; Massage people's *features* into better shape. (eval-when (compile load eval) (dolist (feature *features*) (when (and (symbolp feature) ; 3600 (equal (symbol-name feature) "CMU")) (pushnew :CMU *features*))) #+Lucid (when (search "IBM RT PC" (machine-type)) (pushnew :ibm-rt-pc *features*)) ) ;;; *filename-extensions* is a cons of the source and binary extensions. (defvar *filename-extensions* (car `(#+(and Symbolics Lispm) ("lisp" . "bin") #+(and dec common vax (not ultrix)) ("LSP" . "FAS") #+(and dec common vax ultrix) ("lsp" . "fas") #+ACLPC ("lsp" . "fsl") #+CLISP ("lisp" . "fas") #+KCL ("lsp" . "o") ;;#+ECL ("lsp" . "so") #+IBCL ("lsp" . "o") #+Xerox ("lisp" . "dfasl") ;; Lucid on Silicon Graphics #+(and Lucid MIPS) ("lisp" . "mbin") ;; the entry for (and lucid hp300) must precede ;; that of (and lucid mc68000) for hp9000/300's running lucid, ;; since *features* on hp9000/300's also include the :mc68000 ;; feature. #+(and lucid hp300) ("lisp" . "6bin") #+(and Lucid MC68000) ("lisp" . "lbin") #+(and Lucid Vax) ("lisp" . "vbin") #+(and Lucid Prime) ("lisp" . "pbin") #+(and Lucid SUNRise) ("lisp" . "sbin") #+(and Lucid SPARC) ("lisp" . "sbin") #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin") ;; PA is Precision Architecture, HP's 9000/800 RISC cpu #+(and Lucid PA) ("lisp" . "hbin") #+excl ("cl" . ,(pathname-type (compile-file-pathname "foo.cl"))) #+(or :cmu :scl) ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl")) ; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl") ; #+(and :CMU :sgi) ("lisp" . "sgif") ; #+(and :CMU :sparc) ("lisp" . "sparcf") #+PRIME ("lisp" . "pbin") #+HP ("l" . "b") #+TI ("lisp" . #.(string (si::local-binary-file-type))) #+:gclisp ("LSP" . "F2S") #+pyramid ("clisp" . "o") ;; Harlequin LispWorks #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*) ; #+(and :sun4 :lispworks) ("lisp" . "wfasl") ; #+(and :mips :lispworks) ("lisp" . "mfasl") #+:mcl ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp"))) #+:coral ("lisp" . "fasl") ;; Otherwise, ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp"))))) "Filename extensions for Common Lisp. A cons of the form (Source-Extension . Binary-Extension). If the system is unknown (as in *features* not known), defaults to lisp and fasl.") (defvar *system-extension* ;; MS-DOS systems can only handle three character extensions. #-ACLPC "system" #+ACLPC "sys" "The filename extension to use with systems.") ;;; The above variables and code should be extended to allow a list of ;;; valid extensions for each lisp implementation, instead of a single ;;; extension. When writing a file, the first extension should be used. ;;; But when searching for a file, every extension in the list should ;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and ;;; "lsp" (*load-source-types*) as source code extensions, and ;;; (c:backend-fasl-file-type c:*backend*) ;;; (c:backend-byte-fasl-file-type c:*backend*) ;;; and "fasl" as binary (object) file extensions (*load-object-types*). ;;; Note that the above code is used below in the LANGUAGE defstruct. ;;; There is no real support for this variable being nil, so don't change it. ;;; Note that in any event, the toplevel system (defined with defsystem) ;;; will have its dependencies delayed. Not having dependencies delayed ;;; might be useful if we define several systems within one defsystem. (defvar *system-dependencies-delayed* t "If T, system dependencies are expanded at run time") ;;; Replace this with consp, dammit! (defun non-empty-listp (list) (and list (listp list))) ;;; ******************************** ;;; Component Operation Definition * ;;; ******************************** (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *version-dir* nil "The version subdir. bound in operate-on-system.") (defvar *version-replace* nil "The version replace. bound in operate-on-system.") (defvar *version* nil "Default version.")) (defvar *component-operations* (make-hash-table :test #'equal) "Hash table of (operation-name function) pairs.") (defun component-operation (name &optional operation) (if operation (setf (gethash name *component-operations*) operation) (gethash name *component-operations*))) ;;; ******************************** ;;; AFS @sys immitator ************* ;;; ******************************** ;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out. #-:mcl (eval-when (compile load eval) ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo"). ;; For example, ;; #@"foo" ;; "foo/.bin/rt_mach/" (set-dispatch-macro-character #\# #\@ #'(lambda (stream char arg) (declare (ignore char arg)) `(afs-binary-directory ,(read stream t nil t))))) (defvar *find-irix-version-script* "\"1,4 d\\ s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ /./,$ d\\ \"") (defun operating-system-version () #+(and :sgi :excl) (let* ((full-version (software-version)) (blank-pos (search " " full-version)) (os (subseq full-version 0 blank-pos)) (version-rest (subseq full-version (1+ blank-pos))) os-version) (setq blank-pos (search " " version-rest)) (setq version-rest (subseq version-rest (1+ blank-pos))) (setq blank-pos (search " " version-rest)) (setq os-version (subseq version-rest 0 blank-pos)) (setq version-rest (subseq version-rest (1+ blank-pos))) (setq blank-pos (search " " version-rest)) (setq version-rest (subseq version-rest (1+ blank-pos))) (concatenate 'string os " " os-version)) ; " " version-rest #+(and :sgi :cmu :sbcl) (concatenate 'string (software-type) (software-version)) #+(and :lispworks :irix) (let ((soft-type (software-type))) (if (equalp soft-type "IRIX5") (progn (foreign:call-system (format nil "versions ~A | sed -e ~A > ~A" "eoe1" *find-irix-version-script* "irix-version") "/bin/csh") (with-open-file (s "irix-version") (format nil "IRIX ~S" (read s)))) soft-type)) #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix)) (software-type)) (defun compiler-version () #+:lispworks (concatenate 'string "lispworks" " " (lisp-implementation-version)) #+excl (concatenate 'string "excl" " " excl::*common-lisp-version-number*) #+sbcl (concatenate 'string "sbcl" " " (lisp-implementation-version)) #+cmu (concatenate 'string "cmu" " " (lisp-implementation-version)) #+scl (concatenate 'string "scl" " " (lisp-implementation-version)) #+kcl "kcl" #+IBCL "ibcl" #+akcl "akcl" #+gcl "gcl" #+ecl "ecl" #+lucid "lucid" #+ACLPC "aclpc" #+CLISP "clisp" #+Xerox "xerox" #+symbolics "symbolics" #+mcl "mcl" #+coral "coral" #+gclisp "gclisp" ) (defun afs-binary-directory (root-directory) ;; Function for obtaining the directory AFS's @sys feature would have ;; chosen when we're not in AFS. This function is useful as the argument ;; to :binary-pathname in defsystem. For example, ;; :binary-pathname (afs-binary-directory "scanner/") (let ((machine (machine-type-translation #-(and :sgi :allegro-version>= (version>= 4 2)) (machine-type) #+(and :sgi :allegro-version>= (version>= 4 2)) (machine-version))) (software (software-type-translation #-(and :sgi (or :cmu :sbcl :scl (and :allegro-version>= (version>= 4 2)))) (software-type) #+(and :sgi (or :cmu :sbcl :scl (and :allegro-version>= (version>= 4 2)))) (operating-system-version))) (lisp (compiler-type-translation (compiler-version)))) ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach (setq root-directory (namestring root-directory)) (setq root-directory (ensure-trailing-slash root-directory)) (format nil "~A~@[~A~]~@[~A/~]" root-directory *bin-subdir* (if *multiple-lisp-support* (afs-component machine software lisp) (afs-component machine software))))) (defun afs-source-directory (root-directory &optional version-flag) ;; Function for obtaining the directory AFS's @sys feature would have ;; chosen when we're not in AFS. This function is useful as the argument ;; to :source-pathname in defsystem. (setq root-directory (namestring root-directory)) (setq root-directory (ensure-trailing-slash root-directory)) (format nil "~A~@[~A/~]" root-directory (and version-flag (translate-version *version*)))) (defun null-string (s) (when (stringp s) (string-equal s ""))) (defun ensure-trailing-slash (dir) (if (and dir (not (null-string dir)) (not (char= (char dir (1- (length dir))) #\/)) (not (char= (char dir (1- (length dir))) #\\)) ) (concatenate 'string dir "/") dir)) (defun afs-component (machine software &optional lisp) (format nil "~@[~A~]~@[_~A~]~@[_~A~]" machine (or software "mach") lisp)) (defvar *machine-type-alist* (make-hash-table :test #'equal) "Hash table for retrieving the machine-type") (defun machine-type-translation (name &optional operation) (if operation (setf (gethash (string-upcase name) *machine-type-alist*) operation) (gethash (string-upcase name) *machine-type-alist*))) (machine-type-translation "IBM RT PC" "rt") (machine-type-translation "DEC 3100" "pmax") (machine-type-translation "DEC VAX-11" "vax") (machine-type-translation "DECstation" "pmax") (machine-type-translation "Sun3" "sun3") (machine-type-translation "Sun-4" "sun4") (machine-type-translation "MIPS Risc" "mips") (machine-type-translation "SGI" "sgi") (machine-type-translation "Silicon Graphics Iris 4D" "sgi") (machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi") (machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi") (machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi") (machine-type-translation "IP22" "sgi") ;;; MIPS R4000 Processor Chip Revision: 3.0 ;;; MIPS R4400 Processor Chip Revision: 5.0 ;;; MIPS R4600 Processor Chip Revision: 1.0 (machine-type-translation "IP20" "sgi") ;;; MIPS R4000 Processor Chip Revision: 3.0 (machine-type-translation "IP17" "sgi") ;;; MIPS R4000 Processor Chip Revision: 2.2 (machine-type-translation "IP12" "sgi") ;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0 (machine-type-translation "IP7" "sgi") ;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0 (machine-type-translation "x86" "x86") ;;; ACL (machine-type-translation "IBM PC Compatible" "x86") ;;; LW (machine-type-translation "I686" "x86") ;;; LW (machine-type-translation "PC/386" "x86") ;;; CLisp Win32 #+(and :lucid :sun :mc68000) (machine-type-translation "unknown" "sun3") (defvar *software-type-alist* (make-hash-table :test #'equal) "Hash table for retrieving the software-type") (defun software-type-translation (name &optional operation) (if operation (setf (gethash (string-upcase name) *software-type-alist*) operation) (gethash (string-upcase name) *software-type-alist*))) (software-type-translation "BSD UNIX" "mach") ; "unix" (software-type-translation "Ultrix" "mach") ; "ultrix" (software-type-translation "SunOS" "SunOS") (software-type-translation "MACH/4.3BSD" "mach") (software-type-translation "IRIX System V" "irix") ; (software-type) (software-type-translation "IRIX5" "irix5") ;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version) (software-type-translation "IRIX 5.2" "irix5") (software-type-translation "IRIX 5.3" "irix5") (software-type-translation "IRIX5.2" "irix5") (software-type-translation "IRIX5.3" "irix5") (software-type-translation "Linux" "linux") ; Lispworks for Linux (software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL (software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32") (software-type-translation "Windows NT" "win32") ; LW for Windows (software-type-translation "ANSI C program" "ansi-c") ; CLISP (software-type-translation "C compiler" "ansi-c") ; CLISP for Win32 (software-type-translation nil "") #+:lucid (software-type-translation "Unix" #+:lcl4.0 "4.0" #+(and :lcl3.0 (not :lcl4.0)) "3.0") (defvar *compiler-type-alist* (make-hash-table :test #'equal) "Hash table for retrieving the Common Lisp type") (defun compiler-type-translation (name &optional operation) (if operation (setf (gethash (string-upcase name) *compiler-type-alist*) operation) (gethash (string-upcase name) *compiler-type-alist*))) (compiler-type-translation "lispworks 3.2.1" "lispworks") (compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks") (compiler-type-translation "lispworks 4.2.0" "lispworks") #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (unless (or (find :case-sensitive common-lisp:*features*) (find :case-insensitive common-lisp:*features*)) (if (or (eq excl:*current-case-mode* :case-sensitive-lower) (eq excl:*current-case-mode* :case-sensitive-upper)) (push :case-sensitive common-lisp:*features*) (push :case-insensitive common-lisp:*features*)))) #+(and allegro case-sensitive ics) (compiler-type-translation "excl 6.1" "excl-m") #+(and allegro case-sensitive (not ics)) (compiler-type-translation "excl 6.1" "excl-m8") #+(and allegro case-insensitive ics) (compiler-type-translation "excl 6.1" "excl-a") #+(and allegro case-insensitive (not ics)) (compiler-type-translation "excl 6.1" "excl-a8") (compiler-type-translation "excl 4.2" "excl") (compiler-type-translation "excl 4.1" "excl") (compiler-type-translation "cmu 17f" "cmu") (compiler-type-translation "cmu 17e" "cmu") (compiler-type-translation "cmu 17d" "cmu") ;;; ******************************** ;;; System Names ******************* ;;; ******************************** ;;; If you use strings for system names, be sure to use the same case ;;; as it appears on disk, if the filesystem is case sensitive. (defun canonicalize-system-name (name) ;; Originally we were storing systems using GET. This meant that the ;; name of a system had to be a symbol, so we interned the symbols ;; in the keyword package to avoid package dependencies. Now that we're ;; storing the systems in a hash table, we've switched to using strings. ;; Since the hash table is case sensitive, we use uppercase strings. ;; (Names of modules and files may be symbols or strings.) #||(if (keywordp name) name (intern (string-upcase (string name)) "KEYWORD"))||# (if (stringp name) (string-upcase name) (string-upcase (string name)))) (defvar *defined-systems* (make-hash-table :test #'equal) "Hash table containing the definitions of all known systems.") (defun get-system (name) "Returns the definition of the system named NAME." (gethash (canonicalize-system-name name) *defined-systems*)) (defsetf get-system (name) (value) `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value)) (defun undefsystem (name) "Removes the definition of the system named NAME." (remhash (canonicalize-system-name name) *defined-systems*)) (defun defined-systems () "Returns a list of defined systems." (let ((result nil)) (maphash #'(lambda (key value) (declare (ignore key)) (push value result)) *defined-systems*) result)) (defun defined-names-and-systems () "Returns a a-list of defined systems along with their names." (loop for sname being the hash-keys of *defined-systems* using (hash-value s) collect (cons sname s))) ;;; ******************************** ;;; Directory Pathname Hacking ***** ;;; ******************************** ;;; Unix example: An absolute directory starts with / while a ;;; relative directory doesn't. A directory ends with /, while ;;; a file's pathname doesn't. This is important 'cause ;;; (pathname-directory "foo/bar") will return "foo" and not "foo/". ;;; I haven't been able to test the fix to the problem with symbolics ;;; hosts. Essentially, append-directories seems to have been tacking ;;; the default host onto the front of the pathname (e.g., mk::source-pathname ;;; gets a "B:" on front) and this overrides the :host specified in the ;;; component. The value of :host should override that specified in ;;; the :source-pathname and the default file server. If this doesn't ;;; fix things, specifying the host in the root pathname "F:>root-dir>" ;;; may be a good workaround. ;;; Need to verify that merging of pathnames where modules are located ;;; on different devices (in VMS-based VAXLisp) now works. ;;; Merge-pathnames works for VMS systems. In VMS systems, the directory ;;; part is enclosed in square brackets, e.g., ;;; "[root.child.child_child]" or "[root.][child.][child_child]" ;;; To concatenate directories merge-pathnames works as follows: ;;; (merge-pathnames "" "[root]") ==> "[root]" ;;; (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext" ;;; (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext" ;;; (merge-pathnames "[root]file.ext" "[son]") ==> "[root]file.ext" ;;; Thus the problem with the #-VMS code was that it was merging x y into ;;; [[x]][y] instead of [x][y] or [x]y. ;;; Miscellaneous notes: ;;; On GCLisp, the following are equivalent: ;;; "\\root\\subdir\\BAZ" ;;; "/root/subdir/BAZ" ;;; On VAXLisp, the following are equivalent: ;;; "[root.subdir]BAZ" ;;; "[root.][subdir]BAZ" ;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2 (defun new-append-directories (absolute-dir relative-dir) ;; Version of append-directories for CLtL2-compliant lisps. In particular, ;; they must conform to section 23.1.3 "Structured Directories". We are ;; willing to fix minor aberations in this function, but not major ones. ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100), ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0. (setf absolute-dir (or absolute-dir "") relative-dir (or relative-dir "")) (let* ((abs-dir (pathname absolute-dir)) (rel-dir (pathname relative-dir)) (host (pathname-host abs-dir)) (device (if (null-string absolute-dir) ; fix for CMU CL old compiler (pathname-device rel-dir) (pathname-device abs-dir))) (abs-directory (directory-to-list (pathname-directory abs-dir))) (abs-keyword (when (keywordp (car abs-directory)) (pop abs-directory))) ;; Stig (July 2001): ;; Somehow CLISP dies on the next line, but NIL is ok. (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name (rel-directory (directory-to-list (pathname-directory rel-dir))) (rel-keyword (when (keywordp (car rel-directory)) (pop rel-directory))) ;; rtoy: Why should any Lisp want rel-file? Shouldn't using ;; rel-name and rel-type work for every Lisp? #-(or :MCL :sbcl :clisp :cmu) (rel-file (file-namestring rel-dir)) ;; Stig (July 2001); ;; These values seems to help clisp as well #+(or :MCL :sbcl :clisp :cmu) (rel-name (pathname-name rel-dir)) #+(or :MCL :sbcl :clisp :cmu) (rel-type (pathname-type rel-dir)) (directory nil)) ;; TI Common Lisp pathnames can return garbage for file names because ;; of bizarreness in the merging of defaults. The following code makes ;; sure that the name is a valid name by comparing it with the ;; pathname-name. It also strips TI specific extensions and handles ;; the necessary case conversion. TI maps upper back into lower case ;; for unix files! #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal) (setf abs-name (string-right-trim "." (string-upcase abs-name))) (setf abs-name nil)) #+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal) (setf rel-file (string-right-trim "." (string-upcase rel-file))) (setf rel-file nil)) ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root) ;; and filename "foo". The namestring of a pathname with ;; directory '(:absolute :root "foo") ignores everything after the ;; :root. #+(and allegro-version>= (version>= 4 0)) (when (eq (car abs-directory) :root) (pop abs-directory)) #+(and allegro-version>= (version>= 4 0)) (when (eq (car rel-directory) :root) (pop rel-directory)) (when (and abs-name (not (null-string abs-name))) ; was abs-name (cond ((and (null abs-directory) (null abs-keyword)) #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative) (setf abs-directory (list abs-name))) (t (setf abs-directory (append abs-directory (list abs-name)))))) (when (and (null abs-directory) (or (null abs-keyword) ;; In Lucid, an abs-dir of nil gets a keyword of ;; :relative since (pathname-directory (pathname "")) ;; returns (:relative) instead of nil. #+:lucid (eq abs-keyword :relative)) rel-keyword) ;; The following feature switches seem necessary in CMUCL ;; Marco Antoniotti 19990707 #+(or :sbcl :CMU) (if (typep abs-dir 'logical-pathname) (setf abs-keyword :absolute) (setf abs-keyword rel-keyword)) #-(or :sbcl :CMU) (setf abs-keyword rel-keyword)) (setf directory (append abs-directory rel-directory)) (when abs-keyword (setf directory (cons abs-keyword directory))) (namestring (make-pathname :host host :device device :directory directory :name #-(or :sbcl :MCL :clisp :cmu) rel-file #+(or :sbcl :MCL :clisp :cmu) rel-name #+(or :sbcl :MCL :clisp :cmu) :type #+(or :sbcl :MCL :clisp :cmu) rel-type )))) (defun directory-to-list (directory) ;; The directory should be a list, but nonstandard implementations have ;; been known to use a vector or even a string. (cond ((listp directory) directory) ((stringp directory) (cond ((find #\; directory) ;; It's probably a logical pathname, so split at the ;; semicolons: (split-string directory :item #\;)) #+MCL ((and (find #\: directory) (not (find #\/ directory))) ;; It's probably a MCL pathname, so split at the colons. (split-string directory :item #\:)) (t ;; It's probably a unix pathname, so split at the slash. (split-string directory :item #\/)))) (t (coerce directory 'list)))) (defparameter *append-dirs-tests* '("~/foo/" "baz/bar.lisp" "~/foo" "baz/bar.lisp" "/foo/bar/" "baz/barf.lisp" "/foo/bar/" "/baz/barf.lisp" "foo/bar/" "baz/barf.lisp" "foo/bar" "baz/barf.lisp" "foo/bar" "/baz/barf.lisp" "foo/bar/" "/baz/barf.lisp" "/foo/bar/" nil "foo/bar/" nil "foo/bar" nil "foo" nil "foo" "" nil "baz/barf.lisp" nil "/baz/barf.lisp" nil nil)) (defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*)) (do* ((dir-list test-dirs (cddr dir-list)) (abs-dir (car dir-list) (car dir-list)) (rel-dir (cadr dir-list) (cadr dir-list))) ((null dir-list) (values)) (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S" abs-dir rel-dir (new-append-directories abs-dir rel-dir)))) #|| (test-new-append-directories) ABS: "~/foo/" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp" ABS: "~/foo" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp" ABS: "/foo/bar/" REL: "baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp" ABS: "/foo/bar/" REL: "/baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp" ABS: "foo/bar/" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" ABS: "foo/bar" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" ABS: "foo/bar" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" ABS: "foo/bar/" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" ABS: "/foo/bar/" REL: NIL Result: "/foo/bar/" ABS: "foo/bar/" REL: NIL Result: "foo/bar/" ABS: "foo/bar" REL: NIL Result: "foo/bar/" ABS: "foo" REL: NIL Result: "foo/" ABS: "foo" REL: "" Result: "foo/" ABS: NIL REL: "baz/barf.lisp" Result: "baz/barf.lisp" ABS: NIL REL: "/baz/barf.lisp" Result: "/baz/barf.lisp" ABS: NIL REL: NIL Result: "" ||# (defun append-directories (absolute-directory relative-directory) "There is no CL primitive for tacking a subdirectory onto a directory. We need such a function because defsystem has both absolute and relative pathnames in the modules. This is a somewhat ugly hack which seems to work most of the time. We assume that ABSOLUTE-DIRECTORY is a directory, with no filename stuck on the end. Relative-directory, however, may have a filename stuck on the end." (when (or absolute-directory relative-directory) (cond ;; KMR commented out because: when appending two logical pathnames, ;; using this code translates the first logical pathname then appends ;; the second logical pathname -- an error. #| ;; We need a reliable way to determine if a pathname is logical. ;; Allegro 4.1 does not recognize the syntax of a logical pathname ;; as being logical unless its logical host is already defined. #+(or (and allegro-version>= (version>= 4 1)) :logical-pathnames-mk) ((and absolute-directory (logical-pathname-p absolute-directory) relative-directory) ;; For use with logical pathnames package. (append-logical-directories-mk absolute-directory relative-directory)) |# #+NIL ; madhu 060906 ((namestring-probably-logical absolute-directory) ;; A simplistic stab at handling logical pathnames (append-logical-pnames absolute-directory relative-directory)) (t ;; In VMS, merge-pathnames actually does what we want!!! #+:VMS (namestring (merge-pathnames (or absolute-directory "") (or relative-directory ""))) #+:macl1.3.2 (namestring (make-pathname :directory absolute-directory :name relative-directory)) ;; Cross your fingers and pray. #-(or :VMS :macl1.3.2) (new-append-directories absolute-directory relative-directory))))) #+:logical-pathnames-mk (defun append-logical-directories-mk (absolute-dir relative-dir) (lp:append-logical-directories absolute-dir relative-dir)) ;;; append-logical-pathnames-mk -- ;;; The following is probably still bogus and it does not solve the ;;; problem of appending two logical pathnames. ;;; Anyway, as per suggetsion by KMR, the function is not called ;;; anymore. ;;; Hopefully this will not cause problems for ACL. #+(and (and allegro-version>= (version>= 4 1)) (not :logical-pathnames-mk)) (defun append-logical-directories-mk (absolute-dir relative-dir) ;; We know absolute-dir and relative-dir are non nil. Moreover ;; absolute-dir is a logical pathname. (setq absolute-dir (logical-pathname absolute-dir)) (etypecase relative-dir (string (setq relative-dir (parse-namestring relative-dir))) (pathname #| do nothing |#)) (translate-logical-pathname (merge-pathnames relative-dir absolute-dir))) #| Old version 2002-03-02 #+(and (and allegro-version>= (version>= 4 1)) (not :logical-pathnames-mk)) (defun append-logical-directories-mk (absolute-dir relative-dir) ;; We know absolute-dir and relative-dir are non nil. Moreover ;; absolute-dir is a logical pathname. (setq absolute-dir (logical-pathname absolute-dir)) (etypecase relative-dir (string (setq relative-dir (parse-namestring relative-dir))) (pathname #| do nothing |#)) (translate-logical-pathname (make-pathname :host (or (pathname-host absolute-dir) (pathname-host relative-dir)) :directory (append (pathname-directory absolute-dir) (cdr (pathname-directory relative-dir))) :name (or (pathname-name absolute-dir) (pathname-name relative-dir)) :type (or (pathname-type absolute-dir) (pathname-type relative-dir)) :version (or (pathname-version absolute-dir) (pathname-version relative-dir))))) ;; Old version #+(and (and allegro-version>= (version>= 4 1)) (not :logical-pathnames-mk)) (defun append-logical-directories-mk (absolute-dir relative-dir) (when (or absolute-dir relative-dir) (setq absolute-dir (logical-pathname (or absolute-dir "")) relative-dir (logical-pathname (or relative-dir ""))) (translate-logical-pathname (make-pathname :host (or (pathname-host absolute-dir) (pathname-host relative-dir)) :directory (append (pathname-directory absolute-dir) (cdr (pathname-directory relative-dir))) :name (or (pathname-name absolute-dir) (pathname-name relative-dir)) :type (or (pathname-type absolute-dir) (pathname-type relative-dir)) :version (or (pathname-version absolute-dir) (pathname-version relative-dir)))))) |# ;;; determines if string or pathname object is logical #+:logical-pathnames-mk (defun logical-pathname-p (thing) (eq (lp:pathname-host-type thing) :logical)) ;;; From Kevin Layer for 4.1final. #+(and (and allegro-version>= (version>= 4 1)) (not :logical-pathnames-mk)) (defun logical-pathname-p (thing) (typep (parse-namestring thing) 'logical-pathname)) (defun pathname-logical-p (thing) (typecase thing (logical-pathname t) #+clisp ; CLisp has non conformant Logical Pathnames. (pathname (pathname-logical-p (namestring thing))) (string (and (= 1 (count #\: thing)) ; Shortcut. (ignore-errors (translate-logical-pathname thing)) t)) (t nil))) ;;; This affects only one thing. ;;; 19990707 Marco Antoniotti ;;; old version (defun namestring-probably-logical (namestring) (and (stringp namestring) ;; unix pathnames don't have embedded semicolons (find #\; namestring))) #|| ;;; New version (defun namestring-probably-logical (namestring) (and (stringp namestring) (typep (parse-namestring namestring) 'logical-pathname))) ;;; New new version ;;; 20000321 Marco Antoniotti (defun namestring-probably-logical (namestring) (pathname-logical-p namestring)) ||# #|| This is incorrect, as it strives to keep strings around, when it shouldn't. MERGE-PATHNAMES already DTRT. (defun append-logical-pnames (absolute relative) (declare (type (or null string pathname) absolute relative)) (let ((abs (if absolute #-clisp (namestring absolute) #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string "")) (rel (if relative (namestring relative) "")) ) ;; Make sure the absolute directory ends with a semicolon unless ;; the pieces are null strings (unless (or (null-string abs) (null-string rel) (char= (char abs (1- (length abs))) #\;)) (setq abs (concatenate 'string abs ";"))) ;; Return the concatenate pathnames (concatenate 'string abs rel))) ||# (defun append-logical-pnames (absolute relative) (declare (type (or null string pathname) absolute relative)) (let ((abs (if absolute (pathname absolute) (make-pathname :directory (list :absolute) :name nil :type nil) )) (rel (if relative (pathname relative) (make-pathname :directory (list :relative) :name nil :type nil) )) ) ;; The following is messed up because CMUCL and LW use different ;; defaults for host (in particular LW uses NIL). Thus ;; MERGE-PATHNAMES has legitimate different behaviors on both ;; implementations. Of course this is disgusting, but that is the ;; way it is and the rest tries to circumvent this crap. (etypecase abs (logical-pathname (etypecase rel (logical-pathname (namestring (merge-pathnames rel abs))) (pathname ;; The following potentially translates the logical pathname ;; very early, but we cannot avoid it. (namestring (merge-pathnames rel (translate-logical-pathname abs) nil))) )) (pathname (namestring (merge-pathnames rel abs))) ))) #|| ;;; This was a try at appending a subdirectory onto a directory. ;;; It failed. We're keeping this around to prevent future mistakes ;;; of a similar sort. (defun merge-directories (absolute-directory relative-directory) ;; replace concatenate with something more intelligent ;; i.e., concatenation won't work with some directories. ;; it should also behave well if the parent directory ;; has a filename at the end, or if the relative-directory ain't relative (when absolute-directory (setq absolute-directory (pathname-directory absolute-directory))) (concatenate 'string (or absolute-directory "") (or relative-directory ""))) ||# #|| (defun d (d n) (namestring (make-pathname :directory d :name n))) D (d "~/foo/" "baz/bar.lisp") "/usr0/mkant/foo/baz/bar.lisp" (d "~/foo" "baz/bar.lisp") "/usr0/mkant/foo/baz/bar.lisp" (d "/foo/bar/" "baz/barf.lisp") "/foo/bar/baz/barf.lisp" (d "foo/bar/" "baz/barf.lisp") "foo/bar/baz/barf.lisp" (d "foo/bar" "baz/barf.lisp") "foo/bar/baz/barf.lisp" (d "foo/bar" "/baz/barf.lisp") "foo/bar//baz/barf.lisp" (d "foo/bar" nil) "foo/bar/" (d nil "baz/barf.lisp") "baz/barf.lisp" (d nil nil) "" ||# ;;; The following is a change proposed by DTC for SCL. ;;; Maybe it could be used all the time. #-scl (defun new-file-type (pathname type) ;; why not (make-pathname :type type :defaults pathname)? (make-pathname :host (pathname-host pathname) :device (pathname-device pathname) :directory (pathname-directory pathname) :name (pathname-name pathname) :type type :version (pathname-version pathname))) #+scl (defun new-file-type (pathname type) ;; why not (make-pathname :type type :defaults pathname)? (make-pathname :host (pathname-host pathname :case :common) :device (pathname-device pathname :case :common) :directory (pathname-directory pathname :case :common) :name (pathname-name pathname :case :common) :type (string-upcase type) :version (pathname-version pathname :case :common))) ;;; ******************************** ;;; Component Defstruct ************ ;;; ******************************** (defvar *source-pathname-default* nil "Default value of :source-pathname keyword in DEFSYSTEM. Set this to \"\" to avoid having to type :source-pathname \"\" all the time.") (defvar *binary-pathname-default* nil "Default value of :binary-pathname keyword in DEFSYSTEM.") (defstruct (topological-sort-node (:conc-name topsort-)) (color :white :type (member :gray :black :white)) ) (defparameter *component-evaluated-slots* '(:source-root-dir :source-pathname :source-extension :binary-root-dir :binary-pathname :binary-extension)) (defparameter *component-form-slots* '(:initially-do :finally-do :compile-form :load-form)) (defstruct (component (:include topological-sort-node) (:print-function print-component)) (type :file ; to pacify the CMUCL compiler (:type is alway supplied) :type (member :defsystem :system :subsystem :module :file :private-file )) (name nil :type (or symbol string)) (indent 0 :type (mod 1024)) ; Number of characters of indent in ; verbose output to the user. host ; The pathname host (i.e., "/../a"). device ; The pathname device. source-root-dir ; Relative or absolute (starts ; with "/"), directory or file ; (ends with "/"). (source-pathname *source-pathname-default*) source-extension ; A string, e.g., "lisp" ; if NIL, inherit (binary-pathname *binary-pathname-default*) binary-root-dir binary-extension ; A string, e.g., "fasl". If ; NIL, uses default for ; machine-type. package ; Package for use-package. ;; The following three slots are used to provide for alternate compilation ;; and loading functions for the files contained within a component. If ;; a component has a compiler or a loader specified, those functions are ;; used. Otherwise the functions are derived from the language. If no ;; language is specified, it defaults to Common Lisp (:lisp). Other current ;; possible languages include :scheme (PseudoScheme) and :c, but the user ;; can define additional language mappings. Compilation functions should ;; accept a pathname argument and a :output-file keyword; loading functions ;; just a pathname argument. The default functions are #'compile-file and ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to ;; mix languages. (language nil :type (or null symbol)) (compiler nil :type (or null symbol function)) (loader nil :type (or null symbol function)) (compiler-options nil :type list) ; A list of compiler options to ; use for compiling this ; component. These must be ; keyword options supported by ; the compiler. (components () :type list) ; A list of components ; comprising this component's ; definition. (depends-on () :type list) ; A list of the components ; this one depends on. may ; refer only to the components ; at the same level as this ; one. proclamations ; Compiler options, such as ; '(optimize (safety 3)). (initially-do (lambda () nil)) ; Form to evaluate before the ; operation. (finally-do (lambda () nil)) ; Form to evaluate after the operation. (compile-form (lambda () nil)) ; For foreign libraries. (load-form (lambda () nil)) ; For foreign libraries. ;; load-time ; The file-write-date of the ; binary/source file loaded. ;; If load-only is T, will not compile the file on operation :compile. ;; In other words, for files which are :load-only T, loading the file ;; satisfies any demand to recompile. load-only ; If T, will not compile this ; file on operation :compile. ;; If compile-only is T, will not load the file on operation :compile. ;; Either compiles or loads the file, but not both. In other words, ;; compiling the file satisfies the demand to load it. This is useful ;; for PCL defmethod and defclass definitions, which wrap a ;; (eval-when (compile load eval) ...) around the body of the definition. ;; This saves time in some lisps. compile-only ; If T, will not load this ; file on operation :compile. #|| ISI Extension ||# load-always ; If T, will force loading ; even if file has not ; changed. ;; PVE: add banner (banner nil :type (or null string)) (documentation nil :type (or null string)) ; Optional documentation slot (long-documentation nil :type (or null string)) ; Optional long documentation slot ;; Added AUTHOR, MAINTAINER, VERSION and LICENCE slots. (author nil :type (or null string)) (licence nil :type (or null string)) (maintainer nil :type (or null string)) (version nil :type (or null string)) ;; Added NON-REQUIRED-P slot. Useful for optional items. (non-required-p nil :type boolean) ; If T a missing file or ; sub-directory will not cause ; an error. ) ;;; To allow dependencies from "foreign systems" like ASDF or one of ;;; the proprietary ones like ACL or LW. (defstruct (foreign-system (:include component (type :system))) kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...) object ; The actual foreign system object. ) (defun register-foreign-system (name &key representation kind) (declare (type (or symbol string) name)) (let ((fs (make-foreign-system :name name :kind kind :object representation))) (setf (get-system name) fs))) (define-condition missing-component (simple-condition) ((name :reader missing-component-name :initarg :name) (component :reader missing-component-component :initarg :component) ) #-gcl (:default-initargs :component nil) (:report (lambda (mmc stream) (format stream "MK:DEFSYSTEM: missing component ~S for ~S." (missing-component-name mmc) (missing-component-component mmc)))) ) (define-condition missing-module (missing-component) () (:report (lambda (mmc stream) (format stream "MK:DEFSYSTEM: missing module ~S for ~S." (missing-component-name mmc) (missing-component-component mmc)))) ) (define-condition missing-system (missing-module) () (:report (lambda (msc stream) (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]." (missing-component-name msc) (missing-component-component msc)))) ) (defvar *file-load-time-table* (make-hash-table :test #'equal) "Hash table of file-write-dates for the system definitions and files in the system definitions.") (defun component-load-time (component) (when component (etypecase component (string (gethash component *file-load-time-table*)) (pathname (gethash (namestring component) *file-load-time-table*)) (component (ecase (component-type component) (:defsystem (let* ((name (component-name component)) (path (when name (compute-system-path name nil)))) (declare (type (or string pathname null) path)) (when path (gethash (namestring path) *file-load-time-table*)))) ((:file :private-file) ;; Use only :source pathname to identify component's ;; load time. (let ((path (component-full-pathname component :source))) (when path (gethash path *file-load-time-table*))))))))) #-(or :cmu) (defsetf component-load-time (component) (value) `(when ,component (etypecase ,component (string (setf (gethash ,component *file-load-time-table*) ,value)) (pathname (setf (gethash (namestring (the pathname ,component)) *file-load-time-table*) ,value)) (component (ecase (component-type ,component) (:defsystem (let* ((name (component-name ,component)) (path (when name (compute-system-path name nil)))) (declare (type (or string pathname null) path)) (when path (setf (gethash (namestring path) *file-load-time-table*) ,value)))) ((:file :private-file) ;; Use only :source pathname to identify file. (let ((path (component-full-pathname ,component :source))) (when path (setf (gethash path *file-load-time-table*) ,value))))))) ,value)) #+(or :cmu) (defun (setf component-load-time) (value component) (declare (type (or null string pathname component) component) (type (or unsigned-byte null) value)) (when component (etypecase component (string (setf (gethash component *file-load-time-table*) value)) (pathname (setf (gethash (namestring (the pathname component)) *file-load-time-table*) value)) (component (ecase (component-type component) (:defsystem (let* ((name (component-name component)) (path (when name (compute-system-path name nil)))) (declare (type (or string pathname null) path)) (when path (setf (gethash (namestring path) *file-load-time-table*) value)))) ((:file :private-file) ;; Use only :source pathname to identify file. (let ((path (component-full-pathname component :source))) (when path (setf (gethash path *file-load-time-table*) value))))))) value)) ;;; compute-system-path -- (defun compute-system-path (module-name definition-pname) (let* ((module-string-name (etypecase module-name (symbol (string-downcase (string module-name))) (string module-name))) (file-pathname (make-pathname :name module-string-name :type *system-extension*)) (lib-file-pathname (make-pathname :directory (list :relative module-string-name) :name module-string-name :type *system-extension*)) ) (or (when definition-pname ; given pathname for system def (probe-file definition-pname)) ;; Then the central registry. Note that we also check the current ;; directory in the registry, but the above check is hard-coded. (cond (*central-registry* (if (listp *central-registry*) (dolist (registry *central-registry*) (let* ((reg-path (registry-pathname registry)) (file (or (probe-file (append-directories reg-path file-pathname)) (probe-file (append-directories reg-path lib-file-pathname))))) (when file (return file)))) (or (probe-file (append-directories *central-registry* file-pathname)) (probe-file (append-directories *central-registry* lib-file-pathname)) )) ) (t ;; No central registry. Assume current working directory. ;; Maybe this should be an error? (or (probe-file file-pathname) (probe-file lib-file-pathname))))) )) (defun system-definition-pathname (system-name) (let ((system (ignore-errors (find-system system-name :error)))) (if system (let ((system-def-pathname (make-pathname :type "system" :defaults (pathname (component-full-pathname system :source)))) ) (values system-def-pathname (probe-file system-def-pathname))) (values nil nil)))) #| (defun compute-system-path (module-name definition-pname) (let* ((filename (format nil "~A.~A" (if (symbolp module-name) (string-downcase (string module-name)) module-name) *system-extension*))) (or (when definition-pname ; given pathname for system def (probe-file definition-pname)) ;; Then the central registry. Note that we also check the current ;; directory in the registry, but the above check is hard-coded. (cond (*central-registry* (if (listp *central-registry*) (dolist (registry *central-registry*) (let ((file (probe-file (append-directories (registry-pathname registry) filename)))) (when file (return file)))) (probe-file (append-directories *central-registry* filename)))) (t ;; No central registry. Assume current working directory. ;; Maybe this should be an error? (probe-file filename)))))) |# (defvar *reload-systems-from-disk* t "If T, always tries to reload newer system definitions from disk. Otherwise first tries to find the system definition in the current environment.") (defun find-system (system-name &optional (mode :ask) definition-pname) "Returns the system named SYSTEM-NAME. If not already loaded, loads it, depending on the value of *RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK, :ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default. This allows OPERATE-ON-SYSTEM to work on non-loaded as well as loaded system definitions. DEFINITION-PNAME is the pathname for the system definition, if provided." (ecase mode (:ask (or (get-system system-name) (when (y-or-n-p-wait #\y 20 "System ~A not loaded. Shall I try loading it? " system-name) (find-system system-name :load definition-pname)))) (:error (or (get-system system-name) (error 'missing-system :name system-name))) (:load-or-nil (let ((system (get-system system-name))) ;; (break "System ~S ~S." system-name system) (or (unless *reload-systems-from-disk* system) ;; If SYSTEM-NAME is a symbol, it will lowercase the ;; symbol's string. ;; If SYSTEM-NAME is a string, it doesn't change the case of the ;; string. So if case matters in the filename, use strings, not ;; symbols, wherever the system is named. (when (foreign-system-p system) (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system) (return-from find-system nil)) (let ((path (compute-system-path system-name definition-pname))) (when (and path (or (null system) (null (component-load-time path)) (< (component-load-time path) (file-write-date path)))) (tell-user-generic (format nil "Loading system ~A from file ~A" system-name path)) (load path) (setf system (get-system system-name)) (when system (setf (component-load-time path) (file-write-date path)))) system) system))) (:load (or (unless *reload-systems-from-disk* (get-system system-name)) (when (foreign-system-p (get-system system-name)) (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." (get-system system-name)) (return-from find-system nil)) (or (find-system system-name :load-or-nil definition-pname) (error "Can't find system named ~s." system-name)))))) (defun print-component (component stream depth) (declare (ignore depth)) (format stream "#<~:@(~A~): ~A>" (component-type component) (component-name component))) (defun describe-system (name &optional (stream *standard-output*)) "Prints a description of the system to the stream. If NAME is the name of a system, gets it and prints a description of the system. If NAME is a component, prints a description of the component." (let ((system (if (typep name 'component) name (find-system name :load)))) (format stream "~&~A ~A: ~ ~@[~& Host: ~A~]~ ~@[~& Device: ~A~]~ ~@[~& Package: ~A~]~ ~& Source: ~@[~A~] ~@[~A~] ~@[~A~]~ ~& Binary: ~@[~A~] ~@[~A~] ~@[~A~]~ ~@[~& Depends On: ~A ~]~& Components:~{~15T~A~&~}" (component-type system) (component-name system) (component-host system) (component-device system) (component-package system) (component-root-dir system :source) (component-pathname system :source) (component-extension system :source) (component-root-dir system :binary) (component-pathname system :binary) (component-extension system :binary) (component-depends-on system) (component-components system)) #||(when recursive (dolist (component (component-components system)) (describe-system component stream recursive)))||# system)) (defun canonicalize-component-name (component) ;; Within the component, the name is a string. (if (typep (component-name component) 'string) ;; Unnecessary to change it, so just return it, same case (component-name component) ;; Otherwise, make it a downcase string -- important since file ;; names are often constructed from component names, and unix ;; prefers lowercase as a default. (setf (component-name component) (string-downcase (string (component-name component)))))) (defun component-pathname (component type) (when component (ecase type (:source (component-source-pathname component)) (:binary (component-binary-pathname component)) (:error (component-error-pathname component))))) (defun component-error-pathname (component) (let ((binary (component-pathname component :binary))) (new-file-type binary *compile-error-file-type*))) (defsetf component-pathname (component type) (value) `(when ,component (ecase ,type (:source (setf (component-source-pathname ,component) ,value)) (:binary (setf (component-binary-pathname ,component) ,value))))) (defun component-root-dir (component type) (when component (ecase type (:source (component-source-root-dir component)) ((:binary :error) (component-binary-root-dir component)) ))) (defsetf component-root-dir (component type) (value) `(when ,component (ecase ,type (:source (setf (component-source-root-dir ,component) ,value)) (:binary (setf (component-binary-root-dir ,component) ,value))))) (defvar *source-pathnames-table* (make-hash-table :test #'equal) "Table which maps from components to full source pathnames.") (defvar *binary-pathnames-table* (make-hash-table :test #'equal) "Table which maps from components to full binary pathnames.") (defparameter *reset-full-pathname-table* t "If T, clears the full-pathname tables before each call to OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could result in changes to system and language definitions to not take effect, and so should be used with caution.") (defun clear-full-pathname-tables () (clrhash *source-pathnames-table*) (clrhash *binary-pathnames-table*)) (defun component-full-pathname (component type &optional (version *version*)) (when component (case type (:source (let ((old (gethash component *source-pathnames-table*))) (or old (let ((new (component-full-pathname-i component type version))) (setf (gethash component *source-pathnames-table*) new) new)))) (:binary (let ((old (gethash component *binary-pathnames-table*))) (or old (let ((new (component-full-pathname-i component type version))) (setf (gethash component *binary-pathnames-table*) new) new)))) (otherwise (component-full-pathname-i component type version))))) (defun component-full-pathname-i (component type &optional (version *version*) &aux version-dir version-replace) ;; If the pathname-type is :binary and the root pathname is null, ;; distribute the binaries among the sources (= use :source pathname). ;; This assumes that the component's :source pathname has been set ;; before the :binary one. (if version (multiple-value-setq (version-dir version-replace) (translate-version version)) (setq version-dir *version-dir* version-replace *version-replace*)) ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace) (let ((pathname (append-directories (if version-replace version-dir (append-directories (component-root-dir component type) version-dir)) (component-pathname component type)))) ;; When a logical pathname is used, it must first be translated to ;; a physical pathname. This isn't strictly correct. What should happen ;; is we fill in the appropriate slots of the logical pathname, and ;; then return the logical pathname for use by compile-file & friends. ;; But calling translate-logical-pathname to return the actual pathname ;; should do for now. ;; (format t "pathname = ~A~%" pathname) ;; (format t "type = ~S~%" (component-extension component type)) ;; 20000303 Marco Antoniotti ;; Changed the following according to suggestion by Ray Toy. I ;; just collapsed the tests for "logical-pathname-ness" into a ;; single test (heavy, but probably very portable) and added the ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES ;; beacuse of possible null names (e.g. :defsystem components) ;; causing problems with the subsequenct call to NAMESTRING. ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname) ;; 20050309 Marco Antoniotti ;; The treatment of PATHNAME-HOST and PATHNAME-DEVICE in the call ;; to MAKE-PATHNAME in the T branch is bogus. COMPONENT-DEVICE ;; and COMPONENT-HOST must respect the ANSI definition, hence, ;; they cannot be PATHNAMEs. The simplification of the code is ;; useful. SCL compatibility may be broken, but I doubt it will. ;; 20050310 Marco Antoniotti ;; After a suggestion by David Tolpin, the code is simplified even ;; more, and the logic should be now more clear: use the user ;; supplied pieces of the pathname if non nil. ;; 20050613 Marco Antoniotti ;; Added COMPONENT-NAME extraction to :NAME part, in case the ;; PATHNAME-NAME is NIL. ;;;madhu 060520 (PATHNAME pathname) or search-hosts are logical (cond ((pathname-logical-p (pathname pathname)) ; See definition of test above. (setf pathname (merge-pathnames pathname (make-pathname ;madhu 080208 (lw) :name (or (pathname-name pathname) (component-name component)) :type (component-extension component type)))) (namestring (translate-logical-pathname pathname))) (t (namestring (make-pathname :host (or (component-host component) (pathname-host pathname)) :directory (pathname-directory pathname #+scl :case #+scl :common ) :name (or (pathname-name pathname #+scl :case #+scl :common ) (component-name component)) :type #-scl (component-extension component type) #+scl (string-upcase (component-extension component type)) :device #+sbcl :unspecific #-(or :sbcl) (or (component-device component) (pathname-device pathname #+scl :case #+scl :common )) ;; :version :newest )))))) #-lispworks (defun translate-version (version) ;; Value returns the version directory and whether it replaces ;; the entire root (t) or is a subdirectory. ;; Version may be nil to signify no subdirectory, ;; a symbol, such as alpha, beta, omega, :alpha, mark, which ;; specifies a subdirectory of the root, or ;; a string, which replaces the root. (cond ((null version) (values "" nil)) ((symbolp version) (values (let ((sversion (string version))) (if (find-if #'lower-case-p sversion) sversion (string-downcase sversion))) nil)) ((stringp version) (values version t)) (t (error "~&; Illegal version ~S" version)))) ;;; Looks like LW has a bug in MERGE-PATHNAMES. ;;; ;;; (merge-pathnames "" "LP:foo;bar;") ==> "LP:" ;;; ;;; Which is incorrect. ;;; The change here ensures that the result of TRANSLATE-VERSION is ;;; appropriate. #+lispworks (defun translate-version (version) ;; Value returns the version directory and whether it replaces ;; the entire root (t) or is a subdirectory. ;; Version may be nil to signify no subdirectory, ;; a symbol, such as alpha, beta, omega, :alpha, mark, which ;; specifies a subdirectory of the root, or ;; a string, which replaces the root. (cond ((null version) (values (pathname "") nil)) ((symbolp version) (values (let ((sversion (string version))) (if (find-if #'lower-case-p sversion) (pathname sversion) (pathname (string-downcase sversion)))) nil)) ((stringp version) (values (pathname version) t)) (t (error "~&; Illegal version ~S" version)))) (defun component-extension (component type &key local) (ecase type (:source (or (component-source-extension component) (unless local (default-source-extension component)) ; system default ;; (and (component-language component)) )) (:binary (or (component-binary-extension component) (unless local (default-binary-extension component)) ; system default ;; (and (component-language component)) )) (:error *compile-error-file-type*))) (defsetf component-extension (component type) (value) `(ecase ,type