diff --git a/contrib/defsystem/defsystem.lisp b/contrib/defsystem/defsystem.lisp deleted file mode 100644 index 74b9d9137dbf03f1c98a9d282200982631dbcd72..0000000000000000000000000000000000000000 --- a/contrib/defsystem/defsystem.lisp +++ /dev/null @@ -1,3964 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-Lisp -*- -;;; 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 -;;; defsystem facility on Symbolics 3600's. The exhaustive lists of -;;; filename extensions for various lisps and the idea to have one -;;; "operate-on-system" function instead of separate "compile-system" -;;; and "load-system" functions were taken from Xerox Corp.'s PCL -;;; system. - -;;; This system improves on both PCL and Symbolics defsystem utilities -;;; by performing a topological sort of the graph of file-dependency -;;; constraints. Thus, the components of the system need not be listed -;;; in any special order, because the defsystem command reorganizes them -;;; based on their constraints. It includes all the standard bells and -;;; whistles, such as not recompiling a binary file that is up to date -;;; (unless the user specifies that all files should be recompiled). - -;;; Written by Mark Kantrowitz, School of Computer Science, -;;; Carnegie Mellon University, October 1989. - -;;; 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 -;;; conditions are met: -;;; o no fees or compensation are charged for use, copies, or -;;; access to this software -;;; o this copyright notice is included intact. -;;; This software is made available AS IS, and no warranty is made about -;;; 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 ********************************************* -;;; ******************************************************************** - -;;; To use this system, -;;; 1. If you want to have a central registry of system definitions, -;;; modify the value of the variable *central-registry* below. -;;; 2. Load this file (defsystem.lisp) in either source or compiled form, -;;; 3. Load the file containing the "defsystem" definition of your system, -;;; 4. Use the function "operate-on-system" to do things to your system. - -;;; For more information, see the documentation and examples in -;;; lisp-utilities.ps. - -;;; ******************************** -;;; Usage Comments ***************** -;;; ******************************** - -;;; If you use symbols in the system definition file, they get interned in -;;; the COMMON-LISP-USER package, which can lead to name conflicts when -;;; the system itself seeks to export the same symbol to the COMMON-LISP-USER -;;; package. The workaround is to use strings instead of symbols for the -;;; names of components in the system definition file. In the major overhaul, -;;; perhaps the user should be precluded from using symbols for such -;;; identifiers. -;;; -;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp", -;;; file name expansion is much slower than if you use the full pathname, -;;; as in "/user/USERID/lisp". -;;; - - -;;; **************************************************************** -;;; Lisp Code ****************************************************** -;;; **************************************************************** - -;;; ******************************** -;;; Massage CLtL2 onto *features* ** -;;; ******************************** -;;; Let's be smart about CLtL2 compatible Lisps: -(eval-when (compile load eval) - #+(or (and allegro-version>= (version>= 4 0)) :mcl) - (pushnew :cltl2 *features*)) - -;;; ******************************** -;;; Provide/Require/*modules* ****** -;;; ******************************** - -;;; Since CLtL2 has dropped require and provide from the language, some -;;; lisps may not have the functions PROVIDE and REQUIRE and the -;;; global *MODULES*. So if lisp::provide and user::provide are not -;;; defined, we define our own. - -;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions -;;; and variables not being declared or bound, apparently because it -;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns -;;; T, so it doesn't really bother when compiling the body of the unless. -;;; The new compiler does this properly, so I'm not going to bother -;;; working around this. - -;;; Some Lisp implementations return bogus warnings about assuming -;;; *MODULE-FILES* and *LIBRARY* to be special, and CANONICALIZE-MODULE-NAME -;;; and MODULE-FILES being undefined. Don't worry about them. - -;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code -;;; necessary? - -#-(or (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))))))) - -;;; ******************************** -;;; Set up Package ***************** -;;; ******************************** - - -;;; Unfortunately, lots of lisps have their own defsystems, some more -;;; primitive than others, all uncompatible, and all in the DEFSYSTEM -;;; package. To avoid name conflicts, we've decided to name this the -;;; MAKE package. A nice side-effect is that the short nickname -;;; MK is my initials. - -#-(or :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. -;;; 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) (excl:current-directory) - #+:cmu (ext: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.") - -;;; These variables set up defaults for operate-on-system, and are used -;;; for communication in lieu of parameter passing. Yes, this is bad, -;;; but it keeps the interface small. Also, in the case of the -if-no-binary -;;; variables, parameter passing would require multiple value returns -;;; from some functions. Why make life complicated? -(defvar *tell-user-when-done* nil - "If T, system will print ...DONE at the end of an operation") -(defvar *oos-verbose* nil - "Operate on System Verbose Mode") -(defvar *oos-test* nil - "Operate on System Test Mode") -(defvar *load-source-if-no-binary* nil - "If T, system will try loading the source if the binary is missing") -(defvar *bother-user-if-no-binary* t - "If T, the system will ask the user whether to load the source if - the binary is missing") -(defvar *load-source-instead-of-binary* nil - "If T, the system will load the source file instead of the binary.") -(defvar *compile-during-load* :query - "If T, the system will compile source files during load if the - binary file is missing. If :query, it will ask the user for - permission first.") -(defvar *minimal-load* nil - "If T, the system tries to avoid reloading files that were already loaded - and up to date.") - -(defvar *files-missing-is-an-error* t - "If both the source and binary files are missing, signal a continuable - error instead of just a warning.") - -(defvar *operations-propagate-to-subsystems* t - "If T, operations like :COMPILE and :LOAD propagate to subsystems - of a system that are defined either using a component-type of :system - or by another defsystem form.") - -;;; Particular to CMULisp -(defvar *compile-error-file-type* "err" - "File type of compilation error file in cmulisp") -(defvar *cmu-errors-to-terminal* t - "Argument to :errors-to-terminal in compile-file in cmulisp") -(defvar *cmu-errors-to-file* t - "If T, cmulisp will write an error file during compilation") - -;;; ******************************** -;;; Global Variables *************** -;;; ******************************** - -;;; Massage people's *features* into better shape. -(eval-when (compile load eval) - (dolist (feature *features*) - (when (and (symbolp feature) ; 3600 - (equal (symbol-name feature) "CMU")) - (pushnew :CMU *features*))) - - #+Lucid - (when (search "IBM RT PC" (machine-type)) - (pushnew :ibm-rt-pc *features*)) - ) - -;;; *filename-extensions* is a cons of the source and binary extensions. -(defvar *filename-extensions* - (car `(#+(and Symbolics Lispm) ("lisp" . "bin") - #+(and dec common vax (not ultrix)) ("LSP" . "FAS") - #+(and dec common vax ultrix) ("lsp" . "fas") - #+ACLPC ("lsp" . "fsl") - #+CLISP ("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") - ;; PA is Precision Architecture, HP's 9000/800 RISC cpu - #+(and Lucid PA) ("lisp" . "hbin") - #+excl ("cl" . "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" . "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 -;;; might be useful if we define several systems within one defsystem. -(defvar *system-dependencies-delayed* t - "If T, system dependencies are expanded at run time") - -;;; Replace this with consp, dammit! -(defun non-empty-listp (list) - (and list (listp list))) - -;;; ******************************** -;;; Component Operation Definition * -;;; ******************************** -(defvar *version-dir* nil - "The version subdir. bound in operate-on-system.") -(defvar *version-replace* nil - "The version replace. bound in operate-on-system.") -(defvar *version* nil - "Default version.") - -(defvar *component-operations* (make-hash-table :test #'equal) - "Hash table of (operation-name function) pairs.") -(defun component-operation (name &optional operation) - (if operation - (setf (gethash name *component-operations*) operation) - (gethash name *component-operations*))) - -;;; ******************************** -;;; AFS @sys immitator ************* -;;; ******************************** - -;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out. -#-:mcl -(eval-when (compile load eval) - ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo"). - ;; For example, - ;; <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. 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/~]" - root-directory - *bin-subdir* - (if *multiple-lisp-support* - (afs-component machine software lisp) - (afs-component machine software))))) - -(defun afs-source-directory (root-directory &optional version-flag) - ;; Function for obtaining the directory AFS's @sys feature would have - ;; chosen when we're not in AFS. This function is useful as the argument - ;; to :source-pathname in defsystem. - (setq root-directory (namestring root-directory)) - (setq root-directory (ensure-trailing-slash root-directory)) - (format nil "~A~@[~A/~]" - root-directory - (and version-flag (translate-version *version*)))) - -(defun null-string (s) - (when (stringp s) - (string-equal s ""))) - -(defun ensure-trailing-slash (dir) - (if (and dir - (not (null-string dir)) - (not (char= (char dir - (1- (length dir))) - #\/))) - (concatenate 'string dir "/") - dir)) - -(defun afs-component (machine software &optional lisp) - (format nil "~@[~A~]~@[_~A~]~@[_~A~]" - machine - (or software "mach") - lisp)) - -(defvar *machine-type-alist* (make-hash-table :test #'equal) - "Hash table for retrieving the machine-type") -(defun machine-type-translation (name &optional operation) - (if operation - (setf (gethash (string-upcase name) *machine-type-alist*) operation) - (gethash (string-upcase name) *machine-type-alist*))) - -(machine-type-translation "IBM RT PC" "rt") -(machine-type-translation "DEC 3100" "pmax") -(machine-type-translation "DEC VAX-11" "vax") -(machine-type-translation "DECstation" "pmax") -(machine-type-translation "Sun3" "sun3") -(machine-type-translation "Sun-4" "sun4") -(machine-type-translation "MIPS Risc" "mips") -(machine-type-translation "SGI" "sgi") -(machine-type-translation "Silicon Graphics Iris 4D" "sgi") -(machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi") -(machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi") -(machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi") -(machine-type-translation "IP22" "sgi") -;;; MIPS R4000 Processor Chip Revision: 3.0 -;;; MIPS R4400 Processor Chip Revision: 5.0 -;;; MIPS R4600 Processor Chip Revision: 1.0 -(machine-type-translation "IP20" "sgi") -;;; MIPS R4000 Processor Chip Revision: 3.0 -(machine-type-translation "IP17" "sgi") -;;; MIPS R4000 Processor Chip Revision: 2.2 -(machine-type-translation "IP12" "sgi") -;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0 -(machine-type-translation "IP7" "sgi") -;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0 - -#+(and :lucid :sun :mc68000) -(machine-type-translation "unknown" "sun3") - - -(defvar *software-type-alist* (make-hash-table :test #'equal) - "Hash table for retrieving the software-type") -(defun software-type-translation (name &optional operation) - (if operation - (setf (gethash (string-upcase name) *software-type-alist*) operation) - (gethash (string-upcase name) *software-type-alist*))) - -(software-type-translation "BSD UNIX" "mach") ; "unix" -(software-type-translation "Ultrix" "mach") ; "ultrix" -(software-type-translation "SunOS" "SunOS") -(software-type-translation "MACH/4.3BSD" "mach") -(software-type-translation "IRIX System V" "irix") ; (software-type) -(software-type-translation "IRIX5" "irix5") -;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version) - -(software-type-translation "IRIX 5.2" "irix5") -(software-type-translation "IRIX 5.3" "irix5") -(software-type-translation "IRIX5.2" "irix5") -(software-type-translation "IRIX5.3" "irix5") -(software-type-translation nil "") - -#+:lucid -(software-type-translation "Unix" - #+:lcl4.0 "4.0" - #+(and :lcl3.0 (not :lcl4.0)) "3.0") - -(defvar *compiler-type-alist* (make-hash-table :test #'equal) - "Hash table for retrieving the Common Lisp type") -(defun compiler-type-translation (name &optional operation) - (if operation - (setf (gethash (string-upcase name) *compiler-type-alist*) operation) - (gethash (string-upcase name) *compiler-type-alist*))) - -(compiler-type-translation "lispworks 3.2.1" "lispworks") -(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks") -(compiler-type-translation "excl 4.2" "excl") -(compiler-type-translation "excl 4.1" "excl") -(compiler-type-translation "cmu 17f" "cmu") -(compiler-type-translation "cmu 17e" "cmu") -(compiler-type-translation "cmu 17d" "cmu") - -;;; ******************************** -;;; System Names ******************* -;;; ******************************** - -;;; If you use strings for system names, be sure to use the same case -;;; as it appears on disk, if the filesystem is case sensitive. -(defun canonicalize-system-name (name) - ;; Originally we were storing systems using GET. This meant that the - ;; name of a system had to be a symbol, so we interned the symbols - ;; in the keyword package to avoid package dependencies. Now that we're - ;; storing the systems in a hash table, we've switched to using strings. - ;; Since the hash table is case sensitive, we use uppercase strings. - ;; (Names of modules and files may be symbols or strings.) - #|(if (keywordp name) - name - (intern (string-upcase (string name)) "KEYWORD"))|# - (if (stringp name) (string-upcase name) (string-upcase (string name)))) - -(defvar *defined-systems* (make-hash-table :test #'equal) - "Hash table containing the definitions of all known systems.") - -(defun get-system (name) - "Returns the definition of the system named NAME." - (gethash (canonicalize-system-name name) *defined-systems*)) - -(defsetf get-system (name) (value) - `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value)) - -(defun undefsystem (name) - "Removes the definition of the system named NAME." - (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 ***** -;;; ******************************** - -;;; 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 (or (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) - "There is no CL primitive for tacking a subdirectory onto a directory. - We need such a function because defsystem has both absolute and - relative pathnames in the modules. This is a somewhat ugly hack which - seems to work most of the time. We assume that ABSOLUTE-DIRECTORY - is a directory, with no filename stuck on the end. Relative-directory, - however, may have a filename stuck on the end." - (when (or absolute-directory relative-directory) - (cond - ;; 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))) - -#| -;;; 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/" "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") -"foo/bar/baz/barf.lisp" - -<cl> (d "foo/bar" "baz/barf.lisp") -"foo/bar/baz/barf.lisp" - -<cl> (d "foo/bar" "/baz/barf.lisp") -"foo/bar//baz/barf.lisp" - -<cl> (d "foo/bar" nil) -"foo/bar/" - -<cl> (d nil "baz/barf.lisp") -"baz/barf.lisp" - -<cl> (d nil nil) -"" - -|# - - - - -(defun new-file-type (pathname type) - (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name (pathname-name pathname) - :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 -) - -(defstruct (component (:include topological-sort-node) - (:print-function print-component)) - 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 - ;; 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-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>" - (component-type component) - (component-name component))) - -(defun describe-system (name &optional (stream *standard-output*)) - "Prints a description of the system to the stream. If NAME is the - name of a system, gets it and prints a description of the system. - If NAME is a component, prints a description of the component." - (let ((system (if (typep name 'component) name (find-system name :load)))) - (format stream "~&~A ~A: ~ - ~@[~& Host: ~A~]~ - ~@[~& Device: ~A~]~ - ~@[~& Package: ~A~]~ - ~& Source: ~@[~A~] ~@[~A~] ~@[~A~]~ - ~& Binary: ~@[~A~] ~@[~A~] ~@[~A~]~ - ~@[~& Depends On: ~A ~]~& Components: ~{~15T~A~&~}" - (component-type system) - (component-name system) - (component-host system) - (component-device system) - (component-package system) - (component-root-dir system :source) - (component-pathname system :source) - (component-extension system :source) - (component-root-dir system :binary) - (component-pathname system :binary) - (component-extension system :binary) - (component-depends-on system) - (component-components system)) - #|(when recursive - (dolist (component (component-components system)) - (describe-system component stream recursive)))|# - system)) - -(defun canonicalize-component-name (component) - ;; Within the component, the name is a string. - (if (typep (component-name component) 'string) - ;; Unnecessary to change it, so just return it, same case - (component-name component) - ;; Otherwise, make it a downcase string -- important since file - ;; names are often constructed from component names, and unix - ;; prefers lowercase as a default. - (setf (component-name component) - (string-downcase (string (component-name component)))))) - -(defun component-pathname (component type) - (when component - (ecase type - (:source (component-source-pathname component)) - (:binary (component-binary-pathname component)) - (:error (component-error-pathname component))))) -(defun component-error-pathname (component) - (let ((binary (component-pathname component :binary))) - (namestring (new-file-type binary *compile-error-file-type*)))) -(defsetf component-pathname (component type) (value) - `(when ,component - (ecase ,type - (:source (setf (component-source-pathname ,component) ,value)) - (:binary (setf (component-binary-pathname ,component) ,value))))) - -(defun component-root-dir (component type) - (when component - (ecase type - (:source (component-source-root-dir component)) - ((:binary :error) (component-binary-root-dir component)) - ))) -(defsetf component-root-dir (component type) (value) - `(when ,component - (ecase ,type - (:source (setf (component-source-root-dir ,component) ,value)) - (:binary (setf (component-binary-root-dir ,component) ,value))))) - -(defvar *source-pathnames-table* (make-hash-table :test #'equal) - "Table which maps from components to full source pathnames.") -(defvar *binary-pathnames-table* (make-hash-table :test #'equal) - "Table which maps from components to full binary pathnames.") -(defparameter *reset-full-pathname-table* t - "If T, clears the full-pathname tables before each call to - OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance - after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could - result in changes to system and language definitions to not take - effect, and so should be used with caution.") -(defun clear-full-pathname-tables () - (clrhash *source-pathnames-table*) - (clrhash *binary-pathnames-table*)) - -(defun component-full-pathname (component type &optional (version *version*)) - (when component - (case type - (:source - (let ((old (gethash component *source-pathnames-table*))) - (or old - (let ((new (component-full-pathname-i component type version))) - (setf (gethash component *source-pathnames-table*) new) - new)))) - (:binary - (let ((old (gethash component *binary-pathnames-table*))) - (or old - (let ((new (component-full-pathname-i component type version))) - (setf (gethash component *binary-pathnames-table*) new) - new)))) - (otherwise - (component-full-pathname-i component type version))))) - -(defun component-full-pathname-i (component type &optional (version *version*) - &aux version-dir version-replace) - ;; If the pathname-type is :binary and the root pathname is null, - ;; distribute the binaries among the sources (= use :source pathname). - ;; This assumes that the component's :source pathname has been set - ;; before the :binary one. - (if version - (multiple-value-setq (version-dir version-replace) - (translate-version version)) - (setq version-dir *version-dir* version-replace *version-replace*)) - (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))) - #+cmu17 - (when (logical-pathname-p (make-pathname :host (pathname-host 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 - ;; the entire root (t) or is a subdirectory. - ;; Version may be nil to signify no subdirectory, - ;; a symbol, such as alpha, beta, omega, :alpha, mark, which - ;; specifies a subdirectory of the root, or - ;; a string, which replaces the root. - (cond ((null version) - (values "" nil)) - ((symbolp version) - (values (let ((sversion (string version))) - (if (find-if #'lower-case-p sversion) - sversion - (string-downcase sversion))) - nil)) - ((stringp version) - (values version t)) - (t (error "~&; Illegal version ~S" version)))) - -(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) - `(ecase ,type - (:source (setf (component-source-extension ,component) ,value)) - (:binary (setf (component-binary-extension ,component) ,value)) - (:error (setf *compile-error-file-type* ,value)))) - -;;; ******************************** -;;; System Definition ************** -;;; ******************************** -(defun create-component (type name definition-body &optional parent (indent 0)) - (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 (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) - (setf (get-system name) component)) - - ;; Set up the component's pathname - (create-component-pathnames component parent) - - ;; If there are any components of the component, expand them too. - (expand-component-components component (+ indent 2)) - - ;; Make depends-on refer to structs instead of names. - (link-component-depends-on (component-components component)) - - ;; Design Decision: Topologically sort the dependency graph at - ;; time of definition instead of at time of use. Probably saves a - ;; little bit of time for the user. - - ;; Topological Sort the components at this level. - (setf (component-components component) - (topological-sort (component-components component))) - - ;; 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) - (when parent (component-host parent)))) - (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 :local t) ; local default - (when parent ; parent's default - (component-extension parent :source)))) - (setf (component-extension component :binary) - (or (component-extension component :binary :local t) ; local default - (when parent ; parent's 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. - (generate-component-pathname component parent :source) - (generate-component-pathname component parent :binary)) - -;; maybe file's inheriting of pathnames should be moved elsewhere? -(defun generate-component-pathname (component parent pathname-type) - ;; Pieces together a pathname for the component based on its component-type. - ;; Assumes source defined first. - ;; Null binary pathnames inherit from source instead of the component's - ;; name. This allows binaries to be distributed among the source if - ;; binary pathnames are not specified. Or if the root directory is - ;; specified for binaries, but no module directories, it inherits - ;; parallel directory structure. - (case (component-type component) - ((: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) - (when (eq pathname-type :binary) - ;; When the binary root is nil, use source. - (component-root-dir component :source))) ) - ;; Set the relative pathname to be nil - (setf (component-pathname component pathname-type) - nil));; should this be "" instead? - ;; If the name of the component-pathname is nil, it - ;; defaults to the name of the component. Use "" to - ;; avoid this defaulting. - (:private-file ; Absolute Pathname - ;; Root-dir is the directory part of the pathname - (setf (component-root-dir component pathname-type) - "" - #+ignore(or (when (component-pathname component pathname-type) - (pathname-directory - (component-pathname component pathname-type))) - (when (eq pathname-type :binary) - ;; 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) - (null (component-pathname component :binary))) - ;; When the binary-pathname is nil use source. - (component-pathname component :source)) - (or (when (component-pathname component pathname-type) -; (pathname-name ) - (component-pathname component pathname-type)) - (component-name component))))) - ((:module :subsystem) ; Pathname relative to parent. - ;; Inherit root-dir from parent - (setf (component-root-dir component pathname-type) - (component-root-dir parent pathname-type)) - ;; Tack the relative-dir onto the pathname - (setf (component-pathname component pathname-type) - (or (when (and (eq pathname-type :binary) - (null (component-pathname component :binary))) - ;; When the binary-pathname is nil use source. - (component-pathname component :source)) - (append-directories - (component-pathname parent pathname-type) - (or (component-pathname component pathname-type) - (component-name component)))))) - (:file ; Pathname relative to parent. - ;; 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 - (component-pathname parent pathname-type) - (or (component-pathname component pathname-type) - (component-name component) - (when (eq pathname-type :binary) - ;; When the binary-pathname is nil use source. - (component-pathname component :source))))))) - )) - -#| ;; old version -(defun expand-component-components (component &optional (indent 0)) - (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 - (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) - '(: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)) - ((listp definition) - ;; Otherwise, it is (we hope) a normal form definition - (create-component (car definition) ; type - (cadr definition) ; name - (cddr definition) ; definition body - parent ; parent - indent) ; indent - ))) - -(defun link-component-depends-on (components) - (dolist (component components) - (unless (and *system-dependencies-delayed* - (eq (component-type component) :defsystem)) - (setf (component-depends-on component) - (mapcar #'(lambda (dependency) - (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) :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 ***************** -;;; ******************************** -;;; All output to the user is via the tell-user functions. - -(defun split-string (string &key (item #\space) (test #'char=)) - ;; Splits the string into substrings at spaces. - (let ((len (length string)) - (index 0) result) - (dotimes (i len - (progn (unless (= index len) - (push (subseq string index) result)) - (reverse result))) - (when (funcall test (char string i) item) - (unless (= index i);; two spaces in a row - (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,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) - (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 - (component-full-pathname component type)) - (component-name component)) - (and *tell-user-when-done* - (not no-dots)))))) - -(defun tell-user-done (component &optional force no-dots) - ;; test is no longer really used, but we're leaving it in. - (when (and *tell-user-when-done* - (or *oos-verbose* force)) - (format t "~&~A~:[~;...~] Done." - (prompt-string component) (not no-dots)) - (finish-output *standard-output*))) - -(defmacro with-tell-user ((what component &optional type no-dots force) &body body) - `(progn - (tell-user ,what ,component ,type ,no-dots ,force) - ,@body - (tell-user-done ,component ,force ,no-dots))) - -(defun tell-user-no-files (component &optional force) - (when (or *oos-verbose* force) - (format-justified-string (prompt-string component) - (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*) - (component-full-pathname component :binary))))) - -(defun tell-user-require-system (name parent) - (when *oos-verbose* - (format t "~&; ~:[~;TEST:~] - System ~A requires ~S" - *oos-test* (component-name parent) name) - (finish-output *standard-output*))) - -(defun tell-user-generic (string) - (when *oos-verbose* - (format t "~&; ~:[~;TEST:~] - ~A" - *oos-test* string) - (finish-output *standard-output*))) - -;;; ******************************** -;;; 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. 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 () - (get-universal-time)) - -(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 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) - "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") (finish-output) - (y-or-n-p-wait #\y 10 "1? ") - (y-or-n-p-wait #\n 10 "2? ")) -|# -;;; ******************************** -;;; Operate on System ************** -;;; ******************************** -;;; Operate-on-system -;; Operation is :compile, 'compile, :load or 'load -;; Force is :all or :new-source or :new-source-and-dependents or a list of -;; specific modules. -;; :all (or T) forces a recompilation of every file in the system -;; :new-source-and-dependents compiles only those files whose -;; sources have changed or who depend on recompiled files. -;; :new-source compiles only those files whose sources have changed -;; A list of modules means that only those modules and their dependents are recompiled. -;; Test is T to print out what it would do without actually doing it. -;; Note: it automatically sets verbose to T if test is T. -;; Verbose is T to print out what it is doing (compiling, loading of -;; modules and files) as it does it. -;; Dribble should be the pathname of the dribble file if you want to -;; dribble the compilation. -;; Load-source-instead-of-binary is T to load .lisp instead of binary files. -;; Version may be nil to signify no subdirectory, -;; a symbol, such as alpha, beta, omega, :alpha, mark, which -;; specifies a subdirectory of the root, or -;; a string, which replaces the root. -;; -(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*) - (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)) - (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 (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 non-NIL if something changed in this component and hence had - ;; to be recompiled. This is only used as a boolean. - changed) - -(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* - (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 (module-depends-on-changed module changed) - #|(some #'(lambda (dependent) - (member dependent changed)) - (component-depends-on module))|# - (or (non-empty-listp force) - (eq force :new-source-and-dependents))) - ;; The component depends on a changed file - ;; and force agrees. - (if (eq force :new-source-and-dependents) - :new-source-all - :all)) - ((and (non-empty-listp force) - (member (component-name module) force - :test #'string-equal :key #'string)) - ;; Force is a list of modules - ;; and the component is one of them. - :all) - (t force))) - (push module changed))) - (case operation - ((compile :compile) - (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 *********** -;;; ******************************** -;;; Define :compile/compile and :load/load operations -(component-operation :compile 'compile-and-load-operation) -(component-operation 'compile 'compile-and-load-operation) -(component-operation :load 'load-file-operation) -(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))) - ;; 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 - ;; 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* - (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" - component :source :no-dots :force) - nil) - (t nil)))) - -(defun needs-compilation (component) - ;; 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. - (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* ((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* - (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* - (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* - (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. -;; ((and *oos-test* -;; (eq operation :compile) -;; (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 (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 #\y 30 - "~A- Binary file ~A does not exist. ~ - ~&~A Load source file ~A instead? " - prompt - (component-full-pathname component :binary) - prompt - (component-full-pathname component :source)))) - (setq *bother-user-if-no-binary* - (y-or-n-p-wait #\n 30 - "~A- Should I bother you if this happens again? " - prompt )) - (unless *bother-user-if-no-binary* - (setq *load-source-if-no-binary* load-source)) - load-source))))) - -;;; ******************************** -;;; Allegro Toplevel Commands ****** -;;; ******************************** -;;; 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" - - (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)) - - -;;; ******************************** -;;; Allegro Make System Fasl ******* -;;; ******************************** -#+:excl -(defun allegro-make-system-fasl (system destination - &optional (include-dependents t)) - (excl:shell - (format nil "rm -f ~A; cat~{ ~A~} > ~A" - destination - (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) (component-full-pathname comp :source)) - (remove nil - (file-components-in-component - (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. - (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)) - (file-components-in-component component force))) - -(defun file-components-in-component (component &optional (force :all) - &aux result changed) - (case (component-type component) - ((:file :private-file) - (when (setq changed - (or (find force '(:all t) :test #'eq) - (and (not (non-empty-listp force)) - (needs-compilation component)))) - (setq result - (list component)))) - ((:module :system :subsystem :defsystem) - (dolist (module (component-components component)) - (multiple-value-bind (r c) - (file-components-in-component - module - (cond ((and (some #'(lambda (dependent) - (member dependent changed)) - (component-depends-on module)) - (or (non-empty-listp force) - (eq force :new-source-and-dependents))) - ;; The component depends on a changed file and force agrees. - :all) - ((and (non-empty-listp force) - (member (component-name module) force - :test #'string-equal :key #'string)) - ;; Force is a list of modules and the component is one of them. - :all) - (t force))) - (when c - (push module changed) - (setq result (append result r))))))) - (values result changed)) - -(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* diff --git a/contrib/defsystem/defsystem.ps b/contrib/defsystem/defsystem.ps deleted file mode 100644 index a6daf15fac2a874bfd015fd51e6c60e97d78258c..0000000000000000000000000000000000000000 --- a/contrib/defsystem/defsystem.ps +++ /dev/null @@ -1,1118 +0,0 @@ -%!PS-Adobe-1.0 -%%Title: defsystem.mss -%%DocumentFonts: (atend) -%%Creator: Mark Kantrowitz and Scribe 6(1600) -%%CreationDate: 31 January 1990 12:40 -%%Pages: (atend) -%%EndComments -% PostScript Prelude for Scribe. -/BS {/SV save def 0.0 792.0 translate .01 -.01 scale} bind def -/ES {showpage SV restore} bind def -/SC {setrgbcolor} bind def -/FMTX matrix def -/RDF {WFT SLT 0.0 eq - {SSZ 0.0 0.0 SSZ neg 0.0 0.0 FMTX astore} - {SSZ 0.0 SLT neg sin SLT cos div SSZ mul SSZ neg 0.0 0.0 FMTX astore} - ifelse makefont setfont} bind def -/SLT 0.0 def -/SI { /SLT exch cvr def RDF} bind def -/WFT /Courier findfont def -/SF { /WFT exch findfont def RDF} bind def -/SSZ 1000.0 def -/SS { /SSZ exch 100.0 mul def RDF} bind def -/AF { /WFT exch findfont def /SSZ exch 100.0 mul def RDF} bind def -/MT /moveto load def -/XM {currentpoint exch pop moveto} bind def -/UL {gsave newpath moveto dup 2.0 div 0.0 exch rmoveto - setlinewidth 0.0 rlineto stroke grestore} bind def -/LH {gsave newpath moveto setlinewidth - 0.0 rlineto - gsave stroke grestore} bind def -/LV {gsave newpath moveto setlinewidth - 0.0 exch rlineto - gsave stroke grestore} bind def -/BX {gsave newpath moveto setlinewidth - exch - dup 0.0 rlineto - exch 0.0 exch neg rlineto - neg 0.0 rlineto - closepath - gsave stroke grestore} bind def -/BX1 {grestore} bind def -/BX2 {setlinewidth 1 setgray stroke grestore} bind def -/PB {/PV save def newpath translate - 100.0 -100.0 scale pop /showpage {} def} bind def -/PE {PV restore} bind def -/GB {/PV save def newpath translate rotate - div dup scale 100.0 -100.0 scale /showpage {} def} bind def -/GE {PV restore} bind def -/FB {dict dup /FontMapDict exch def begin} bind def -/FM {cvn exch cvn exch def} bind def -/FE {end /original-findfont /findfont load def /findfont - {dup FontMapDict exch known{FontMapDict exch get} if - original-findfont} def} bind def -/BC {gsave moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath clip} bind def -/EC /grestore load def -/SH /show load def -/MX {exch show 0.0 rmoveto} bind def -/W {0 32 4 -1 roll widthshow} bind def -/WX {0 32 5 -1 roll widthshow 0.0 rmoveto} bind def -%%EndProlog -%%Page: 1 1 -BS -0 SI -15 /Helvetica-Bold AF -11090 8294 MT -(Defsystem: A Portable Make Facility for Common Lisp)SH -13 SS -24641 15620 MT -(by Mark Kantrowitz)SH -21752 19236 MT -(School of Computer Science)SH -22256 22852 MT -(Carnegie Mellon University)SH -26480 26468 MT -(January 1990)SH -12 SS -7200 32344 MT -(Introduction)SH -10 /Helvetica AF -7200 35777 MT -(This document describes the defsystem system definition macro, a portable "Make" facility for) -87 W( Common)86 W -7200 37297 MT -(Lisp.)SH -7200 40793 MT -(Support is provided for organizing systems into hierarchical layers of modules, with matching directory)133 W -7200 42313 MT -(structure. Moreover, the components of the system may be listed in any order) -49 W( the user desires, because)48 W -7200 43833 MT -(the defsystem command reorganizes them according) -69 W( to the file-dependency constraints specified by the)70 W -7200 45353 MT -(user. Since it accomplishes this by performing a topological sort of the constraint-graph,) -351 W( cyclical)350 W -7200 46873 MT -(dependencies are not supported \050the graph must be a DAG\051.)SH -7200 50369 MT -(Only two operations, compile and load, are currently defined. The) -87 W( interface for defining new operations,)88 W -7200 51889 MT -(however, is simple and extendible.)SH -7200 55385 MT -(Though home-grown, the syntax was inspired by fond) -108 W( memories of the defsystem facility on Symbolics)107 W -7200 56905 MT -(3600 series lisp) -100 W( machines. The exhaustive lists of filename extensions for various lisps and the idea to)101 W -7200 58425 MT -(have one)240 W -/Helvetica-Oblique SF -12072 XM -(operate-on-system)SH -/Helvetica SF -20925 XM -(function instead of separate)239 W -/Helvetica-Oblique SF -34444 XM -(compile-system)SH -/Helvetica SF -41906 XM -(and)SH -/Helvetica-Oblique SF -44091 XM -(load-system)SH -/Helvetica SF -49998 XM -(functions)SH -7200 59945 MT -(were taken from Xerox Corporation's PCL \050Portable Common Loops\051 system.)SH -7200 63441 MT -(The code for the defsystem facility and this documentation may be found in the files)SH -11648 65030 MT -(/afs/cs.cmu.edu/user/mkant/Defsystem/defsystem.{text,lisp})SH -7200 68526 MT -(Please send bug reports, comments and suggestions to mkant@cs.cmu.edu.)SH -ES -%%Page: 2 2 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(2)SH -12 SS -7200 8075 MT -(Using the System)SH -10 /Helvetica AF -7200 11508 MT -(To use this system,)SH -9424 12909 MT -(1.)SH -10536 XM -(If you want to have a central) -55 W( directory where system definition files will be kept, modify the)56 W -10536 14052 MT -(value of *central-registry* in defsystem.lisp to be the pathname of that directory.)SH -9424 15867 MT -(2.)SH -10536 XM -(Save and load the file defsystem.lisp)SH -9424 17682 MT -(3.)SH -10536 XM -(Load the) -235 W( file containing the defsystem form defining your system. If the name of your)234 W -10536 18825 MT -(system is foo, the) -43 W( file will be named "foo.system". [If you are going to load the system and)44 W -10536 19968 MT -(not compile it, you can use \050require "foo"\051) -10 W( to load it if the definition file is in either the current)9 W -10536 21111 MT -(directory or the central registry.])SH -9424 22926 MT -(4.)SH -10536 XM -(Use the function)60 W -/Helvetica-Oblique SF -18220 XM -(operate-on-system)SH -/Helvetica SF -26894 XM -(to do things to your system.) -60 W( For example \050operate-on-)61 W -10536 24069 MT -(system "foo" 'load\051 will load the system, while \050operate-on-system "foo" 'compile\051 will)306 W -10536 25212 MT -(compile it.)SH -12 /Helvetica-Bold AF -7200 29013 MT -(External Interface)SH -10 /Helvetica AF -7200 32446 MT -(The external interface to) -226 W( the defsystem facility are the defsystem macro and the operate-on-system)227 W -7200 33966 MT -(function. Defsystem is used to define a new system and operate-on-system) -43 W( to compile it and load it. The)42 W -7200 35486 MT -(definition of require has been modified to mesh well with systems) -104 W( defined using defsystem, and is fully)105 W -7200 37006 MT -(backward-compatible.)SH -7200 40502 MT -(In addition, the function) -107 W( afs-binary-directory has been provided for immitating the behavior of the @sys)106 W -7200 42022 MT -(feature of the Andrew File System on systems not) -123 W( running AFS. The @sys feature allows soft links to)124 W -7200 43542 MT -(point to different directories depending on) -86 W( which platform is accessing the files. A common setup would)85 W -7200 45062 MT -(be to have the bin directory soft linked to .bin/@sys and to have subdirectories of .bin corresponding) -84 W( to)85 W -7200 46582 MT -(each platform \050.bin/vax_mach, .bin/unix, .bin/pmax_mach, etc.\051. The afs-binary-directory) -81 W( function returns)80 W -7200 48102 MT -(the appropriate binary directory for use as the :binary-pathname) -99 W( argument in the defsystem macro. For)100 W -7200 49622 MT -(example, if we evaluate \050afs-binary-directory) -220 W( "foodir/"\051 on a vax running the Mach operating system,)219 W -7200 51142 MT -("foodir/.bin/vax_mach/" would be returned.)SH -12 /Helvetica-Bold AF -7200 54485 MT -(Defining Systems with Defsystem)SH -10 /Helvetica AF -7200 57918 MT -(A system is a set of components with associated properties. These properties include the type,) -126 W( name,)127 W -7200 59438 MT -(source and binary pathnames,) -523 W( package, component-dependencies, initializations, and a set of)522 W -7200 60958 MT -(components.)SH -7200 64454 MT -(Components may be of three types: :system, :module, or) -259 W( :file. Components of type :system have)260 W -7200 65974 MT -(absolute pathnames and are used to define a multi-system system. The) -93 W( toplevel system defined by the)92 W -7200 67494 MT -(defsystem macro) -174 W( is implicitly of type :system. Components of type :module have pathnames that are)175 W -7200 69014 MT -(relative to their containing system or module,) -89 W( and may contain a set of files and modules. This enables)88 W -7200 70534 MT -(one to define subsystems, subsubsystems, submodules, and so on.)SH -ES -%%Page: 3 3 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(3)SH -/Helvetica SF -7200 7929 MT -(Foreign systems \050systems defined using some other system definition tool\051, may be) -16 W( included by providing)17 W -7200 9449 MT -(separate compile and load forms for them \050using) -189 W( the :compile-form and :load-form keywords\051. These)188 W -7200 10969 MT -(forms will be run if and only if they are included in) -33 W( a module with no components. [In some future version)34 W -7200 12489 MT -(of the defsystem) -120 W( facility there will be new component types corresponding to each possible operation.])119 W -7200 14009 MT -(This is useful if it isn't possible to convert these systems to the defsystem format all at once.)SH -7200 17505 MT -(The name of a component may be a symbol or a string. For ease of access the definition) -29 W( of a system \050its)30 W -7200 19025 MT -(component\051 is stored under the system properties of the symbol corresponding to its uppercase name.) -28 W( If)332 W -7200 20545 MT -(the system name is a symbol, for all other purposes the name is converted to) -34 W( a lowercase string \050system)35 W -7200 22065 MT -(names that are strings are left alone\051. It is usually best to) -20 W( use the string version of a system's name when)19 W -7200 23585 MT -(defining or referring to it. A system defined as 'foo will) -16 W( have an internal name of "foo" and will be stored in)17 W -7200 25105 MT -(the file "foo.system". A system defined as "Foo" will have an internal name of "Foo" and) -52 W( will be stored in)51 W -7200 26625 MT -(the file "Foo.system".)SH -7200 30121 MT -(The absolute \050for components of type :system\051 and relative) -70 W( \050for all other components\051 pathnames of the)71 W -7200 31641 MT -(binary and source files may be specified using the :source-pathname and :binary-pathname keywords in)60 W -7200 33161 MT -(the component definition. The pathnames associated with a module correspond to subdirectories of the)94 W -7200 34681 MT -(containing module or system. If) -86 W( no binary pathname is specified, the binaries are distributed among the)85 W -7200 36201 MT -(sources. If no source pathname is given for a component, it defaults to the name of the) -9 W( component. Since)10 W -7200 37721 MT -(the names are converted to lowercase, pathnames must be provided for each component if) -26 W( the operating)25 W -7200 39241 MT -(system is) -244 W( case sensitive \050unless the pathnames are all lowercase\051. Similarly, if a module does not)245 W -7200 40761 MT -(correspond to a subdirectory, a null-string pathname \050""\051 must be provided.)SH -7200 44257 MT -(File types \050e.g., "lisp" and "fasl"\051 for source and binary files may be specified using the) -40 W( :source-extension)39 W -7200 45777 MT -(and :binary-extension keywords. If) -27 W( these are not specified or given as nil, the makes a reasonable choice)28 W -7200 47297 MT -(of defaults based on the machine type and underlying operating system. These) -28 W( file types are inherited by)27 W -7200 48817 MT -(the components of the system.)SH -7200 52313 MT -(At system definition time, every relative directory is replaced with the corresponding cumulative) -103 W( relative)104 W -7200 53833 MT -(pathname with all the components incorporated.)SH -7200 57329 MT -(One may also specify the package) -219 W( to be used and any initializations and finalizations. Initializations)218 W -7200 58849 MT -(\050specified with the keyword :initially-do\051 are) -210 W( evaluated before the system is loaded or compiled, and)211 W -7200 60369 MT -(finalizations \050specified with the keyword :finally-do\051 are evaluated after) -92 W( the system is finished loading or)91 W -7200 61889 MT -(compiling. The argument to the keyword is a form which is evaluated. Multiple forms may be evaluated) -10 W( by)11 W -7200 63409 MT -(wrapping a progn around the forms.)SH -7200 66905 MT -(The components of a system, module or file are specified with the :components keyword, and are) -14 W( defined)13 W -7200 68425 MT -(in a manner analogous to the way in which a system is defined.)SH -7200 71921 MT -(The dependencies of a system, module or file are specified with the :depends-on keyword,) -45 W( followed by a)46 W -ES -%%Page: 4 4 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(4)SH -/Helvetica SF -7200 7929 MT -(list of the names of the components the system, module) -56 W( or file depends on. The components referred to)55 W -7200 9449 MT -(must exist at the same level of the hierarchy as the referring component. This enforces the modularity of)31 W -7200 10969 MT -(the defined system. If module A depends on a file) -25 W( contained within module B, then module A depends on)24 W -7200 12489 MT -(module B) -175 W( and should be specified as such. Any other use would make a mockery of the concept of)176 W -7200 14009 MT -(modularity. This requirement is not enforced in the software, but) -216 W( any use contrary to it will produce)215 W -7200 15529 MT -(unpredictable results.)SH -7200 19025 MT -(Thus the only requirement in how the files are organized is that at the) -8 W( level of each module or system, the)9 W -7200 20545 MT -(dependency graph) -312 W( of the components must be a DAG \050directed)311 W -/Helvetica-Bold SF -38659 XM -(acyclic)SH -/Helvetica SF -42584 XM -(graph\051. If there are any)311 W -7200 22065 MT -(dependency cycles \050i.e., module A uses definitions from module) -96 W( B, and module B uses definitions from)97 W -7200 23585 MT -(module A\051, the defsystem macro will not be) -48 W( able to compute a total ordering of the files \050a linear order in)47 W -7200 25105 MT -(which they should be compiled and loaded\051. Usually the defsystem will detect such cycles and halt) -80 W( with)81 W -7200 26625 MT -(an error.)SH -7200 30121 MT -(If no dependencies are provided for the system, modules and files, it may load them in) -229 W( any order.)228 W -7200 31641 MT -(Currently, however, it loads them in serial order. In a future version of defsystem this will) -233 W( probably)234 W -7200 33161 MT -(become a supported feature. [In other words, this) -56 W( feature hasn't been tested to make sure that they files)55 W -7200 34681 MT -(are not) -2 W( accidentally loaded in the opposite order in some cases. It all depends on whether the definition of)3 W -7200 36201 MT -(topological-sort used is a stable sort or not.])SH -7200 39697 MT -(The basic algorithm used is to topologically sort the DAG at each level) -195 W( of abstraction \050system level,)194 W -7200 41217 MT -(module level, submodule) -45 W( level, etc.\051 to insure that the system's files are compiled and loaded in the right)46 W -7200 42737 MT -(order. This occurs at system) -86 W( definition time, rather than at system use time, since it probably saves the)85 W -7200 44257 MT -(user some time.)SH -12 /Helvetica-Bold AF -7200 47600 MT -(BNF for Components)SH -10 /Helvetica AF -7200 51033 MT -(The general format of a component's definition is:)SH -/Courier-Bold SF -7200 52838 MT -(<definition> ::= \050<type> <name> [:host <host>] [:device <device>])SH -26400 53969 MT -([:source-pathname <pathname>])SH -26400 55100 MT -([:source-extension <extension>])SH -26400 56231 MT -([:binary-pathname <pathname>])SH -26400 57362 MT -([:binary-extension <extension>])SH -26400 58493 MT -([:package <package>])SH -26400 59624 MT -([:initially-do <form>])SH -26400 60755 MT -([:finally-do <form>])SH -26400 61886 MT -([:components \050<definition>*\051])SH -26400 63017 MT -([:depends-on \050<name>*\051])SH -26400 64148 MT -([:compile-form <form>])SH -26400 65279 MT -([:load-form <form>]\051)SH -7200 66410 MT -(<type> ::= :system | :module | :file)SH -/Helvetica SF -7200 69906 MT -(The toplevel defsystem form substitutes defsystem for :system.)SH -ES -%%Page: 5 5 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(5)SH -12 SS -7200 8075 MT -(Using Systems with Operate-on-System)SH -10 /Helvetica AF -7200 11508 MT -(The function operate-on-system is used) -166 W( to compile or load a system, or do any other operation on a)167 W -7200 13028 MT -(system. At present only compile and load operations are defined, but other operations such as edit,)200 W -7200 14548 MT -(hardcopy, or applying arbitrary functions \050e.g., enscript, lpr\051 to every file in the system) -125 W( could be added)126 W -7200 16068 MT -(easily.)SH -7200 19564 MT -(The syntax of operate-on-system is as follows:)SH -/Helvetica-Bold SF -7200 23060 MT -(OPERATE-ON-SYSTEM)SH -/Helvetica-Oblique SF -18640 XM -(system-name operation)50 W -/Helvetica SF -29466 XM -(&key)SH -/Helvetica-Oblique SF -32017 XM -(force test) -50 W( verbose dribble load-source-instead-of-)49 W -7200 24580 MT -(binary load-source-if-no-binary bother-user-if-no-binary)SH -/Symbol SF -9242 26052 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(system-name)SH -/Helvetica SF -16649 XM -(is the name of the system and may be a symbol or string.)SH -/Symbol SF -9242 27867 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(operation)SH -/Helvetica SF -14940 XM -(is 'compile \050or :compile\051 or 'load \050or :load\051 or any new operation) -126 W( defined by the)127 W -9980 29010 MT -(user.)SH -/Symbol SF -9242 30825 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(force)SH -/Helvetica SF -12703 XM -(determines what files are operated on:)SH -7 /Symbol AF -12160 32076 MT -(\267)SH -10 /Helvetica-Oblique AF -12760 32226 MT -(:all)SH -/Helvetica SF -14316 XM -(\050or T\051 specifies that all files in the system should be used)SH -7 /Symbol AF -12160 33891 MT -(\267)SH -10 /Helvetica-Oblique AF -12760 34041 MT -(:new-source)SH -/Helvetica SF -18573 XM -(If the operation is 'compile, compiles only those files whose sources are)88 W -12760 35184 MT -(more recent than the binaries. If the operation is) -114 W( 'load, loads the source if it is more)115 W -12760 36327 MT -(recent than the binaries. This allows you to load the most up) -139 W( to date version of the)138 W -12760 37470 MT -(system even if it isn't compiled.)SH -7 /Symbol AF -12160 39135 MT -(\267)SH -10 /Helvetica-Oblique AF -12760 39285 MT -(:new-sources-and-dependents)SH -/Helvetica SF -26688 XM -(uses all files used by :new-source,) -144 W( plus any files that)145 W -12760 40428 MT -(depend on the those files or their dependents \050recursively\051.)SH -7 /Symbol AF -12160 42093 MT -(\267)SH -10 /Helvetica AF -12760 42243 MT -(Force may also be a list) -289 W( of the specific modules or files to be used \050plus their)288 W -12760 43386 MT -(dependents\051.)SH -9980 44787 MT -(The default for 'load is :all and for 'compile is :new-source-and-dependents.)SH -/Symbol SF -9242 46602 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(version)SH -/Helvetica SF -13989 XM -(indicates which version of the system should be used. If nil, then the usual root)174 W -9980 47745 MT -(directory is) -101 W( used. If a symbol, such as 'alpha, 'beta, 'omega, :alpha, or 'mark, it substitutes)100 W -9980 48888 MT -(the appropriate) -19 W( \050lowercase\051 subdirectory of the root directory for the root directory. If a string,)20 W -9980 50031 MT -(it replaces the entire root directory with the given directory. \050default *version*, which is nil\051)SH -/Symbol SF -9242 51846 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(verbose)SH -/Helvetica SF -14146 XM -(is T to print out what it is doing) -53 W( \050compiling, loading of modules and files\051 as it does)52 W -9980 52989 MT -(it. \050default nil\051)SH -/Symbol SF -9242 54804 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(test)SH -/Helvetica SF -12051 XM -(is T) -15 W( to print out what it would do without actually doing it. If test is T it automatically sets)16 W -9980 55947 MT -(verbose to T. \050default nil\051)SH -/Symbol SF -9242 57762 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(dribble)SH -/Helvetica SF -13873 XM -(should be the pathname of a dribble file if you want to keep a record of) -281 W( the)280 W -9980 58905 MT -(compilation. \050default nil\051)SH -/Symbol SF -9242 60720 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(load-source-instead-of-binary)SH -/Helvetica SF -24392 XM -(is T to force) -21 W( the system to load source files instead of binary)22 W -9980 61863 MT -(files. \050default nil\051)SH -/Symbol SF -9242 63678 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(load-source-if-no-binary)SH -/Helvetica SF -22022 XM -(is T to have the) -263 W( system load source files if the binary file is)262 W -9980 64821 MT -(missing. \050default nil\051)SH -/Symbol SF -9242 66636 MT -(\267)SH -/Helvetica-Bold SF -9980 XM -(bother-user-if-no-binary)SH -/Helvetica SF -21818 XM -(is T to) -171 W( have the system bother the user about missing binaries)172 W -9980 67779 MT -(before it goes ahead and loads them if load-source-if-no-binary is T. \050default) -67 W( t\051 Times out in)66 W -9980 68922 MT -(60 seconds unless *use-timeouts* is set to nil.)SH -ES -%%Page: 6 6 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(6)SH -/Helvetica SF -7200 7929 MT -(An implicit assumption is that if we need to) -10 W( load a file for some reason, then we should be able to compile)11 W -7200 9449 MT -(it immediately before we need to) -138 W( load it. This obviates the need to specify separate load and compile)137 W -7200 10969 MT -(dependencies in the modules.)SH -7200 14465 MT -(Files which must not) -117 W( be compiled should be loaded in the initializations or finalizations of a module by)118 W -7200 15985 MT -(means of an explicit load form.)SH -7200 19481 MT -(Note that under this assumption, the example given) -207 W( in the PCL defsystem becomes quite ludicrous.)206 W -7200 21001 MT -(Those constraints are of the form:)SH -9424 22402 MT -(1.)SH -10536 XM -(C must be loaded before A&B are loaded)SH -9424 24217 MT -(2.)SH -10536 XM -(A&B must be loaded before C is compiled)SH -7200 25737 MT -(When you add in the reasonable assumption that before you load C, you must compile C, you get a cycle.)SH -7200 29233 MT -(The only case is which this might not be true is in a system which worked on) -86 W( the dependency graph of)87 W -7200 30753 MT -(individual definitions. But we have restricted) -112 W( ourselves to file dependencies and will stick with that. \050In)111 W -7200 32273 MT -(situations where a file defining macros must have the sources loaded before compiling them, most often) -7 W( it)8 W -7200 33793 MT -(is because the macros are used before they are defined, and) -82 W( hence assumed to be functions. This can)81 W -7200 35313 MT -(be fixed by organizing the macros better, or including them in a separate file.\051)SH -12 /Helvetica-Bold AF -7200 38656 MT -(Defining New Operations)SH -10 /Helvetica AF -7200 42089 MT -(To define a new) -203 W( operation, write a function with parameters component and force that performs the)204 W -7200 43609 MT -(operation. The) -82 W( function component-pathname may be used to extract the source and binary pathnames)81 W -7200 45129 MT -(from the component. [Component-pathname takes parameters component and file-type,) -10 W( where file-type is)11 W -7200 46649 MT -(either :source or :binary,) -120 W( and returns the appropriate pathname.] If the component has "changed" as a)119 W -7200 48169 MT -(result of the operation, T should) -3 W( be returned; otherwise nil. See the definition of compile-file-operation and)4 W -7200 49689 MT -(load-file-operation for examples.)SH -7200 53185 MT -(Then install the definition using component-operation, which takes as) -99 W( parameters the symbol which will)98 W -7200 54705 MT -(be used) -58 W( to name the operation in operate-on-system, and the name of the function. For example, here's)59 W -7200 56225 MT -(the definition of the 'compile and :compile operations:)SH -/Courier-Bold SF -13200 58030 MT -(\050component-operation :compile 'compile-and-load-operation\051)SH -13200 59161 MT -(\050component-operation 'compile 'compile-and-load-operation\051)SH -/Helvetica SF -7200 61021 MT -(Eventually this system will include portable definitions of 'hardcopy and 'edit.)SH -12 /Helvetica-Bold AF -7200 64364 MT -(Changes to Require)SH -10 /Helvetica AF -7200 67797 MT -(This defsystem interacts smoothly) -138 W( with the require and provide facilities of Common Lisp. Operate-on-)137 W -7200 69317 MT -(system automatically provides the name of any system it loads, and uses the new definition of) -49 W( require to)50 W -7200 70837 MT -(load any dependencies of the toplevel system.)SH -ES -%%Page: 7 7 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(7)SH -/Helvetica SF -7200 7929 MT -(To facilitate this, three new optional arguments have been added) -174 W( to require. Thus the new syntax of)173 W -7200 9449 MT -(require is as follows:)SH -/Helvetica-Bold SF -7200 12945 MT -(REQUIRE)SH -/Helvetica-Oblique SF -12034 XM -(system-name)SH -/Helvetica SF -18313 XM -(&optional)SH -/Helvetica-Oblique SF -22760 XM -(pathname definition-pname default-action version)SH -/Helvetica SF -7200 16441 MT -(If pathname is provided, the new require behaves just like the old) -46 W( definition. Otherwise it first tries to find)47 W -7200 17961 MT -(the definition of the system-name \050if it is not already defined it will load the definition file if it is in the)143 W -7200 19481 MT -(current-directory, the central-registry directory, or the directory specified by definition-pname\051 and) -147 W( runs)148 W -7200 21001 MT -(operate-on-system on the system definition. If no definition is to be found, it) -160 W( will evaluate the default-)159 W -7200 22521 MT -(action if there) -52 W( is one. Otherwise it will try running the old definition of require on just the system name. If)53 W -7200 24041 MT -(all else fails, it will print out a warning.)SH -12 /Helvetica-Bold AF -7200 27384 MT -(A Sample System Definition and Its Use)SH -10 /Helvetica AF -7200 30817 MT -(Here's a system definition for the files in the following directory structure:)SH -/Courier-Bold SF -8400 32622 MT -(% du -a test)SH -8400 33753 MT -(1 test/fancy/macros.lisp)3600 W -8400 34884 MT -(1 test/fancy/primitives.lisp)3600 W -8400 36015 MT -(3 test/fancy)3600 W -8400 37146 MT -(1 test/macros.lisp)3600 W -8400 38277 MT -(1 test/primitives.lisp)3600 W -8400 39408 MT -(1 test/graphics/macros.lisp)3600 W -8400 40539 MT -(1 test/graphics/primitives.lisp)3600 W -8400 41670 MT -(3 test/graphics)3600 W -8400 42801 MT -(1 test/os/macros.lisp)3600 W -8400 43932 MT -(1 test/os/primitives.lisp)3600 W -8400 45063 MT -(3 test/os)3600 W -8400 46194 MT -(12 test)3000 W -8400 49587 MT -(\050defsystem test)SH -9600 50718 MT -(:source-pathname "/afs/cs.cmu.edu/user/mkant/Defsystem/test/")SH -9600 51849 MT -(:source-extension "lisp")SH -9600 52980 MT -(:binary-pathname nil)SH -9600 54111 MT -(:binary-extension nil)SH -9600 55242 MT -(:components \050\050:module basic)SH -22800 56373 MT -(:source-pathname "")SH -22800 57504 MT -(:components \050\050:file "primitives"\051)SH -30600 58635 MT -(\050:file "macros")SH -34800 59766 MT -(:depends-on \050"primitives"\051\051\051\051)SH -17400 60897 MT -(\050:module graphics)SH -22800 62028 MT -(:source-pathname "graphics")SH -22800 63159 MT -(:components \050\050:file "macros")SH -34800 64290 MT -(:depends-on \050"primitives"\051\051)SH -30600 65421 MT -(\050:file "primitives"\051\051)SH -22800 66552 MT -(:depends-on \050basic\051\051)SH -17400 67683 MT -(\050:module fancy-stuff)SH -22800 68814 MT -(:source-pathname "fancy")SH -22800 69945 MT -(:components \050\050:file "macros")SH -34800 71076 MT -(:depends-on \050"primitives"\051\051)SH -ES -%%Page: 8 8 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(8)SH -/Courier-Bold SF -30600 7874 MT -(\050:file "primitives"\051\051)SH -22800 9005 MT -(:depends-on \050graphics operating-system\051\051)SH -17400 10136 MT -(\050:module operating-system)SH -22800 11267 MT -(:source-pathname "os")SH -22800 12398 MT -(:components \050\050:file "primitives"\051)SH -30600 13529 MT -(\050:file "macros")SH -34800 14660 MT -(:depends-on \050"primitives"\051\051\051)SH -22800 15791 MT -(:depends-on \050basic\051\051\051)SH -9600 16922 MT -(:depends-on nil\051)SH -8400 19184 MT -(<cl> \050operate-on-system 'test 'compile :verbose t\051)SH -8400 21446 MT -(; -) -600 W( Compiling system "test")SH -8400 22577 MT -(; -) -1800 W( Compiling module "basic")SH -8400 23708 MT -(; -) -3000 W( Compiling source file)SH -8400 24839 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.lisp")4200 W -8400 25970 MT -(; -) -3000 W( Loading binary file)SH -8400 27101 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W -8400 28232 MT -(; -) -3000 W( Compiling source file)SH -8400 29363 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.lisp")4200 W -8400 30494 MT -(; -) -3000 W( Loading binary file)SH -8400 31625 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W -8400 32756 MT -(; -) -1800 W( Compiling module "graphics")SH -8400 33887 MT -(; -) -3000 W( Compiling source file)SH -8400 35018 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.lisp)4200 W -8400 36149 MT -(; -) -3000 W( Loading binary file)SH -8400 37280 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W -8400 38411 MT -(; -) -3000 W( Compiling source file)SH -8400 39542 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.lisp")4200 W -8400 40673 MT -(; -) -3000 W( Loading binary file)SH -8400 41804 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W -8400 42935 MT -(; -) -1800 W( Compiling module "operating-system")SH -8400 44066 MT -(; -) -3000 W( Compiling source file)SH -8400 45197 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.lisp")4200 W -8400 46328 MT -(; -) -3000 W( Loading binary file)SH -8400 47459 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W -8400 48590 MT -(; -) -3000 W( Compiling source file)SH -8400 49721 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.lisp")4200 W -8400 50852 MT -(; -) -3000 W( Loading binary file)SH -8400 51983 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W -8400 53114 MT -(; -) -1800 W( Compiling module "fancy-stuff")SH -8400 54245 MT -(; -) -3000 W( Compiling source file)SH -8400 55376 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.lisp")4200 W -8400 56507 MT -(; -) -3000 W( Loading binary file)SH -8400 57638 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W -8400 58769 MT -(; -) -3000 W( Compiling source file)SH -8400 59900 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.lisp")4200 W -8400 61031 MT -(; -) -3000 W( Loading binary file)SH -8400 62162 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W -8400 63293 MT -(; -) -600 W( Providing system test)SH -8400 64424 MT -(NIL)SH -8400 66686 MT -(<cl> \050operate-on-system 'test 'load :verbose t\051)SH -8400 68948 MT -(; -) -600 W( Loading system "test")SH -8400 70079 MT -(; -) -1800 W( Loading module "basic")SH -8400 71210 MT -(; -) -3000 W( Loading binary file)SH -ES -%%Page: 9 9 -BS -0 SI -10 /Helvetica-Bold AF -30322 4329 MT -(9)SH -/Courier-Bold SF -8400 7874 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W -8400 9005 MT -(; -) -3000 W( Loading binary file)SH -8400 10136 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W -8400 11267 MT -(; -) -1800 W( Loading module "graphics")SH -8400 12398 MT -(; -) -3000 W( Loading binary file)SH -8400 13529 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W -8400 14660 MT -(; -) -3000 W( Loading binary file)SH -8400 15791 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W -8400 16922 MT -(; -) -1800 W( Loading module "operating-system")SH -8400 18053 MT -(; -) -3000 W( Loading binary file)SH -8400 19184 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W -8400 20315 MT -(; -) -3000 W( Loading binary file)SH -8400 21446 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W -8400 22577 MT -(; -) -1800 W( Loading module "fancy-stuff")SH -8400 23708 MT -(; -) -3000 W( Loading binary file)SH -8400 24839 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W -8400 25970 MT -(; -) -3000 W( Loading binary file)SH -8400 27101 MT -(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W -8400 28232 MT -(; -) -600 W( Providing system test)SH -8400 29363 MT -(NIL)SH -12 /Helvetica-Bold AF -7200 33623 MT -(Miscellaneous Notes)SH -10 /Helvetica AF -7200 37056 MT -(Macintosh pathnames are) -27 W( not fully supported at this time because of irregularities in the Allegro Common)26 W -7200 38576 MT -(Lisp definition of the pathname functions. Thus) -92 W( system definitions will not be portable to the Macintosh.)93 W -7200 40096 MT -(To convert them, include the device in the toplevel pathname and include trailing colons in) -7 W( the pathnames)6 W -7200 41616 MT -(of each module.)SH -7200 45112 MT -(We currently assume that) -205 W( compilation-load dependencies and if-changed dependencies are identical.)206 W -7200 46632 MT -(However, in some cases this might not be true. For example, if we change) -21 W( a macro we have to recompile)20 W -7200 48152 MT -(functions that depend on it, but not if we change) -239 W( a function. Splitting these apart \050with appropriate)240 W -7200 49672 MT -(defaulting\051 would be nice, but not worth doing immediately since it may save only a) -252 W( couple of file)251 W -7200 51192 MT -(recompilations, while making the defsystem much) -222 W( more complex. And if someone has such a large)223 W -7200 52712 MT -(system that this matters, they've got more important problems.)SH -ES -%%Trailer -%%Pages: 9 -%%DocumentFonts: Helvetica Helvetica-Bold Helvetica-Oblique Courier-Bold Symbol