CMUCL commit: src/contrib/defsystem (defsystem.lisp)

Raymond Toy rtoy at common-lisp.net
Mon May 10 21:04:00 CEST 2010


    Date: Monday, May 10, 2010 @ 15:04:00
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/contrib/defsystem

Modified: defsystem.lisp

Restore old defsystem.lisp.


----------------+
 defsystem.lisp | 3964 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 3964 insertions(+)


Index: src/contrib/defsystem/defsystem.lisp
diff -u /dev/null src/contrib/defsystem/defsystem.lisp:1.8
--- /dev/null	Mon May 10 15:04:00 2010
+++ src/contrib/defsystem/defsystem.lisp	Mon May 10 15:04:00 2010
@@ -0,0 +1,3964 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp -*-
+;;; Mon Mar 13 20:33:57 1995 by Mark Kantrowitz <mkant at 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 at 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 at dfki.uni-sb.de>
+;;; as   = Andreas Stolcke <stolcke at ICSI.Berkeley.EDU>
+;;; bha  = Brian Anderson <bha at atc.boeing.com>
+;;; brad = Brad Miller <miller at cs.rochester.edu>
+;;; bw   = Robert Wilhelm <wilhelm at rpal.rockwell.com>
+;;; djc  = Daniel J. Clancy <clancy at cs.utexas.edu>
+;;; fdmm = Fernando D. Mato Mira <matomira at di.epfl.ch>
+;;; gc   = Guillaume Cartier <cartier at math.uqam.ca>
+;;; gi   = Gabriel Inaebnit <inaebnit at research.abb.ch>
+;;; gpw  = George Williams <george at hsvaic.boeing.com>
+;;; hkt  = Rick Taube <hkt at cm-next-8.stanford.edu>
+;;; ik   = Ik Su Yoo <ik at ctt.bellcore.com>
+;;; jk   = John_Kolojejchick at MORK.CIMDS.RI.CMU.EDU
+;;; kt   = Kevin Thompson <kthompso at ptolemy.arc.nasa.gov>
+;;; kc   = Kaelin Colclasure <kaelin at bridge.com>
+;;; lmh  = Liam M. Healy <Liam.Healy at nrl.navy.mil>
+;;; mc   = Matthew Cornell <cornell at unix1.cs.umass.edu>
+;;; oc   = Oliver Christ <oli at adler.ims.uni-stuttgart.de>
+;;; rs   = Ralph P. Sobek <ralph at vega.laas.fr>
+;;; rs2  = Richard Segal <segal at cs.washington.edu>
+;;; sb   = Sean Boisen <sboisen at bbn.com>
+;;; ss   = Steve Strassman <straz at cambridge.apple.com>
+;;; tar  = Thomas A. Russ <tar at isi.edu>
+;;; toni = Anton Beschta <toni%l4 at ztivax.siemens.com>
+;;; yc   = Yang Chen <yangchen%iris.usc.edu at usc.edu>
+;;;
+;;; Thanks to Steve Strassmann <straz at media-lab.media.mit.edu> and
+;;; Sean Boisen <sboisen at BBN.COM> for detailed bug reports and 
+;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit
+;;; <inaebnit at 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 at 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 at 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 at 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)
+     , at 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*



More information about the cmucl-commit mailing list