From 393f9ddbeadad1de12cc571891a073d64d3bb4fe Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Thu, 26 Feb 1998 18:19:54 +0000 Subject: [PATCH] Update to "v3.0 14-MAR-1995". --- contrib/defsystem/defsystem.lisp | 3686 ++++++++++++++++++++++++++---- 1 file changed, 3215 insertions(+), 471 deletions(-) diff --git a/contrib/defsystem/defsystem.lisp b/contrib/defsystem/defsystem.lisp index 33c2541f8..a3abb715d 100644 --- a/contrib/defsystem/defsystem.lisp +++ b/contrib/defsystem/defsystem.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: LISP; Syntax: Common-Lisp -*- - -;;; ******************************************************************** -;;; Portable Mini-DefSystem ******************************************** -;;; ******************************************************************** -;;; Fri Feb 2 10:24:17 1990 by Mark Kantrowitz <mkant@GS8.SP.CS.CMU.EDU> +;;; Mon Mar 13 20:33:57 1995 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU> +;;; defsystem.lisp -- 164167 bytes + +;;; **************************************************************** +;;; 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 @@ -24,7 +25,7 @@ ;;; Written by Mark Kantrowitz, School of Computer Science, ;;; Carnegie Mellon University, October 1989. -;;; Copyright (c) 1989 by Mark Kantrowitz. All rights reserved. +;;; Copyright (c) 1989-95 by Mark Kantrowitz. All rights reserved. ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted, so long as the following @@ -36,8 +37,679 @@ ;;; the software or its performance. ;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. - - + +;;; ******************************** +;;; 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 <diagne@dfki.uni-sb.de> +;;; as = Andreas Stolcke <stolcke@ICSI.Berkeley.EDU> +;;; bha = Brian Anderson <bha@atc.boeing.com> +;;; brad = Brad Miller <miller@cs.rochester.edu> +;;; bw = Robert Wilhelm <wilhelm@rpal.rockwell.com> +;;; djc = Daniel J. Clancy <clancy@cs.utexas.edu> +;;; fdmm = Fernando D. Mato Mira <matomira@di.epfl.ch> +;;; gc = Guillaume Cartier <cartier@math.uqam.ca> +;;; gi = Gabriel Inaebnit <inaebnit@research.abb.ch> +;;; gpw = George Williams <george@hsvaic.boeing.com> +;;; hkt = Rick Taube <hkt@cm-next-8.stanford.edu> +;;; ik = Ik Su Yoo <ik@ctt.bellcore.com> +;;; jk = John_Kolojejchick@MORK.CIMDS.RI.CMU.EDU +;;; kt = Kevin Thompson <kthompso@ptolemy.arc.nasa.gov> +;;; kc = Kaelin Colclasure <kaelin@bridge.com> +;;; lmh = Liam M. Healy <Liam.Healy@nrl.navy.mil> +;;; mc = Matthew Cornell <cornell@unix1.cs.umass.edu> +;;; oc = Oliver Christ <oli@adler.ims.uni-stuttgart.de> +;;; rs = Ralph P. Sobek <ralph@vega.laas.fr> +;;; rs2 = Richard Segal <segal@cs.washington.edu> +;;; sb = Sean Boisen <sboisen@bbn.com> +;;; ss = Steve Strassman <straz@cambridge.apple.com> +;;; tar = Thomas A. Russ <tar@isi.edu> +;;; toni = Anton Beschta <toni%l4@ztivax.siemens.com> +;;; yc = Yang Chen <yangchen%iris.usc.edu@usc.edu> +;;; +;;; Thanks to Steve Strassmann <straz@media-lab.media.mit.edu> and +;;; Sean Boisen <sboisen@BBN.COM> for detailed bug reports and +;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit +;;; <inaebnit@research.abb.ch> 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. + + +;;; ******************************** +;;; 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) +;;; +;;; DEFSYSTEM needs to be tested in the following lisps: +;;; Macintosh Common Lisp +;;; 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 <goldman@isi.edu> 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/<FWD> 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 ********************************************* ;;; ******************************************************************** @@ -49,59 +721,356 @@ ;;; 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 defsystem.text. +;;; 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 ****************************************************** ;;; **************************************************************** ;;; ******************************** -;;; Set up Package ***************** +;;; 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) + (pushnew :cltl2 *features*)) -(in-package "DEFSYSTEM" - :nicknames '("DEFSYS" "MAKE") - :use '("USER" - "LISP") - ) - -(provide 'defsystem) - -(defvar *exports* - '(defsystem operate-on-system oos afs-binary-directory files-in-system)) - -(defvar *other-exports* - '(*central-registry* *bin-subdir* - machine-type-translation software-type-translation - ;require - allegro-make-system-fasl files-which-need-compilation - )) +;;; ******************************** +;;; Provide/Require/*modules* ****** +;;; ******************************** -(export (append *exports* *other-exports*)) -#| -;(import *exports* "LISP") -;(import *exports* "USER") -|# +;;; 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 (and :CMU (not :new-compiler)) :vms :mcl :lispworks + (and allegro-version>= (version>= 4 1))) +(eval-when #-(or :lucid :cmu17) (:compile-toplevel :load-toplevel :execute) + #+(or :lucid :cmu17) (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))))))) -#-(OR CMU :CCL) -(import *exports* "USER") -#+(OR CMU :CCL) -(progn - (import (cdr *exports*) "USER") - (shadowing-import (car *exports*) "USER")) +;;; ******************************** +;;; Set up Package ***************** +;;; ******************************** -#-PCL(when (find-package "PCL") (push :pcl *modules*)(push :pcl *features*)) +;;; 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 :cltl2 :lispworks) +(in-package "MAKE" :nicknames '("MK")) + +;;; For CLtL2 compatible lisps... +#+(and :excl (or :allegro-v4.0 :allegro-v4.1) :cltl2) +(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") + (:import-from cltl1 *modules* provide require)) + +#+(and :excl :allegro-version>= (version>= 4 2)) +(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")) + +#+lispworks +(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") + (:import-from system *modules* provide require) + (: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)) +#+(and :cltl2 (not (or (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")))) + +#+(or :cltl2 lispworks) +(eval-when (compile load eval) + (in-package "MAKE")) + +#+(and :excl (or :allegro-v4.0 :allegro-v4.1) :cltl2) +(cltl1:provide 'make) +#+:mcl +(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*) + +;;; 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* + '(defsystem compile-system load-system))) + (export (setq *other-exports* + '(*central-registry* + *bin-subdir* + 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* + )))) + + +;;; 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 :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 :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) +(when (find-package "PCL") + (pushnew :pcl *modules*) + (pushnew :pcl *features*)) +;;; ******************************** +;;; Defsystem Version ************** +;;; ******************************** +(defparameter *defsystem-version* "v3.0 14-MAR-95" + "Current version number/date for Defsystem.") ;;; ******************************** ;;; Customizable System Parameters * ;;; ******************************** +(defvar *dont-redefine-require* 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 is used only in *central-registry* below. +;;; Note that CMU CL 17e does not understand the ~/ shorthand for home +;;; directories. +(defun home-subdirectory (directory) + (concatenate 'string + #+:cmu "home:" + #-:cmu (let ((homedir (user-homedir-pathname))) + (or (when homedir (namestring homedir)) + "~/")) + 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. -(defvar *central-registry* "/afs/cs.cmu.edu/project/oz/oz2/system/Registry/" - "Central directory of system definitions" ) +;;; 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) + #+(or :allegro ACLPC) (current-directory) + #+:cmu (default-directory) + #+:lispworks + ,(multiple-value-bind (major minor) (system::lispworks-version) + (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")))) + + ;; Home directory + (mk::home-subdirectory "lisp/systems/") + + ;; Global registry + "/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.") (defvar *bin-subdir* ".bin/" "The subdirectory of an AFS directory where the binaries are really kept.") @@ -120,9 +1089,26 @@ (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") + "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" @@ -150,33 +1136,78 @@ ;;; *filename-extensions* is a cons of the source and binary extensions. (defvar *filename-extensions* - (car '(#+(and Symbolics Lispm) ("lisp" . "bin") + (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 ("lsp" . "fas") #+KCL ("lsp" . "o") #+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") + #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin") + ;; PA is Precision Architecture, HP's 9000/800 RISC cpu + #+(and Lucid PA) ("lisp" . "hbin") #+excl ("cl" . "fasl") - #+:CMU ("lisp" . "fasl") + #+CMU ("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") #+:coral ("lisp" . "fasl") - + ;; Harlequin LispWorks + #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*) +; #+(and :sun4 :lispworks) ("lisp" . "wfasl") +; #+(and :mips :lispworks) ("lisp" . "mfasl") + #+:mcl ("lisp" . "fasl") + #+clisp ("lisp" . "fas") + ;; Otherwise, - ("lisp" . "lbin"))) + ("lisp" . "fasl"))) "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 lbin.") +;;; In ANSI CL, we should be able to get the object file type by +;;; doing (pathname-type (compile-file-pathname "foo.lisp")). + +(defvar *system-extension* + ;; MS-DOS systems can only handle three character extensions. + #-ACLPC "system" + #+ACLPC "sys" + "The filename extension to use with systems.") + +(defvar *standard-source-file-types* '("lisp" "l" "cl" "lsp")) +(defvar *standard-binary-file-types* '("fasl")) + +;;; 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 @@ -184,170 +1215,600 @@ (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))) ;;; ******************************** -;;; Alist Manipulation ************* +;;; Component Operation Definition * ;;; ******************************** -(defun alist-lookup (name alist &key test test-not key) - (cdr (assoc name alist :test test :test-not test-not :key key))) - -(defmacro set-alist-lookup ((name alist &key test test-not key) value) - (let ((pair (gensym))) - `(let ((,pair (assoc ,name ,alist :test ,test :test-not ,test-not :key ,key))) - (if ,pair - (rplacd ,pair ,value) - (push (cons ,name ,value) ,alist))))) +(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* nil - "Alist of (operation-name function) pairs" ) +(defvar *component-operations* (make-hash-table :test #'equal) + "Hash table of (operation-name function) pairs.") (defun component-operation (name &optional operation) (if operation - (set-alist-lookup (name *component-operations*) operation) - (alist-lookup name *component-operations*))) + (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, + ;; <cl> #@"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))))) + +(defconstant *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) + (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*) + #+cmu (concatenate 'string + "cmu" " " (lisp-implementation-version)) + #+kcl "kcl" + #+akcl "akcl" + #+gcl "gcl" + #+lucid "lucid" + #+ACLPC "aclpc" + #+CLISP "clisp" + #+KCL "kcl" + #+IBCL "ibcl" + #+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. - (let ((machine (machine-type-translation (machine-type))) - (software (software-type-translation (software-type)))) + ;; 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 + (and :allegro-version>= (version>= 4 2)))) + (software-type) + #+(and :sgi (or :cmu + (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/~]" - (namestring root-directory) + root-directory *bin-subdir* - (afs-component machine software) - ))) + (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 afs-component (machine software) - (format nil "~@[~A~]~@[_~A~]" +(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))) + #\/))) + (concatenate 'string dir "/") + dir)) + +(defun afs-component (machine software &optional lisp) + (format nil "~@[~A~]~@[_~A~]~@[_~A~]" machine - (or software "mach"))) + (or software "mach") + lisp)) -(defvar *machine-type-alist* nil - "Alist for retrieving the machine-type") +(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 - (set-alist-lookup (name *machine-type-alist* :test #'string-equal) operation) - (alist-lookup name *machine-type-alist* :test #'string-equal))) - -(machine-type-translation "IBM RT PC" "rt") -(machine-type-translation "DEC 3100" "pmax") -(machine-type-translation "DEC VAX-11" "vax") -(machine-type-translation "Sun3" "sun3") + (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 + +#+(and :lucid :sun :mc68000) +(machine-type-translation "unknown" "sun3") + -(defvar *software-type-alist* nil - "Alist for retrieving the software-type") +(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 - (set-alist-lookup (name *software-type-alist* :test #'string-equal) operation) - (alist-lookup name *software-type-alist* :test #'string-equal))) + (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 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*))) -(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") +(compiler-type-translation "lispworks 3.2.1" "lispworks") +(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks") +(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) - ;; Names of modules or files may be symbols or strings, but - ;; names of systems must be symbols for accessing the system. - (if (symbolp 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))))) + (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) - ;; The system definition is stored under the - ;; 'system property of the system name. - (get (canonicalize-system-name name) 'system)) + "Returns the definition of the system named NAME." + (gethash (canonicalize-system-name name) *defined-systems*)) (defsetf get-system (name) (value) - `(setf (get (canonicalize-system-name ,name) 'system) ,value)) + `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value)) + +(defun undefsystem (name) + "Removes the definition of the system named NAME." + (setf (get-system name) nil)) + +(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)) ;;; ******************************** ;;; Directory Pathname Hacking ***** ;;; ******************************** -;;; There is no CL primitive for tacking a subdirectory onto a directory. -;;; Such a primitive is needed since we use both absolute and relative -;;; directories. The merge-directories function was a try that failed -;;; (we're keeping it around to prevent future mistakes of that sort), -;;; while the append-directories function seems to work right most -;;; of the time (i.e., it gets the pathname delimiters right). - ;;; 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))) + (abs-name (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))) + (rel-file (file-namestring 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) + (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 + #-(and :cmu (not :cmu17)) directory + #+(and :cmu (not :cmu17)) (coerce directory 'simple-vector) + :name rel-file)))) + +(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)))) + +#| +<cl> (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) - ;; Assumptions: Absolute-directory is a directory, with no - ;; filename stuck on the end. Relative-directory, however, may - ;; have a filename stuck on the end. + "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) - #+ExCL(when (and (stringp absolute-directory) - (null-string absolute-directory)) - (setq absolute-directory nil)) - #+CMU(when (pathnamep absolute-directory) - (setq absolute-directory (namestring absolute-directory))) - #+CMU(when (pathnamep relative-directory) - (setq relative-directory (namestring relative-directory))) - (namestring (make-pathname :directory absolute-directory - :name relative-directory)))) + (cond + ;; 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)) + ;; For use with logical pathnames package. + (append-logical-directories-mk absolute-directory relative-directory)) + ((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)) + +;;; this works in allegro-v4.1 and above. +#+(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 namestring-probably-logical (namestring) + (and (stringp namestring) + ;; unix pathnames don't have embedded semicolons + (find #\; namestring))) + +(defun append-logical-pnames (absolute relative) + (let ((abs (or absolute "")) + (rel (or 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 null-string (s) - (string-equal s "")) +#| +;;; 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 ""))) +|# #| <cl> (defun d (d n) (namestring (make-pathname :directory d :name n))) D -<cl> (d "/foo/bar/" "baz/barf.lisp") +<cl> (d "~/foo/" "baz/bar.lisp") +"/usr0/mkant/foo/baz/bar.lisp" +<cl> (d "~/foo" "baz/bar.lisp") +"/usr0/mkant/foo/baz/bar.lisp" + +<cl> (d "/foo/bar/" "baz/barf.lisp") "/foo/bar/baz/barf.lisp" -<cl> (d "foo/bar/" "baz/barf.lisp") +<cl> (d "foo/bar/" "baz/barf.lisp") "foo/bar/baz/barf.lisp" -<cl> (d "foo/bar" "baz/barf.lisp") +<cl> (d "foo/bar" "baz/barf.lisp") "foo/bar/baz/barf.lisp" -<cl> (d "foo/bar" "/baz/barf.lisp") +<cl> (d "foo/bar" "/baz/barf.lisp") "foo/bar//baz/barf.lisp" -<cl> (d "foo/bar" nil) +<cl> (d "foo/bar" nil) "foo/bar/" -<cl> (d nil "baz/barf.lisp") +<cl> (d nil "baz/barf.lisp") "baz/barf.lisp" -<cl> (d nil nil) +<cl> (d nil nil) "" |# -#| -(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 namestring-or-nil (pathname) - (when pathname - (namestring pathname))) + (defun new-file-type (pathname type) (make-pathname @@ -358,54 +1819,251 @@ D :type type :version (pathname-version pathname))) + + ;;; ******************************** ;;; 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.") + +;;; Removed TIME slot, which has been made unnecessary by the new definition +;;; of topological-sort. (defstruct (topological-sort-node (:conc-name topsort-)) color - time) +; time +) (defstruct (component (:include topological-sort-node) (:print-function print-component)) - type ; :system, :module, or :file, or :private-file + type ; :defsystem, :system, :subsystem, :module, :file, or :private-file name ; a symbol or string indent ; 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 - source-pathname ; relative or absolute (starts with "/"), directory or file (ends with "/") + ;; relative or absolute (starts with "/"), directory or file (ends with "/") + (source-pathname *source-pathname-default*) source-extension ; a string, e.g., "lisp". If nil, uses default for machine-type - binary-pathname + (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 function)) + (loader nil :type (or NULL function)) + components ; a list of components comprising this component's definition depends-on ; 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 ; form to evaluate before the operation finally-do ; form to evaluate after the operation compile-form ; for foreign libraries load-form ; 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. + ;; optional documentation slot + (documentation nil :type (or NULL string)) ) +(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*))))))))) +(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)) + +(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 (if (consp registry) + (eval registry) + 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. + 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 "Can't find system named ~s." system-name))) + (:LOAD-OR-NIL + (let ((system (get-system system-name))) + (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. + (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)) + (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>" + (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 + ;; 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 - (case type + (ecase type (:source (component-source-pathname component)) (:binary (component-binary-pathname component)) (:error (component-error-pathname component))))) @@ -414,53 +2072,104 @@ D (new-file-type binary *compile-error-file-type*))) (defsetf component-pathname (component type) (value) `(when ,component - (case ,type + (ecase ,type (:source (setf (component-source-pathname ,component) ,value)) (:binary (setf (component-binary-pathname ,component) ,value))))) (defun component-root-dir (component type) (when component - (case type + (ecase type (:source (component-source-root-dir component)) ((:binary :error) (component-binary-root-dir component)) ))) (defsetf component-root-dir (component type) (value) `(when ,component - (case ,type + (ecase ,type (:source (setf (component-source-root-dir ,component) ,value)) (:binary (setf (component-binary-root-dir ,component) ,value))))) -(defvar *version-dir* nil - "The version subdir. bound in oos.") -(defvar *version-replace* nil - "The version replace. bound in oos.") -(defvar *version* nil - "Default version") -(defun component-full-pathname (component type &optional (version *version*) - &aux version-dir replace) +(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 - ;; 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 replace) (translate-version version)) - (setq version-dir *version-dir* replace *version-replace*)) - (let ((pathname - (append-directories - (if replace - version-dir - (append-directories (component-root-dir component type) - version-dir)) - (component-pathname component type)))) - (make-pathname :name (pathname-name pathname) - :type (component-extension component type) - :host (pathname-host (component-host component)) - :device #+CMU :absolute - #-CMU (pathname-device (component-device component)) - ;; :version :newest - ;; Use :directory instead of :defaults - :directory (pathname-directory pathname))))) + (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*)) + (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. + #+:logical-pathnames-mk + (when (eq (lp:pathname-host-type pathname) :logical) + ;;(setf (lp::%logical-pathname-type pathname) + ;; (component-extension component type)) + (setf pathname (lp:translate-logical-pathname pathname))) + #+(and (and allegro-version>= (version>= 4 1)) + (not :logical-pathnames-mk)) + (when (and (pathname-host pathname) (logical-pathname-p pathname)) + (setf pathname (translate-logical-pathname pathname))) + + (namestring + (make-pathname :name (pathname-name pathname) + :type (component-extension component type) + :host (when (component-host component) + ;; MCL2.0b1 and ACLPC cause an error on + ;; (pathname-host nil) + (pathname-host (component-host component))) + :device #+(and :CMU (not :cmu17)) :absolute + #-(and :CMU (not :cmu17)) + (let ((dev (component-device component))) + (when dev + (pathname-device dev))) + ;; :version :newest + ;; Use :directory instead of :defaults + :directory (pathname-directory pathname))))) + +;;; What about CMU17 :device :unspecific in the above? (defun translate-version (version) ;; Value returns the version directory and whether it replaces @@ -472,18 +2181,26 @@ D (cond ((null version) (values "" nil)) ((symbolp version) - (values (string-downcase (string version)) nil)) + (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)))) -(defun component-extension (component type) - (case type - (:source (component-source-extension component)) - (:binary (component-binary-extension component)) +(defun component-extension (component type &key local) + (ecase type + (:source (or (component-source-extension component) + (unless local + (default-source-extension component)))) ; system default + (:binary (or (component-binary-extension component) + (unless local + (default-binary-extension component)))) ; system default (:error *compile-error-file-type*))) (defsetf component-extension (component type) (value) - `(case ,type + `(ecase ,type (:source (setf (component-source-extension ,component) ,value)) (:binary (setf (component-binary-extension ,component) ,value)) (:error (setf *compile-error-file-type* ,value)))) @@ -491,16 +2208,34 @@ D ;;; ******************************** ;;; System Definition ************** ;;; ******************************** -(defmacro defsystem (name &rest definition-body) - `(create-component :system ',name ',definition-body nil 0)) - (defun create-component (type name definition-body &optional parent (indent 0)) - (let ((component (apply #'make-component :type type :name name :indent indent definition-body))) + (let ((component (apply #'make-component :type type :name name + :indent indent definition-body))) + ;; Set up :load-only attribute + (unless (find :load-only definition-body) + ;; If the :load-only attribute wasn't specified, + ;; inherit it from the parent. If no parent, default it to nil. + (setf (component-load-only component) + (when parent + (component-load-only parent)))) + ;; Set up :compile-only attribute + (unless (find :compile-only definition-body) + ;; If the :compile-only attribute wasn't specified, + ;; inherit it from the parent. If no parent, default it to nil. + (setf (component-compile-only component) + (when parent + (component-compile-only parent)))) + ;; Initializations/after makes (canonicalize-component-name component) + ;; Inherit package from parent if not specified. + (setf (component-package component) + (or (component-package component) + (when parent (component-package parent)))) + ;; Type specific setup: - (when (eq type :system) + (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) (setf (get-system name) component)) ;; Set up the component's pathname @@ -523,17 +2258,36 @@ D ;; Return the component. component)) +(defmacro defsystem (name &rest definition-body) + `(create-component :defsystem ',name ',definition-body nil 0)) + (defun create-component-pathnames (component parent) + ;; Set up language-specific defaults + (setf (component-language component) + (or (component-language component) ; for local defaulting + (when parent ; parent's default + (component-language parent)))) + (setf (component-compiler component) + (or (component-compiler component) ; for local defaulting + (when parent ; parent's default + (component-compiler parent)))) + (setf (component-loader component) + (or (component-loader component) ; for local defaulting + (when parent ; parent's default + (component-loader parent)))) + ;; Evaluate the root dir arg (setf (component-root-dir component :source) (eval (component-root-dir component :source))) (setf (component-root-dir component :binary) (eval (component-root-dir component :binary))) + ;; Evaluate the pathname arg (setf (component-pathname component :source) (eval (component-pathname component :source))) (setf (component-pathname component :binary) (eval (component-pathname component :binary))) + ;; Pass along the host and devices (setf (component-host component) (or (component-host component) @@ -541,17 +2295,17 @@ D (setf (component-device component) (or (component-device component) (when parent (component-device parent)))) + ;; Set up extension defaults (setf (component-extension component :source) - (or (component-extension component :source) ; for local defaulting + (or (component-extension component :source :local t) ; local default (when parent ; parent's default - (component-extension parent :source)) - (car *filename-extensions*))) ; system default + (component-extension parent :source)))) (setf (component-extension component :binary) - (or (component-extension component :binary) ; for local defaulting + (or (component-extension component :binary :local t) ; local default (when parent ; parent's default - (component-extension parent :binary)) - (cdr *filename-extensions*))) ; system default + (component-extension parent :binary)))) + ;; Set up pathname defaults -- expand with parent ;; We must set up the source pathname before the binary pathname ;; to allow distribution of binaries among the sources to work. @@ -568,7 +2322,7 @@ D ;; specified for binaries, but no module directories, it inherits ;; parallel directory structure. (case (component-type component) - (:system ; Absolute Pathname + ((:defsystem :system) ; Absolute Pathname ;; Set the root-dir to be the absolute pathname (setf (component-root-dir component pathname-type) (or (component-pathname component pathname-type) @@ -592,6 +2346,12 @@ D ;; When the binary root is nil, use source. (component-root-dir component :source))) ) + ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "", + ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could + ;; wind up being "", which is wrong for :file components. So replace + ;; them with NIL. + (when (null-string (component-pathname component pathname-type)) + (setf (component-pathname component pathname-type) nil)) ;; The relative pathname is the name part (setf (component-pathname component pathname-type) (or (when (and (eq pathname-type :binary) @@ -602,7 +2362,7 @@ D ; (pathname-name ) (component-pathname component pathname-type)) (component-name component))))) - (:module ; Pathname relative to parent. + ((:module :subsystem) ; Pathname relative to parent. ;; Inherit root-dir from parent (setf (component-root-dir component pathname-type) (component-root-dir parent pathname-type)) @@ -620,6 +2380,12 @@ D ;; Inherit root-dir from parent (setf (component-root-dir component pathname-type) (component-root-dir parent pathname-type)) + ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "", + ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could + ;; wind up being "", which is wrong for :file components. So replace + ;; them with NIL. + (when (null-string (component-pathname component pathname-type)) + (setf (component-pathname component pathname-type) nil)) ;; Tack the relative-dir onto the pathname (setf (component-pathname component pathname-type) (or (append-directories @@ -631,21 +2397,82 @@ D (component-pathname component :source))))))) )) +#| ;; old version (defun expand-component-components (component &optional (indent 0)) - (setf (component-components component) - (mapcar #'(lambda (definition) - (expand-component-definition definition component indent)) - (component-components component)))) + (let ((definitions (component-components component))) + (setf (component-components component) + (remove-if #'null + (mapcar #'(lambda (definition) + (expand-component-definition definition + component + indent)) + definitions))))) +|# +;; new version +(defun expand-component-components (component &optional (indent 0)) + (let ((definitions (component-components component))) + (if (eq (car definitions) :serial) + (setf (component-components component) + (expand-serial-component-chain (cdr definitions) + component indent)) + (setf (component-components component) + (expand-component-definitions definitions component indent))))) + +(defun expand-component-definitions (definitions parent &optional (indent 0)) + (let ((components nil)) + (dolist (definition definitions) + (let ((new (expand-component-definition definition parent indent))) + (when new (push new components)))) + (nreverse components))) + +(defun expand-serial-component-chain (definitions parent &optional (indent 0)) + (let ((previous nil) + (components nil)) + (dolist (definition definitions) + (let ((new (expand-component-definition definition parent indent))) + (when new + ;; Make this component depend on the previous one. Since + ;; we don't know the form of the definition, we have to + ;; expand it first. + (when previous (pushnew previous (component-depends-on new))) + ;; The dependencies will be linked later, so we use the name + ;; instead of the actual component. + (setq previous (component-name new)) + ;; Save the new component. + (push new components)))) + ;; Return the list of expanded components, in appropriate order. + (nreverse components))) + + +(defparameter *enable-straz-absolute-string-hack* nil + "Special hack requested by Steve Strassman, where the shorthand + that specifies a list of components as a list of strings also + recognizes absolute pathnames and treats them as files of type + :private-file instead of type :file. Defaults to NIL, because I + haven't tested this.") +(defun absolute-file-namestring-p (string) + ;; If a FILE namestring starts with a slash, or is a logical pathname + ;; as implied by the existence of a colon in the filename, assume it + ;; represents an absolute pathname. + (or (find #\: string :test #'char=) + (and (not (null-string string)) + (char= (char string 0) #\/)))) (defun expand-component-definition (definition parent &optional (indent 0)) ;; Should do some checking for malformed definitions here. (cond ((null definition) nil) ((stringp definition) ;; Strings are assumed to be of type :file - (create-component :file definition nil parent indent)) + (if (and *enable-straz-absolute-string-hack* + (absolute-file-namestring-p definition)) + ;; Special hack for Straz + (create-component :private-file definition nil parent indent) + ;; Normal behavior + (create-component :file definition nil parent indent))) ((and (listp definition) (not (member (car definition) - '(:system :module :file :private-file)))) + '(:defsystem :system :subsystem + :module :file :private-file)))) ;; Lists whose first element is not a component type ;; are assumed to be of type :file (create-component :file (car definition) (cdr definition) parent indent)) @@ -661,38 +2488,71 @@ D (defun link-component-depends-on (components) (dolist (component components) (unless (and *system-dependencies-delayed* - (eq (component-type component) :system)) + (eq (component-type component) :defsystem)) (setf (component-depends-on component) (mapcar #'(lambda (dependency) - (find (string dependency) components :key #'component-name - :test #'string-equal)) + (let ((parent (find (string dependency) components + :key #'component-name + :test #'string-equal))) + (cond (parent parent) + ;; make it more intelligent about the following + (t (warn "Dependency ~S of component ~S not found." + dependency component))))) + (component-depends-on component)))))) ;;; ******************************** ;;; Topological Sort the Graph ***** ;;; ******************************** + +;;; New version of topological sort suggested by rs2. Even though +;;; this version avoids the call to sort, in practice it isn't faster. It +;;; does, however, eliminate the need to have a TIME slot in the +;;; topological-sort-node defstruct. +(defun topological-sort (list &aux (sorted-list nil)) + (labels ((dfs-visit (znode) + (setf (topsort-color znode) 'gray) + (unless (and *system-dependencies-delayed* + (eq (component-type znode) :system)) + (dolist (child (component-depends-on znode)) + (cond ((eq (topsort-color child) 'white) + (dfs-visit child)) + ((eq (topsort-color child) 'gray) + (format t "~&Detected cycle containing ~A" child))))) + (setf (topsort-color znode) 'black) + (push znode sorted-list))) + (dolist (znode list) + (setf (topsort-color znode) 'white)) + (dolist (znode list) + (when (eq (topsort-color znode) 'white) + (dfs-visit znode))) + (nreverse sorted-list))) + +#| +;;; Older version of topological sort. (defun topological-sort (list &aux (time 0)) ;; The algorithm works by calling depth-first-search to compute the ;; blackening times for each vertex, and then sorts the vertices into ;; reverse order by blackening time. (labels ((dfs-visit (node) - (setf (topsort-color node) 'gray) - (unless (and *system-dependencies-delayed* - (eq (component-type node) :system)) - (dolist (child (component-depends-on node)) - (cond ((eq (topsort-color child) 'white) - (dfs-visit child)) - ((eq (topsort-color child) 'gray) - (format t "~&Detected cycle containing ~A" child))))) - (setf (topsort-color node) 'black) - (setf (topsort-time node) time) - (incf time))) + (setf (topsort-color node) 'gray) + (unless (and *system-dependencies-delayed* + (eq (component-type node) :defsystem)) + (dolist (child (component-depends-on node)) + (cond ((eq (topsort-color child) 'white) + (dfs-visit child)) + ((eq (topsort-color child) 'gray) + (format t "~&Detected cycle containing ~A" child))))) + (setf (topsort-color node) 'black) + (setf (topsort-time node) time) + (incf time))) (dolist (node list) (setf (topsort-color node) 'white)) (dolist (node list) (when (eq (topsort-color node) 'white) (dfs-visit node))) (sort list #'< :key #'topsort-time))) +|# ;;; ******************************** ;;; Output to User ***************** @@ -712,28 +2572,66 @@ D (push (subseq string index i) result)) (setf index (1+ i)))))) +;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it +;; because of an AKCL bug. +;; KGK suggests using an 8 instead, but 1 does nicely. (defun prompt-string (component) - (format nil "; ~:[~;TEST:~]~V,@T " + (format nil "; ~:[~;TEST:~]~V,1@T " *oos-test* (component-indent component))) +#| (defun format-justified-string (prompt contents) (format t (concatenate 'string "~%" prompt "-~{~<~%" prompt " ~1,80:; ~A~>~^~}") (split-string contents)) (finish-output *standard-output*)) +|# + +(defun format-justified-string (prompt contents &optional (width 80) + (stream *standard-output*)) + (let ((prompt-length (+ 2 (length prompt)))) + (cond ((< (+ prompt-length (length contents)) width) + (format stream "~%~A- ~A" prompt contents)) + (t + (format stream "~%~A-" prompt) + (do* ((cursor prompt-length) + (contents (split-string contents) (cdr contents)) + (content (car contents) (car contents)) + (content-length (1+ (length content)) (1+ (length content)))) + ((null contents)) + (cond ((< (+ cursor content-length) width) + (incf cursor content-length) + (format stream " ~A" content)) + (t + (setf cursor (+ prompt-length content-length)) + (format stream "~%~A ~A" prompt content))))))) + (finish-output stream)) (defun tell-user (what component &optional type no-dots force) (when (or *oos-verbose* force) (format-justified-string (prompt-string component) (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]" + ;; To have better messages, wrap the following around the + ;; case statement: + ;;(if (find (component-type component) + ;; '(:defsystem :system :subsystem :module)) + ;; "Checking" + ;; (case ...)) + ;; This gets around the problem of DEFSYSTEM reporting + ;; that it's loading a module, when it eventually never + ;; loads any of the files of the module. (case what - ((compile :compile) "Compiling") + ((compile :compile) + (if (component-load-only component) + ;; If it is :load-only t, we're loading. + "Loading" + ;; Otherwise we're compiling. + "Compiling")) ((load :load) "Loading") (otherwise what)) (component-type component) (or (when type - (namestring-or-nil (component-full-pathname - component type))) + (component-full-pathname component type)) (component-name component)) (and *tell-user-when-done* (not no-dots)))))) @@ -755,11 +2653,11 @@ D (defun tell-user-no-files (component &optional force) (when (or *oos-verbose* force) (format-justified-string (prompt-string component) - (format nil "Binary file ~A ~ - ~:[and source file ~A do~;does~] not exist, not loading." - (namestring (component-full-pathname component :binary)) + (format nil "Source file ~A ~ + ~:[and binary file ~A ~;~]not found, not loading." + (component-full-pathname component :source) (or *load-source-if-no-binary* *load-source-instead-of-binary*) - (namestring (component-full-pathname component :source)))))) + (component-full-pathname component :binary))))) (defun tell-user-require-system (name parent) (when *oos-verbose* @@ -776,45 +2674,93 @@ D ;;; ******************************** ;;; Y-OR-N-P-WAIT ****************** ;;; ******************************** -;;; y-or-n-p-wait is like y-or-n-p, but will timeout -;;; after a specified number of seconds +;;; Y-OR-N-P-WAIT is like Y-OR-N-P, but will timeout after a specified +;;; number of seconds. I should really replace this with a call to +;;; the Y-OR-N-P-WAIT defined in the query.cl package and include that +;;; instead. + +(defparameter *use-timeouts* t + "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves + like Y-OR-N-P. This is provided for users whose lisps don't handle + read-char-no-hang properly.") + +(defparameter *clear-input-before-query* t + "If T, y-or-n-p-wait will clear the input before printing the prompt + and asking the user for input.") + +;;; The higher *sleep-amount* is, the less consing, but the lower the +;;; responsiveness. +(defparameter *sleep-amount* #-CMU 0.1 #+CMU 1.0 + "Amount of time to sleep between checking query-io. In multiprocessing + Lisps, this allows other processes to continue while we busy-wait. If + 0, skips call to SLEEP.") + (defun internal-real-time-in-seconds () - (float (/ (get-internal-real-time) - internal-time-units-per-second))) + (get-universal-time)) -(defun read-char-wait (&optional (timeout 20) input-stream &aux char) +(defun read-char-wait (&optional (timeout 20) input-stream + (eof-error-p t) eof-value + &aux peek) (do ((start (internal-real-time-in-seconds))) - ((or (setq char (read-char-no-hang input-stream)) ;(listen *query-io*) - (< (+ start timeout) (internal-real-time-in-seconds))) - char))) + ((or (setq peek (listen input-stream)) + (< (+ start timeout) (internal-real-time-in-seconds))) + (when peek + ;; was read-char-no-hang + (read-char input-stream eof-error-p eof-value))) + (unless (zerop *sleep-amount*) + (sleep *sleep-amount*)))) + +;;; Lots of lisps, especially those that run on top of UNIX, do not get +;;; their input one character at a time, but a whole line at a time because +;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait +;;; to not always work as expected. +;;; +;;; I wish lisp did all its own buffering (turning off UNIX input line +;;; buffering by putting the UNIX into CBREAK mode). Of course, this means +;;; that we lose input editing, but why can't the lisp implement this? (defun y-or-n-p-wait (&optional (default #\y) (timeout 20) format-string &rest args) - (clear-input *query-io*) - (format *query-io* "~&~?" (or format-string "") args) - (finish-output *query-io*);; needed for CMU and other places - (let* ((read-char (read-char-wait timeout *query-io*)) - (char (or read-char default))) - (clear-input *query-io*) - (when (null read-char) (format *query-io* "~@[~A~]" default)) - (cond ((null char) t) - ((find char '(#\y #\Y #\space) :test #'char=) t) - ((find char '(#\n #\N) :test #'char=) nil) - (t (y-or-n-p-wait default timeout - "Type \"y\" for yes or \"n\" for no. "))))) - -(defvar *use-timeouts* t) - -(defun y-or-n-p-wait-optional (&optional (default #\y) (timeout 20) - format-string &rest args) - (cond ((and default - *use-timeouts*) - (apply 'y-or-n-p-wait default timeout format-string args)) - (t (apply 'y-or-n-p format-string args)))) + "Y-OR-N-P-WAIT prints the message, if any, and reads characters from + *QUERY-IO* until the user enters y, Y or space as an affirmative, or either + n or N as a negative answer, or the timeout occurs. It asks again if + you enter any other characters." + (when *clear-input-before-query* (clear-input *query-io*)) + (when format-string + (fresh-line *query-io*) + (apply #'format *query-io* format-string args) + ;; FINISH-OUTPUT needed for CMU and other places which don't handle + ;; output streams nicely. This prevents it from continuing and + ;; reading the query until the prompt has been printed. + (finish-output *query-io*)) + (loop + (let* ((read-char (if *use-timeouts* + (read-char-wait timeout *query-io* nil nil) + (read-char *query-io*))) + (char (or read-char default))) + ;; We need to ignore #\newline because otherwise the bugs in + ;; clear-input will cause y-or-n-p-wait to print the "Type ..." + ;; message every time... *sigh* + ;; Anyway, we might want to use this to ignore whitespace once + ;; clear-input is fixed. + (unless (find char '(#\tab #\newline #\return)) + (when (null read-char) + (format *query-io* "~@[~A~]" default) + (finish-output *query-io*)) + (cond ((null char) (return t)) + ((find char '(#\y #\Y #\space) :test #'char=) (return t)) + ((find char '(#\n #\N) :test #'char=) (return nil)) + (t + (when *clear-input-before-query* (clear-input *query-io*)) + (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ") + (when format-string + (fresh-line *query-io*) + (apply #'format *query-io* format-string args)) + (finish-output *query-io*))))))) #| (y-or-n-p-wait #\y 20 "What? ") -(progn (format t "~&hi") +(progn (format t "~&hi") (finish-output) (y-or-n-p-wait #\y 10 "1? ") (y-or-n-p-wait #\n 10 "2? ")) |# @@ -841,121 +2787,310 @@ D ;; a symbol, such as alpha, beta, omega, :alpha, mark, which ;; specifies a subdirectory of the root, or ;; a string, which replaces the root. +;; (defun operate-on-system (name operation &key force (version *version*) (test *oos-test*) (verbose *oos-verbose*) - (load-source-instead-of-binary *load-source-instead-of-binary*) - (load-source-if-no-binary *load-source-if-no-binary*) - (bother-user-if-no-binary *bother-user-if-no-binary*) - dribble) - (when dribble (dribble dribble)) - (when test (setq verbose t)) - (when (null force);; defaults - (case operation - ((load :load) (setq force :all)) - ((compile :compile) (setq force :new-source-and-dependents)))) - ;; Some CL implementations have a variable called *compile-verbose* - (multiple-value-bind (*version-dir* *version-replace*) - (translate-version version) - (let ((*load-verbose* nil);; CL implementations may uniformly default this to nil - (*version* version) - (*oos-verbose* verbose) - (*oos-test* test) - (*load-source-if-no-binary* load-source-if-no-binary) - (*bother-user-if-no-binary* bother-user-if-no-binary) - (*load-source-instead-of-binary* load-source-instead-of-binary) - (system (get-system name))) - (unless system (error "Can't find system named ~A." name)) - (unless (component-operation operation) (error "Operation ~A undefined." operation)) - (operate-on-component system operation force))) - (when dribble (dribble))) + (load-source-instead-of-binary + *load-source-instead-of-binary*) + (load-source-if-no-binary + *load-source-if-no-binary*) + (bother-user-if-no-binary + *bother-user-if-no-binary*) + (compile-during-load *compile-during-load*) + dribble + (minimal-load *minimal-load*)) + (unwind-protect + ;; Protect the undribble. + (progn + (when *reset-full-pathname-table* (clear-full-pathname-tables)) + (when dribble (dribble dribble)) + (when test (setq verbose t)) + (when (null force);; defaults + (case operation + ((load :load) (setq force :all)) + ((compile :compile) (setq force :new-source-and-dependents)) + (t (setq force :all)))) + ;; Some CL implementations have a variable called *compile-verbose* + ;; or *compile-file-verbose*. + (multiple-value-bind (*version-dir* *version-replace*) + (translate-version version) + ;; CL implementations may uniformly default this to nil + (let ((*load-verbose* t) ; nil + #-(or MCL CMU) (*compile-file-verbose* t) ; nil + (*compile-verbose* t) ; nil + (*version* version) + (*oos-verbose* verbose) + (*oos-test* test) + (*load-source-if-no-binary* load-source-if-no-binary) + (*compile-during-load* compile-during-load) + (*bother-user-if-no-binary* bother-user-if-no-binary) + (*load-source-instead-of-binary* load-source-instead-of-binary) + (*minimal-load* minimal-load) + (system (find-system name :load))) + #-CMU + (declare (special *compile-verbose* #-MCL *compile-file-verbose*) + (ignore *compile-verbose* #-MCL *compile-file-verbose*)) + (unless (component-operation operation) + (error "Operation ~A undefined." operation)) + (operate-on-component system operation force)))) + (when dribble (dribble)))) + +(defun COMPILE-SYSTEM (name &key force + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + (load-source-instead-of-binary + *load-source-instead-of-binary*) + (load-source-if-no-binary + *load-source-if-no-binary*) + (bother-user-if-no-binary + *bother-user-if-no-binary*) + (compile-during-load *compile-during-load*) + dribble + (minimal-load *minimal-load*)) + ;; For users who are confused by OOS. + (operate-on-system + name :compile + :force force + :version version + :test test + :verbose verbose + :load-source-instead-of-binary load-source-instead-of-binary + :load-source-if-no-binary load-source-if-no-binary + :bother-user-if-no-binary bother-user-if-no-binary + :compile-during-load compile-during-load + :dribble dribble + :minimal-load minimal-load)) + +(defun LOAD-SYSTEM (name &key force + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + (load-source-instead-of-binary + *load-source-instead-of-binary*) + (load-source-if-no-binary *load-source-if-no-binary*) + (bother-user-if-no-binary *bother-user-if-no-binary*) + (compile-during-load *compile-during-load*) + dribble + (minimal-load *minimal-load*)) + ;; For users who are confused by OOS. + (operate-on-system + name :load + :force force + :version version + :test test + :verbose verbose + :load-source-instead-of-binary load-source-instead-of-binary + :load-source-if-no-binary load-source-if-no-binary + :bother-user-if-no-binary bother-user-if-no-binary + :compile-during-load compile-during-load + :dribble dribble + :minimal-load minimal-load)) + +(defun CLEAN-SYSTEM (name &key (force :all) + (version *version*) + (test *oos-test*) (verbose *oos-verbose*) + dribble) + "Deletes all the binaries in the system." + ;; For users who are confused by OOS. + (operate-on-system + name :delete-binaries + :force force + :version version + :test test + :verbose verbose + :dribble dribble)) + +(defun EDIT-SYSTEM + (name &key force + (version *version*) + (test *oos-test*) + (verbose *oos-verbose*) + dribble) + + (operate-on-system + name :edit + :force force + :version version + :test test + :verbose verbose + :dribble dribble)) + +(defun HARDCOPY-SYSTEM + (name &key force + (version *version*) + (test *oos-test*) + (verbose *oos-verbose*) + dribble) + + (operate-on-system + name :hardcopy + :force force + :version version + :test test + :verbose verbose + :dribble dribble)) (defun operate-on-component (component operation force &aux changed) ;; Returns T if something changed and had to be compiled. (let ((type (component-type component)) - ;; Use the correct package. - #+ignore(*package* - (or (when (component-package component) - (tell-user-generic (format nil "Using package ~A" - (component-package component))) - (cond (*oos-test* *package*) - (t (find-package (component-package component))))) - *package*)) -) - (when (component-package component) - (tell-user-generic (format nil "Using package ~A" - (component-package component))) - (cond (*oos-test* *package*) - (t (unless (find-package (component-package component)) - (require (component-package component))) - (use-package (component-package component))))) - - ;; Load any required systems - (when (eq type :system) - (operate-on-system-dependencies component)) - - ;; Do any initial actions - (when (component-initially-do component) - (tell-user-generic (format nil "Doing initializations for ~A" - (component-name component))) - (or *oos-test* - (eval (component-initially-do component)))) - - ;; Do operation and set changed flag if necessary. - (setq changed - (case type - ((:file :private-file) - (funcall (component-operation operation) component force)) - ((:module :system) - (operate-on-components component operation force changed)))) - - ;; Do any final actions - (when (component-finally-do component) - (tell-user-generic (format nil "Doing finalizations for ~A" - (component-name component))) - (or *oos-test* - (eval (component-finally-do component)))) + (old-package (package-name *package*))) + + (unwind-protect + ;; Protect old-package. + (progn + ;; Use the correct package. + (when (component-package component) + (tell-user-generic (format nil "Using package ~A" + (component-package component))) + (unless *oos-test* + (unless (find-package (component-package component)) + ;; If the package name is the same as the name of the system, + ;; and the package is not defined, this would lead to an + ;; infinite loop, so bomb out with an error. + (when (string-equal (string (component-package component)) + (component-name component)) + (format t "~%Component ~A not loaded:~%" + (component-name component)) + (error " Package ~A is not defined" + (component-package component))) + ;; If package not found, try using REQUIRE to load it. + (new-require (component-package component))) + ;; This was USE-PACKAGE, but should be IN-PACKAGE. + ;; Actually, CLtL2 lisps define in-package as a macro, + ;; so we'll set the package manually. + ;; (in-package (component-package component)) + (let ((package (find-package (component-package component)))) + (when package + (setf *package* package))))) + + ;; Load any required systems + (when (eq type :defsystem) ; maybe :system too? + (operate-on-system-dependencies component operation force)) + + ;; Do any compiler proclamations + (when (component-proclamations component) + (tell-user-generic (format nil "Doing proclamations for ~A" + (component-name component))) + (or *oos-test* + (proclaim (component-proclamations component)))) + + ;; Do any initial actions + (when (component-initially-do component) + (tell-user-generic (format nil "Doing initializations for ~A" + (component-name component))) + (or *oos-test* + (eval (component-initially-do component)))) + + ;; If operation is :compile and load-only is T, this would change + ;; the operation to load. Only, this would mean that a module would + ;; be considered to have changed if it was :load-only and had to be + ;; loaded, and then dependents would be recompiled -- this doesn't + ;; seem right. So instead, we propagate the :load-only attribute + ;; to the components, and modify compile-file-operation so that + ;; it won't compile the files (and modify tell-user to say "Loading" + ;; instead of "Compiling" for load-only modules). + #|(when (and (find operation '(:compile compile)) + (component-load-only component)) + (setf operation :load))|# + + ;; Do operation and set changed flag if necessary. + (setq changed + (case type + ((:file :private-file) + (funcall (component-operation operation) component force)) + ((:module :system :subsystem :defsystem) + (operate-on-components component operation force changed)))) + + ;; Do any final actions + (when (component-finally-do component) + (tell-user-generic (format nil "Doing finalizations for ~A" + (component-name component))) + (or *oos-test* + (eval (component-finally-do component))))) + + ;; Reset the package. (Cleanup form of unwind-protect.) + ;;(in-package old-package) + (setf *package* (find-package old-package))) ;; Provide the loaded system - (when (eq type :system) - (tell-user-generic (format nil "Providing system ~A" + (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) + (tell-user-generic (format nil "Providing system ~A~%" (component-name component))) (or *oos-test* (provide (canonicalize-system-name (component-name component)))))) - ;; Return t if something changed in this component and hence had to be recompiled. + ;; Return non-NIL if something changed in this component and hence had + ;; to be recompiled. This is only used as a boolean. changed) -(defun operate-on-system-dependencies (component) +(defvar *force* nil) +(defvar *providing-blocks-load-propagation* t + "If T, if a system dependency exists on *modules*, it is not loaded.") +(defun operate-on-system-dependencies (component operation &optional force) (when *system-dependencies-delayed* - (dolist (system (component-depends-on component)) - ;; For each system that this system depends on, - ;; runs require (my version) on that system to load it. - ;; Explores the system tree in a DFS manner. - (cond ((listp system) - (tell-user-require-system - (cond ((and (null (car system)) (null (cadr system))) - (caddr system)) - (t system)) - component) - (or *oos-test* (require (car system) nil - (eval (cadr system)) - (caddr system) - (or (car (cdddr system)) - *version*)))) - (t - (tell-user-require-system system component) - (or *oos-test* (require system)))) - ))) + (let ((*force* force)) + (dolist (system (component-depends-on component)) + ;; For each system that this system depends on, if it is a + ;; defined system (either via defsystem or component type :system), + ;; and propagation is turned on, propagates the operation to the + ;; subsystem. Otherwise runs require (my version) on that system + ;; to load it (needed since we may be depending on a lisp + ;; dependent package). + ;; Explores the system tree in a DFS manner. + (cond ((and *operations-propagate-to-subsystems* + (not (listp system)) + ;; The subsystem is a defined system. + (find-system system :load-or-nil)) + ;; Call OOS on it. Since *system-dependencies-delayed* is + ;; T, the :depends-on slot is filled with the names of + ;; systems, not defstructs. + ;; Aside from system, operation, force, for everything else + ;; we rely on the globals. + (unless (and *providing-blocks-load-propagation* + ;; If *providing-blocks-load-propagation* is T, + ;; the system dependency must not exist in the + ;; *modules* for it to be loaded. Note that + ;; the dependencies are implicitly systems. + (find operation '(load :load)) + ;; (or (eq force :all) (eq force t)) + (find (canonicalize-system-name system) + *modules* :test #'string-equal)) + (operate-on-system system operation :force force))) + ((listp system) + (tell-user-require-system + (cond ((and (null (car system)) (null (cadr system))) + (caddr system)) + (t system)) + component) + (or *oos-test* (new-require (car system) nil + (eval (cadr system)) + (caddr system) + (or (car (cdddr system)) + *version*)))) + (t + (tell-user-require-system system component) + (or *oos-test* (new-require system)))))))) + +;;; Modules can depend only on siblings. If a module should depend +;;; on an uncle, then the parent module should depend on that uncle +;;; instead. Likewise a module should depend on a sibling, not a niece +;;; or nephew. Modules also cannot depend on cousins. Modules cannot +;;; depend on parents, since that is circular. + +(defun module-depends-on-changed (module changed) + (dolist (dependent (component-depends-on module)) + (when (member dependent changed) + (return t)))) (defun operate-on-components (component operation force changed) (with-tell-user (operation component) (if (component-components component) (dolist (module (component-components component)) (when (operate-on-component module operation - (cond ((and (some #'(lambda (dependent) + (cond ((and (module-depends-on-changed module changed) + #|(some #'(lambda (dependent) (member dependent changed)) - (component-depends-on module)) + (component-depends-on module))|# (or (non-empty-listp force) (eq force :new-source-and-dependents))) ;; The component depends on a changed file @@ -976,8 +3111,274 @@ D (eval (component-compile-form component))) ((load :load) (eval (component-load-form component)))))) + ;; This is only used as a boolean. changed) +;;; ******************************** +;;; New Require ******************** +;;; ******************************** +(defvar *old-require* nil) + +;;; All calls to require in this file have been replaced with calls +;;; to new-require to avoid compiler warnings and make this less of +;;; a tangled mess. +(defun new-require (module-name &optional pathname definition-pname + default-action (version *version*)) + ;; If the pathname is present, this behaves like the old require. + (unless (and module-name + (find #-CMU (string module-name) + #+CMU (string-downcase (string module-name)) + *modules* :test #'string=)) + (cond (pathname + (funcall *old-require* module-name pathname)) + ;; If the system is defined, load it. + ((find-system module-name :load-or-nil definition-pname) + (operate-on-system module-name :load + :force *force* + :version version + :test *oos-test* + :verbose *oos-verbose* + :load-source-if-no-binary *load-source-if-no-binary* + :bother-user-if-no-binary *bother-user-if-no-binary* + :compile-during-load *compile-during-load* + :load-source-instead-of-binary *load-source-instead-of-binary* + :minimal-load *minimal-load*)) + ;; If there's a default action, do it. This could be a progn which + ;; loads a file that does everything. + ((and default-action + (eval default-action))) + ;; If no system definition file, try regular require. + ;; had last arg PATHNAME, but this wasn't really necessary. + ((funcall *old-require* module-name)) + ;; If no default action, print a warning or error message. + (t + (format t "~&Warning: System ~A doesn't seem to be defined..." + module-name))))) + +;;; Note that in some lisps, when the compiler sees a REQUIRE form at +;;; top level it immediately executes it. This is as if an +;;; (eval-when (compile load eval) ...) were wrapped around the REQUIRE +;;; form. I don't see any easy way to do this without making REQUIRE +;;; a macro. +;;; +;;; For example, in VAXLisp, if a (require 'streams) form is at the top of +;;; a file in the system, compiling the system doesn't wind up loading the +;;; streams module. If the (require 'streams) form is included within an +;;; (eval-when (compile load eval) ...) then everything is OK. +;;; +;;; So perhaps we should replace the redefinition of lisp:require +;;; with the following macro definition: +#| +(unless *old-require* + (setf *old-require* + (symbol-function #-(or lispworks + (and :excl :allegro-v4.0)) 'lisp:require + #+lispworks 'system:::require + #+(and :excl :allegro-v4.0) 'cltl1:require)) + + (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil)) + ;; Note that lots of lisps barf if we redefine a function from + ;; the LISP package. So what we do is define a macro with an + ;; unused name, and use (setf macro-function) to redefine + ;; lisp:require without compiler warnings. If the lisp doesn't + ;; do the right thing, try just replacing require-as-macro + ;; with lisp:require. + (defmacro require-as-macro (module-name + &optional pathname definition-pname + default-action (version '*version*)) + `(eval-when (compile load eval) + (new-require ,module-name ,pathname ,definition-pname + ,default-action ,version))) + (setf (macro-function #-(and :excl :allegro-v4.0) 'lisp:require + #+(and :excl :allegro-v4.0) 'cltl1:require) + (macro-function 'require-as-macro)))) +|# +;;; This will almost certainly fix the problem, but will cause problems +;;; if anybody does a funcall on #'require. + +;;; Redefine old require to call the new require. +(eval-when #-(or :lucid :cmu17) (:load-toplevel :execute) + #+(or :lucid :cmu17) (load eval) +(unless *old-require* + (setf *old-require* + (symbol-function + #-(or (and :excl :allegro-v4.0) :mcl :lispworks) 'lisp:require + #+(and :excl :allegro-v4.0) 'cltl1:require + #+lispworks3.1 'common-lisp::require + #+(and :lispworks (not :lispworks3.1)) 'system::require + #+:mcl 'ccl:require)) + + (unless *dont-redefine-require* + (let (#+(or :mcl (and :CCL (not lispworks))) + (ccl:*warn-if-redefine-kernel* nil)) + #-(or (and allegro-version>= (version>= 4 1)) :lispworks) + (setf (symbol-function + #-(or (and :excl :allegro-v4.0) :mcl :lispworks) 'lisp:require + #+(and :excl :allegro-v4.0) 'cltl1:require + #+lispworks3.1 'common-lisp::require + #+(and :lispworks (not :lispworks3.1)) 'system::require + #+:mcl 'ccl:require) + (symbol-function 'new-require)) + #+lispworks + (let ((warn-packs system::*packages-for-warn-on-redefinition*)) + (declare (special system::*packages-for-warn-on-redefinition*)) + (setq system::*packages-for-warn-on-redefinition* nil) + (setf (symbol-function + #+:lispworks3.1 'common-lisp::require + #-:lispworks3.1 'system::require + ) + (symbol-function 'new-require)) + (setq system::*packages-for-warn-on-redefinition* warn-packs)) + #+(and allegro-version>= (version>= 4 1)) + (excl:without-package-locks + (setf (symbol-function 'lisp:require) + (symbol-function 'new-require)))))) +) + +;;; ******************************** +;;; Language-Dependent Characteristics +;;; ******************************** +;;; This section is used for defining language-specific behavior of +;;; defsystem. If the user changes a language definition, it should +;;; take effect immediately -- they shouldn't have to reload the +;;; system definition file for the changes to take effect. + +(defvar *language-table* (make-hash-table :test #'equal) + "Hash table that maps from languages to language structures.") +(defun find-language (name) + (gethash name *language-table*)) + +(defstruct (language (:print-function print-language)) + name ; The name of the language (a keyword) + compiler ; The function used to compile files in the language + loader ; The function used to load files in the language + source-extension ; Filename extensions for source files + binary-extension ; Filename extensions for binary files +) + +(defun print-language (language stream depth) + (declare (ignore depth)) + (format stream "#<~:@(~A~): ~A ~A>" + (language-name language) + (language-source-extension language) + (language-binary-extension language))) + +(defun compile-function (component) + (or (component-compiler component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (when language (language-compiler language))) + #'compile-file)) + +(defun load-function (component) + (or (component-loader component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (when language (language-loader language))) + #'load)) + +(defun default-source-extension (component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (or (when language (language-source-extension language)) + "lisp"))) + +(defun default-binary-extension (component) + (let ((language (find-language (or (component-language component) + :lisp)))) + (or (when language (language-binary-extension language)) + "fasl"))) + +(defmacro define-language (name &key compiler loader + source-extension binary-extension) + (let ((language (gensym "LANGUAGE"))) + `(let ((,language (make-language :name ,name + :compiler ,compiler + :loader ,loader + :source-extension ,source-extension + :binary-extension ,binary-extension))) + (setf (gethash ,name *language-table*) ,language) + ,name))) + +#| +;;; Test System for verifying multi-language capabilities. +(defsystem foo + :language :lisp + :components ((:module c :language :c :components ("foo" "bar")) + (:module lisp :components ("baz" "barf")))) + +|# + +;;; *** Lisp Language Definition +(define-language :lisp + :compiler #'compile-file + :loader #'load + :source-extension (car *filename-extensions*) + :binary-extension (cdr *filename-extensions*)) + +;;; *** PseudoScheme Language Definition +(defun scheme-compile-file (filename &rest args) + (let ((scheme-package (find-package "SCHEME"))) + (apply (symbol-function (find-symbol "COMPILE-FILE" + scheme-package)) + filename + (funcall (symbol-function + (find-symbol "INTERACTION-ENVIRONMENT" + scheme-package))) + args))) + +(define-language :scheme + :compiler #'scheme-compile-file + :loader #'load + :source-extension "scm" + :binary-extension "bin") + +;;; *** C Language Definition + +;;; This is very basic. Somebody else who needs it can add in support +;;; for header files, libraries, different C compilers, etc. For example, +;;; we might add a COMPILER-OPTIONS slot to the component defstruct. + +(defparameter *c-compiler* "gcc") +#-symbolics +(defun run-unix-program (program arguments) + #+:lucid (run-program program :arguments arguments) + #+:allegro (excl:run-shell-command (format nil "~A~@[ ~A~]" + program arguments)) + #+KCL (system (format nil "~A~@[ ~A~]" program arguments)) + #+:cmu (extensions:run-program program arguments) + #+:lispworks (foreign:call-system-showing-output + (format nil "~A~@[ ~A~]" program arguments)) + ) +(defun c-compile-file (filename &rest args &key output-file) + ;; gcc -c foo.c -o foo.o + (declare (ignore args)) + (run-unix-program *c-compiler* + (format nil "-c ~A~@[ -o ~A~]" + filename + output-file))) + +(define-language :c + :compiler #'c-compile-file + :loader #+:lucid #'load-foreign-files + #+:allegro #'load + #-(or :lucid :allegro) #'load + :source-extension "c" + :binary-extension "o") + +#| +;;; FDMM's changes, which we've replaced. +(defvar *compile-file-function* #'cl-compile-file) + +#+(or :clos :pcl) +(defmethod set-language ((lang (eql :common-lisp))) + (setq *compile-file-function* #'cl-compile-file)) + +#+(or :clos :pcl) +(defmethod set-language ((lang (eql :scheme))) + (setq *compile-file-function #'scheme-compile-file)) +|# + ;;; ******************************** ;;; Component Operations *********** ;;; ******************************** @@ -988,28 +3389,69 @@ D (component-operation 'load 'load-file-operation) (defun compile-and-load-operation (component force) + ;; FORCE was CHANGED. this caused defsystem during compilation to only + ;; load files that it immediately compiled. (let ((changed (compile-file-operation component force))) - (load-file-operation component changed) - changed)) + ;; Return T if the file had to be recompiled and reloaded. + (if (and changed (component-compile-only component)) + ;; For files which are :compile-only T, compiling the file + ;; satisfies the need to load. + changed + ;; If the file wasn't compiled, or :compile-only is nil, + ;; check to see if it needs to be loaded. + (and (load-file-operation component force) ; FORCE was CHANGED ??? + changed)))) + +(defun unmunge-lucid (namestring) + ;; Lucid's implementation of COMPILE-FILE is non-standard, in that + ;; when the :output-file is a relative pathname, it tries to munge + ;; it with the directory of the source file. For example, + ;; (compile-file "src/globals.lisp" :output-file "bin/globals.sbin") + ;; tries to stick the file in "./src/bin/globals.sbin" instead of + ;; "./bin/globals.sbin" like any normal lisp. This hack seems to fix the + ;; problem. I wouldn't have expected this problem to occur with any + ;; use of defsystem, but some defsystem users are depending on + ;; using relative pathnames (at least three folks reported the problem). + (cond ((null-string namestring) namestring) + ((char= (char namestring 0) #\/) + ;; It's an absolute namestring + namestring) + (t + ;; Ugly, but seems to fix the problem. + (concatenate 'string "./" namestring)))) (defun compile-file-operation (component force) ;; Returns T if the file had to be compiled. (let ((must-compile - (or (find force '(:all :new-source-all t) :test #'eq) - (and (find force '(:new-source :new-source-and-dependents) - :test #'eq) - (needs-compilation component))))) - - (cond ((and must-compile - (probe-file (component-full-pathname component :source))) + ;; For files which are :load-only T, loading the file + ;; satisfies the demand to recompile. + (and (null (component-load-only component)) ; not load-only + (or (find force '(:all :new-source-all t) :test #'eq) + (and (find force '(:new-source :new-source-and-dependents) + :test #'eq) + (needs-compilation component))))) + (source-pname (component-full-pathname component :source))) + + (cond ((and must-compile (probe-file source-pname)) (with-tell-user ("Compiling source" component :source) - (or *oos-test* - (compile-file (component-full-pathname component :source) - :output-file (component-full-pathname component :binary) - #+CMU :error-file #+CMU (and *cmu-errors-to-file* - (component-full-pathname component :error)) - #+CMU :errors-to-terminal #+CMU *cmu-errors-to-terminal* - ))) + (or *oos-test* + (funcall (compile-function component) + source-pname + :output-file + #+:lucid + (unmunge-lucid (component-full-pathname component + :binary)) + #-:lucid + (component-full-pathname component :binary) + #+CMU :error-file + #+CMU (and *cmu-errors-to-file* + (component-full-pathname component + :error)) + #+(and CMU (not :new-compiler)) + :errors-to-terminal + #+(and CMU (not :new-compiler)) + *cmu-errors-to-terminal* + ))) must-compile) (must-compile (tell-user "Source file not found. Not compiling" @@ -1021,50 +3463,140 @@ D ;; If there is no binary, or it is older than the source ;; file, then the component needs to be compiled. ;; Otherwise we only need to recompile if it depends on a file that changed. - (or - ;; no binary - (null (probe-file (component-full-pathname component :binary))) - ;; old binary - (< (file-write-date (component-full-pathname component :binary)) - (file-write-date (component-full-pathname component :source))))) - + (let ((source-pname (component-full-pathname component :source)) + (binary-pname (component-full-pathname component :binary))) + (and + ;; source must exist + (probe-file source-pname) + (or + ;; no binary + (null (probe-file binary-pname)) + ;; old binary + (< (file-write-date binary-pname) + (file-write-date source-pname)))))) + +(defun needs-loading (component &optional (check-source t) (check-binary t)) + ;; Compares the component's load-time against the file-write-date of + ;; the files on disk. + (let ((load-time (component-load-time component)) + (source-pname (component-full-pathname component :source)) + (binary-pname (component-full-pathname component :binary))) + (or + ;; File never loaded. + (null load-time) + ;; Binary is newer. + (when (and check-binary + (probe-file binary-pname)) + (< load-time + (file-write-date binary-pname))) + ;; Source is newer. + (when (and check-source + (probe-file source-pname)) + (< load-time + (file-write-date source-pname)))))) + +;;; Need to completely rework this function... (defun load-file-operation (component force) ;; Returns T if the file had to be loaded - (let ((load-source - (or *load-source-instead-of-binary* - (and (find force '(:new-source :new-source-and-dependents - :new-source-all) - :test #'eq) - (needs-compilation component)))) - (load-binary - (or (find force '(:all :new-source-all t) :test #'eq) ; Force load. - ;; :new-source* and binary up to date - (find force '(:new-source :new-source-and-dependents) - :test #'eq)))) - - (cond ((and load-source - (probe-file (component-full-pathname component :source))) - (with-tell-user ("Loading source" component :source) + (let* ((binary-pname (component-full-pathname component :binary)) + (source-pname (component-full-pathname component :source)) + (binary-exists (probe-file binary-pname)) + (source-exists (probe-file source-pname)) + (source-needs-loading (needs-loading component t nil)) + (binary-needs-loading (needs-loading component nil t)) + ;; needs-compilation has an implicit source-exists in it. + (needs-compilation (if (component-load-only component) + source-needs-loading + (needs-compilation component))) + (check-for-new-source + ;; If force is :new-source*, we're checking for files + ;; whose source is newer than the compiled versions. + (find force '(:new-source :new-source-and-dependents :new-source-all) + :test #'eq)) + (load-binary (or (find force '(:all :new-source-all t) :test #'eq) + binary-needs-loading)) + (load-source + (or *load-source-instead-of-binary* + (and load-binary (component-load-only component)) + (and check-for-new-source needs-compilation))) + (compile-and-load + (and needs-compilation (or load-binary check-for-new-source) + (compile-and-load-source-if-no-binary component)))) + ;; When we're trying to minimize the files loaded to only those + ;; that need be, restrict the values of load-source and load-binary + ;; so that we only load the component if the files are newer than + ;; the load-time. + (when *minimal-load* + (when load-source (setf load-source source-needs-loading)) + (when load-binary (setf load-binary binary-needs-loading))) + + (when (or load-source load-binary compile-and-load) + (cond (compile-and-load + ;; If we're loading the binary and it is old or nonexistent, + ;; and the user says yes, compile and load the source. + (compile-file-operation component t) + (with-tell-user ("Loading binary" component :binary) (or *oos-test* - (load (component-full-pathname component :source)))) - T) - ((and load-binary - (probe-file (component-full-pathname component :binary))) - (with-tell-user ("Loading binary" component :binary) + (progn + (funcall (load-function component) binary-pname) + (setf (component-load-time component) + (file-write-date binary-pname))))) + T) + ((and source-exists + (or (and load-source ; implicit needs-comp... + (or *load-source-instead-of-binary* + (component-load-only component) + (not *compile-during-load*))) + (and load-binary (not binary-exists) + (load-source-if-no-binary component)))) + ;; Load the source if the source exists and: + ;; o we're loading binary and it doesn't exist + ;; o we're forcing it + ;; o we're loading new source and user wasn't asked to compile + (with-tell-user ("Loading source" component :source) (or *oos-test* - (load (component-full-pathname component :binary)))) - T) - ((and load-binary - (probe-file (component-full-pathname component :source)) - (load-source-if-no-binary component)) - (with-tell-user ("Loading source" component :source) + (progn + (funcall (load-function component) source-pname) + (setf (component-load-time component) + (file-write-date source-pname))))) + T) + ((and binary-exists load-binary) + (with-tell-user ("Loading binary" component :binary) (or *oos-test* - (load (component-full-pathname component :source)))) - T) - ((or load-source load-binary) - (tell-user-no-files component :force) - nil) - (t nil)))) + (progn + (funcall (load-function component) binary-pname) + (setf (component-load-time component) + (file-write-date binary-pname))))) + T) + ((and (not binary-exists) (not source-exists)) + (tell-user-no-files component :force) + (when *files-missing-is-an-error* + (cerror "Continue, ignoring missing files." + "~&Source file ~S ~:[and binary file ~S ~;~]do not exist." + source-pname + (or *load-source-if-no-binary* + *load-source-instead-of-binary*) + binary-pname)) + nil) + (t + nil))))) + +(component-operation :clean 'delete-binaries-operation) +(component-operation 'clean 'delete-binaries-operation) +(component-operation :delete-binaries 'delete-binaries-operation) +(component-operation 'delete-binaries 'delete-binaries-operation) +(defun delete-binaries-operation (component force) + (when (or (eq force :all) + (eq force t) + (and (find force '(:new-source :new-source-and-dependents + :new-source-all) + :test #'eq) + (needs-compilation component))) + (let ((binary-pname (component-full-pathname component :binary))) + (when (probe-file binary-pname) + (with-tell-user ("Deleting binary" component :binary) + (or *oos-test* + (delete-file binary-pname))))))) ;; when the operation = :compile, we can assume the binary exists in test mode. @@ -1073,23 +3605,63 @@ D ;; (probe-file (component-full-pathname component :source))) ;; (with-tell-user ("Loading binary" component :binary))) +(defun binary-exists (component) + (probe-file (component-full-pathname component :binary))) + +;;; or old-binary +(defun compile-and-load-source-if-no-binary (component) + (when (not (or *load-source-instead-of-binary* + (and *load-source-if-no-binary* + (not (binary-exists component))))) + (cond ((component-load-only component) + #|(let ((prompt (prompt-string component))) + (format t "~A- File ~A is load-only, ~ + ~&~A not compiling." + prompt + (component-full-pathname component :source) + prompt))|# + nil) + ((eq *compile-during-load* :query) + (let* ((prompt (prompt-string component)) + (compile-source + (y-or-n-p-wait + #\y 30 + "~A- Binary file ~A is old or does not exist. ~ + ~&~A Compile (and load) source file ~A instead? " + prompt + (component-full-pathname component :binary) + prompt + (component-full-pathname component :source)))) + (unless (y-or-n-p-wait + #\y 30 + "~A- Should I bother you if this happens again? " + prompt) + (setq *compile-during-load* + (y-or-n-p-wait + #\y 30 + "~A- Should I compile and load or not? " + prompt))) ; was compile-source, then t + compile-source)) + (*compile-during-load*) + (t nil)))) + (defun load-source-if-no-binary (component) (and (not *load-source-instead-of-binary*) - (or *load-source-if-no-binary* + (or (and *load-source-if-no-binary* + (not (binary-exists component))) + (component-load-only component) (when *bother-user-if-no-binary* (let* ((prompt (prompt-string component)) (load-source - (y-or-n-p-wait-optional - #\y 30 + (y-or-n-p-wait #\y 30 "~A- Binary file ~A does not exist. ~ ~&~A Load source file ~A instead? " prompt - (namestring (component-full-pathname component :binary)) + (component-full-pathname component :binary) prompt - (namestring (component-full-pathname component :source))))) + (component-full-pathname component :source)))) (setq *bother-user-if-no-binary* - (y-or-n-p-wait-optional - #\n 30 + (y-or-n-p-wait #\n 30 "~A- Should I bother you if this happens again? " prompt )) (unless *bother-user-if-no-binary* @@ -1097,83 +3669,127 @@ D load-source))))) ;;; ******************************** -;;; New Require ******************** +;;; Allegro Toplevel Commands ****** ;;; ******************************** -(defun compute-system-path (module-name definition-pname) - (let* ((filename (format nil "~A.system" - (if (symbolp module-name) - (string-downcase (string module-name)) - module-name)))) - (or (when definition-pname ; given pathname for system def - (probe-file definition-pname)) - (probe-file filename) ; try current dir - (probe-file (append-directories *central-registry* filename))) ; central registry - )) +;;; Creates toplevel command aliases for Allegro CL. +#+:allegro +(top-level:alias ("compile-system" 8) + (system &key force (minimal-load mk:*minimal-load*) + test verbose version) + "Compile the specified system" -(unless (fboundp 'old-require) - (setf (symbol-function 'old-require) (symbol-function 'lisp:require)) + (mk:compile-system system :force force + :minimal-load minimal-load + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("load-system" 5) + (system &key force (minimal-load mk:*minimal-load*) + (compile-during-load mk:*compile-during-load*) + test verbose version) + "Compile the specified system" + + (mk:load-system system :force force + :minimal-load minimal-load + :compile-during-load compile-during-load + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("show-system" 5) (system) + "Show information about the specified system." + + (mk:describe-system system)) + +#+:allegro +(top-level:alias ("describe-system" 9) (system) + "Show information about the specified system." + + (mk:describe-system system)) + +#+:allegro +(top-level:alias ("system-source-size" 9) (system) + "Show size information about source files in the specified system." + + (mk:system-source-size system)) + +#+:allegro +(top-level:alias ("clean-system" 6) + (system &key force test verbose version) + "Delete binaries in the specified system." + + (mk:clean-system system :force force + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("edit-system" 7) + (system &key force test verbose version) + "Load system source files into Emacs." + + (mk:edit-system system :force force + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("hardcopy-system" 9) + (system &key force test verbose version) + "Hardcopy files in the specified system." + + (mk:hardcopy-system system :force force + :test test :verbose verbose + :version version)) + +#+:allegro +(top-level:alias ("make-system-tag-table" 13) (system) + "Make an Emacs TAGS file for source files in specified system." + + (mk:make-system-tag-table system)) - (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil)) - (defun lisp:require (module-name &optional pathname definition-pname - default-action (version *version*) - &aux system-path) - ;; If the pathname is present, this behaves like the old require. - (unless (and module-name - (find #-CMU (string module-name) - #+CMU (string-downcase (string module-name)) - *modules* :test #'string=)) - (cond (pathname - (funcall 'old-require module-name pathname)) - ;; If the system is defined, load it. - ((or (get-system module-name) - (and (setq system-path - (compute-system-path module-name definition-pname)) - (load system-path) - (get-system module-name))) - (operate-on-system module-name :load - :version version - :test *oos-test* - :verbose *oos-verbose* - :load-source-if-no-binary *load-source-if-no-binary* - :bother-user-if-no-binary *bother-user-if-no-binary* - :load-source-instead-of-binary *load-source-instead-of-binary*)) - ;; If there's a default action, do it. This could be a progn which - ;; loads a file that does everything. - ((and default-action - (eval default-action))) - ;; If no system definition file, try regular require. - ((funcall 'old-require module-name pathname)) - ;; If no default action, print a warning or error message. - (t - (format t "~&Warning: System ~A doesn't seem to be defined..." module-name)) - ))))) ;;; ******************************** ;;; Allegro Make System Fasl ******* ;;; ******************************** #+:excl -(defun allegro-make-system-fasl (system destination) +(defun allegro-make-system-fasl (system destination + &optional (include-dependents t)) (excl:shell (format nil "rm -f ~A; cat~{ ~A~} > ~A" destination - (mapcar #'namestring - (files-in-system system :all :binary))))) + (if include-dependents + (files-in-system-and-dependents system :all :binary) + (files-in-system system :all :binary)) + destination))) (defun files-which-need-compilation (system) - (mapcar #'(lambda (comp) (namestring (component-full-pathname comp :source))) + (mapcar #'(lambda (comp) (component-full-pathname comp :source)) (remove nil (file-components-in-component - (get-system system) :new-source)))) - -(defun files-in-system (name &optional (force :all) (type :source) version - &aux system) + (find-system system :load) :new-source)))) + +(defun files-in-system-and-dependents (name &optional (force :all) + (type :source) version) + ;; Returns a list of the pathnames in system and dependents in load order. + (let ((system (find-system name :load))) + (multiple-value-bind (*version-dir* *version-replace*) + (translate-version version) + (let ((*version* version)) + (let ((result (file-pathnames-in-component system type force))) + (dolist (dependent (reverse (component-depends-on system))) + (setq result + (append (files-in-system-and-dependents dependent + force type version) + result))) + result))))) + +(defun files-in-system (name &optional (force :all) (type :source) version) ;; Returns a list of the pathnames in system in load order. - (setq system (get-system name)) - (unless system (error "Can't find system named ~A." name)) - (multiple-value-bind (*version-dir* *version-replace*) - (translate-version version) - (let ((*version* version)) - (file-pathnames-in-component system type force)))) + (let ((system (find-system name :load))) + (multiple-value-bind (*version-dir* *version-replace*) + (translate-version version) + (let ((*version* version)) + (file-pathnames-in-component system type force))))) (defun file-pathnames-in-component (component type &optional (force :all)) (mapcar #'(lambda (comp) (component-full-pathname comp type)) @@ -1189,7 +3805,7 @@ D (needs-compilation component)))) (setq result (list component)))) - ((:module :system) + ((:module :system :subsystem :defsystem) (dolist (module (component-components component)) (multiple-value-bind (r c) (file-components-in-component @@ -1214,4 +3830,132 @@ D (setf (symbol-function 'oos) (symbol-function 'operate-on-system)) +;;; ******************************** +;;; Additional Component Operations +;;; ******************************** + +;;; *** Edit Operation *** + +;;; Should this conditionalization be (or :mcl (and :CCL (not lispworks)))? +#+:ccl +(defun edit-operation (component force) + "Always returns nil, i.e. component not changed." + (declare (ignore force)) + ;; + (let* ((full-pathname (make::component-full-pathname component :source)) + (already-editing\? #+:mcl (dolist (w (CCL:windows :class + 'fred-window)) + (when (equal (CCL:window-filename w) + full-pathname) + (return w))) + #-:mcl nil)) + (if already-editing\? + #+:mcl (CCL:window-select already-editing\?) #-:mcl nil + (ed full-pathname))) + nil) + +#+:allegro +(defun edit-operation (component force) + "Edit a component - always returns nil, i.e. component not changed." + (declare (ignore force)) + (let ((full-pathname (component-full-pathname component :source))) + (ed full-pathname)) + nil) + +#+(or :ccl :allegro) +(make::component-operation :edit 'edit-operation) +#+(or :ccl :allegro) +(make::component-operation 'edit 'edit-operation) + +;;; *** Hardcopy System *** +(defparameter *print-command* "enscript -2Gr" ; "lpr" + "Command to use for printing files on UNIX systems.") +#+:allegro +(defun hardcopy-operation (component force) + "Hardcopy a component - always returns nil, i.e. component not changed." + (declare (ignore force)) + (let ((full-pathname (component-full-pathname component :source))) + (excl:run-shell-command (format nil "~A ~A" + *print-command* full-pathname))) + nil) + +#+:allegro +(make::component-operation :hardcopy 'hardcopy-operation) +#+:allegro +(make::component-operation 'hardcopy 'hardcopy-operation) + + +;;; *** System Source Size *** + +(defun system-source-size (system-name) + "Prints a short report and returns the size in bytes of the source files in + <system-name>." + (let* ((file-list (files-in-system system-name :all :source)) + (total-size (file-list-size file-list))) + (format t "~&~S (~A files) totals ~A bytes (~A K)" + system-name (length file-list) total-size (round total-size 1024)) + total-size)) + +(defun file-list-size (file-list) + "Returns the size in bytes of the files in <file-list>." + ;; + (let ((total-size 0)) + (dolist (file file-list) + (with-open-file (stream file) + (incf total-size (file-length stream)))) + total-size)) + +;;; *** System Tag Table *** + +#+:allegro +(defun make-system-tag-table (system-name) + "Makes an Emacs tag table using the GNU etags program." + (let ((files-in-system (files-in-system system-name :all :source))) + + (format t "~&Making tag table...") + (excl:run-shell-command (format nil "etags ~{~a ~}" files-in-system)) + (format t "done.~%"))) + + + +;;; **************************************************************** +;;; Dead Code ****************************************************** +;;; **************************************************************** + +#| +;;; ******************************** +;;; Alist Manipulation ************* +;;; ******************************** +;;; This is really gross. I've replaced it with hash tables. + +(defun alist-lookup (name alist &key (test #'eql) (key #'identity)) + (cdr (assoc name alist :test test :key key))) + +(defmacro set-alist-lookup ((name alist &key (test '#'eql) (key '#'identity)) + value) + (let ((pair (gensym))) + `(let ((,pair (assoc ,name ,alist :test ,test :key ,key))) + (if ,pair + (rplacd ,pair ,value) + (push (cons ,name ,value) ,alist))))) + +(defun component-operation (name &optional operation) + (if operation + (set-alist-lookup (name *component-operations*) operation) + (alist-lookup name *component-operations*))) + +(defun machine-type-translation (name &optional operation) + (if operation + (set-alist-lookup (name *machine-type-alist* :test #'string-equal) + operation) + (alist-lookup name *machine-type-alist* :test #'string-equal))) + +(defun software-type-translation (name &optional operation) + (if operation + (set-alist-lookup (name *software-type-alist* :test #'string-equal) + operation) + (alist-lookup name *software-type-alist* :test #'string-equal))) + +|# + ;;; *END OF FILE* -- GitLab