[projects/cmucl/cmucl.git] / src / contrib / defsystem / defsystem.lisp

;;; -*- Mode: Lisp; Package: make -*-
;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-

;;; DEFSYSTEM 3.6 Interim.

;;; defsystem.lisp --

;;; ****************************************************************
;;; MAKE -- A Portable Defsystem Implementation ********************
;;; ****************************************************************

;;; This is a portable system definition facility for Common Lisp.
;;; Though home-grown, the syntax was inspired by fond memories of the
;;; defsystem facility on Symbolics 3600's. The exhaustive lists of
;;; filename extensions for various lisps and the idea to have one
;;; "operate-on-system" function instead of separate "compile-system"
;;; and "load-system" functions were taken from Xerox Corp.'s PCL
;;; system.

;;; This system improves on both PCL and Symbolics defsystem utilities
;;; by performing a topological sort of the graph of file-dependency
;;; constraints. Thus, the components of the system need not be listed
;;; in any special order, because the defsystem command reorganizes them
;;; based on their constraints. It includes all the standard bells and
;;; whistles, such as not recompiling a binary file that is up to date
;;; (unless the user specifies that all files should be recompiled).

;;; Originally written by Mark Kantrowitz, School of Computer Science,
;;; Carnegie Mellon University, October 1989.

;;; MK:DEFSYSTEM 3.6 Interim
;;;
;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
;;;               1999 - 2005 Mark Kantrowitz and Marco Antoniotti. All
;;;                           rights reserved.

;;; Use, copying, modification, merging, publishing, distribution
;;; and/or sale of this software, source and/or binary files and
;;; associated documentation files (the "Software") and of derivative
;;; works based upon this Software are permitted, as long as the
;;; following conditions are met:

;;;    o this copyright notice is included intact and is prominently
;;;      visible in the Software
;;;    o if modifications have been made to the source code of the
;;;      this package that have not been adopted for inclusion in the
;;;      official version of the Software as maintained by the Copyright
;;;      holders, then the modified package MUST CLEARLY identify that
;;;      such package is a non-standard and non-official version of
;;;      the Software.  Furthermore, it is strongly encouraged that any
;;;      modifications made to the Software be sent via e-mail to the
;;;      MK-DEFSYSTEM maintainers for consideration of inclusion in the
;;;      official MK-DEFSYSTEM package.

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT.
;;; IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY
;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;;; Except as contained in this notice, the names of M. Kantrowitz and
;;; M. Antoniotti shall not be used in advertising or otherwise to promote
;;; the sale, use or other dealings in this Software without prior written
;;; authorization from M. Kantrowitz and M. Antoniotti.


;;; Please send bug reports, comments and suggestions to <marcoxa@cons.org>.
\f
;;; ********************************
;;; Change Log *********************
;;; ********************************
;;;
;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in
;;; September and October 1990, but not documented until January 1991.
;;;
;;; akd  = Abdel Kader Diagne <diagne@dfki.uni-sb.de>
;;; as   = Andreas Stolcke <stolcke@ICSI.Berkeley.EDU>
;;; bha  = Brian Anderson <bha@atc.boeing.com>
;;; brad = Brad Miller <miller@cs.rochester.edu>
;;; bw   = Robert Wilhelm <wilhelm@rpal.rockwell.com>
;;; djc  = Daniel J. Clancy <clancy@cs.utexas.edu>
;;; fdmm = Fernando D. Mato Mira <matomira@di.epfl.ch>
;;; gc   = Guillaume Cartier <cartier@math.uqam.ca>
;;; gi   = Gabriel Inaebnit <inaebnit@research.abb.ch>
;;; gpw  = George Williams <george@hsvaic.boeing.com>
;;; hkt  = Rick Taube <hkt@cm-next-8.stanford.edu>
;;; ik   = Ik Su Yoo <ik@ctt.bellcore.com>
;;; jk   = John_Kolojejchick@MORK.CIMDS.RI.CMU.EDU
;;; kt   = Kevin Thompson <kthompso@ptolemy.arc.nasa.gov>
;;; kc   = Kaelin Colclasure <kaelin@bridge.com>
;;; kmr  = Kevin M. Rosenberg <kevin@rosenberg.net>
;;; lmh  = Liam M. Healy <Liam.Healy@nrl.navy.mil>
;;; mc   = Matthew Cornell <cornell@unix1.cs.umass.edu>
;;; oc   = Oliver Christ <oli@adler.ims.uni-stuttgart.de>
;;; rs   = Ralph P. Sobek <ralph@vega.laas.fr>
;;; rs2  = Richard Segal <segal@cs.washington.edu>
;;; sb   = Sean Boisen <sboisen@bbn.com>
;;; ss   = Steve Strassman <straz@cambridge.apple.com>
;;; tar  = Thomas A. Russ <tar@isi.edu>
;;; toni = Anton Beschta <toni%l4@ztivax.siemens.com>
;;; yc   = Yang Chen <yangchen%iris.usc.edu@usc.edu>
;;;
;;; Thanks to Steve Strassmann <straz@media-lab.media.mit.edu> and
;;; Sean Boisen <sboisen@BBN.COM> for detailed bug reports and
;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit
;;; <inaebnit@research.abb.ch> for help with VAXLisp bugs.
;;;
;;; 05-NOV-90  hkt  Changed canonicalize-system-name to make system
;;;                 names package independent. Interns them in the
;;;                 keyword package. Thus either strings or symbols may
;;;                 be used to name systems from the user's point of view.
;;; 05-NOV-90  hkt  Added definition FIND-SYSTEM to allow OOS to
;;;                 work on systems whose definition hasn't been loaded yet.
;;; 05-NOV-90  hkt  Added definitions COMPILE-SYSTEM and LOAD-SYSTEM
;;;                 as alternates to OOS for naive users.
;;; 05-NOV-90  hkt  Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT]
;;;                 into USER package instead of import.
;;; 15-NOV-90  mk   Changed package name to "MAKE", eliminating "DEFSYSTEM"
;;;                 to avoid conflicts with allegro, symbolics packages
;;;                 named "DEFSYSTEM".
;;; 30-JAN-91  mk   Modified append-directories to work with the
;;;                 logical-pathnames system.
;;; 30-JAN-91  mk   Append-directories now works with Sun CL4.0. Also, fixed
;;;                 bug wrt Lucid 4.0's pathnames (which changed from lcl3.0
;;;                 -- 4.0 uses a list for the directory slot, whereas
;;;                 3.0 required a string). Possible fix to symbolics bug.
;;; 30-JAN-91  mk   Defined NEW-REQUIRE to make redefinition of REQUIRE
;;;                 cleaner. Replaced all calls to REQUIRE in this file with
;;;                 calls to NEW-REQUIRE, which should avoid compiler warnings.
;;; 30-JAN-91  mk   In VAXLisp, when we redefine lisp:require, the compiler
;;;                 no longer automatically executes require forms when it
;;;                 encounters them in a file. The user can always wrap an
;;;                 (eval-when (compile load eval) ...) around the require
;;;                 form. Alternately, see commented out code near the
;;;                 redefinition of lisp:require which redefines it as a
;;;                 macro instead.
;;; 30-JAN-91  mk   Added parameter :version to operate-on-system. If it is
;;;                 a number, that number is used as part of the binary
;;;                 directory name as the place to store and load files.
;;;                 If NIL (the default), uses regular binary directory.
;;;                 If T, tries to find the most recent version of the
;;;                 binary directory.
;;; 30-JAN-91  mk   Added global variable *use-timeouts* (default: t), which
;;;                 specifies whether timeouts should be used in
;;;                 Y-OR-N-P-WAIT. This is provided for users whose lisps
;;;                 don't handle read-char-no-hang properly, so that they
;;;                 can set it to NIL to disable the timeouts. Usually the
;;;                 reason for this is the lisp is run on top of UNIX,
;;;                 which buffers input LINES (and provides input editing).
;;;                 To get around this we could always turn CBREAK mode
;;;                 on and off, but there's no way to do this in a portable
;;;                 manner.
;;; 30-JAN-91  mk   Fixed bug where in :test t mode it was actually providing
;;;                 the system, instead of faking it.
;;; 30-JAN-91  mk   Changed storage of system definitions to a hash table.
;;;                 Changed canonicalize-system-name to coerce the system
;;;                 names to uppercase strings. Since we're no longer using
;;;                 get, there's no need to intern the names as symbols,
;;;                 and strings don't have packages to cause problems.
;;;                 Added UNDEFSYSTEM, DEFINED-SYSTEMS, and DESCRIBE-SYSTEM.
;;;                 Added :delete-binaries command.
;;; 31-JAN-91  mk   Franz Allegro CL has a defsystem in the USER package,
;;;                 so we need to do a shadowing import to avoid name
;;;                 conflicts.
;;; 31-JAN-91  mk   Fixed bug in compile-and-load-operation where it was
;;;                 only loading newly compiled files.
;;; 31-JAN-91  mk   Added :load-time slot to components to record the
;;;                 file-write-date of the binary/source file that was loaded.
;;;                 Now knows "when" (which date version) the file was loaded.
;;;                 Added keyword :minimal-load and global *minimal-load*
;;;                 to enable defsystem to avoid reloading unmodified files.
;;;                 Note that if B depends on A, but A is up to date and
;;;                 loaded and the user specified :minimal-load T, then A
;;;                 will not be loaded even if B needs to be compiled. So
;;;                 if A is an initializations file, say, then the user should
;;;                 not specify :minimal-load T.
;;; 31-JAN-91  mk   Added :load-only slot to components. If this slot is
;;;                 specified as non-NIL, skips over any attempts to compile
;;;                 the files in the component. (Loading the file satisfies
;;;                 the need to recompile.)
;;; 31-JAN-91  mk   Eliminated use of set-alist-lookup and alist-lookup,
;;;                 replacing it with hash tables. It was too much bother,
;;;                 and rather brittle too.
;;; 31-JAN-91  mk   Defined #@ macro character for use with AFS @sys
;;;                 feature simulator. #@"directory" is then synonymous
;;;                 with (afs-binary-directory "directory").
;;; 31-JAN-91  mk   Added :private-file type of module. It is similar to
;;;                 :file, but has an absolute pathname. This allows you
;;;                 to specify a different version of a file in a system
;;;                 (e.g., if you're working on the file in your home
;;;                 directory) without completely rewriting the system
;;;                 definition.
;;; 31-JAN-91  mk   Operations on systems, such as :compile and :load,
;;;                 now propagate to subsystems the system depends on
;;;                 if *operations-propagate-to-subsystems* is T (the default)
;;;                 and the systems were defined using either defsystem
;;;                 or as a :system component of another system. Thus if
;;;                 a system depends on another, it can now recompile the
;;;                 other.
;;; 01-FEB-91  mk   Added default definitions of PROVIDE/REQUIRE/*MODULES*
;;;                 for lisps that have thrown away these definitions in
;;;                 accordance with CLtL2.
;;; 01-FEB-91  mk   Added :compile-only slot to components. Analogous to
;;;                 :load-only. If :compile-only is T, will not load the
;;;                 file on operation :compile. Either compiles or loads
;;;                 the file, but not both. In other words, compiling the
;;;                 file satisfies the demand to load it. This is useful
;;;                 for PCL defmethod and defclass definitions, which wrap
;;;                 an (eval-when (compile load eval) ...) around the body
;;;                 of the definition -- we save time by not loading the
;;;                 compiled code, since the eval-when forces it to be
;;;                 loaded. Note that this may not be entirely safe, since
;;;                 CLtL2 has added a :load keyword to compile-file, and
;;;                 some lisps may maintain a separate environment for
;;;                 the compiler. This feature is for the person who asked
;;;                 that a :COMPILE-SATISFIES-LOAD keyword be added to
;;;                 modules. It's named :COMPILE-ONLY instead to match
;;;                 :LOAD-ONLY.
;;; 11-FEB-91  mk   Now adds :mk-defsystem to features list, to allow
;;;                 special cased loading of defsystem if not already
;;;                 present.
;;; 19-FEB-91  duff Added filename extension for hp9000/300's running Lucid.
;;; 26-FEB-91  mk   Distinguish between toplevel systems (defined with
;;;                 defsystem) and systems defined as a :system module
;;;                 of a defsystem. The former can depend only on systems,
;;;                 while the latter can depend on anything at the same
;;;                 level.
;;; 12-MAR-91  mk   Added :subsystem component type to be a system with
;;;                 pathnames relative to its parent component.
;;; 12-MAR-91  mk   Uncommented :device :absolute for CMU pathnames, so
;;;                 that the leading slash is included.
;;; 12-MAR-91  brad Patches for Allegro 4.0.1 on Sparc.
;;; 12-MAR-91  mk   Changed definition of format-justified-string so that
;;;                 it no longer depends on the ~<~> format directives,
;;;                 because Allegro 4.0.1 has a bug which doesn't support
;;;                 them. Anyway, the new definition is twice as fast
;;;                 and conses half as much as FORMAT.
;;; 12-MAR-91 toni  Remove nils from list in expand-component-components.
;;; 12-MAR-91 bw    If the default-package and system have the same name,
;;;                 and the package is not loaded, this could lead to
;;;                 infinite loops, so we bomb out with an error.
;;;                 Fixed bug in default packages.
;;; 13-MAR-91 mk    Added global *providing-blocks-load-propagation* to
;;;                 control whether system dependencies are loaded if they
;;;                 have already been provided.
;;; 13-MAR-91 brad  In-package is a macro in CLtL2 lisps, so we change
;;;                 the package manually in operate-on-component.
;;; 15-MAR-91 mk    Modified *central-registry* to be either a single
;;;                 directory pathname, or a list of directory pathnames
;;;                 to be checked in order.
;;; 15-MAR-91 rs    Added afs-source-directory to handle versions when
;;;                 compiling C code under lisp. Other minor changes to
;;;                 translate-version and operate-on-system.
;;; 21-MAR-91 gi    Fixed bug in defined-systems.
;;; 22-MAR-91 mk    Replaced append-directories with new version that works
;;;                 by actually appending the directories, after massaging
;;;                 them into the proper format. This should work for all
;;;                 CLtL2-compliant lisps.
;;; 09-APR-91 djc   Missing package prefix for lp:pathname-host-type.
;;;                 Modified component-full-pathname to work for logical
;;;                 pathnames.
;;; 09-APR-91 mk    Added *dont-redefine-require* to control whether
;;;                 REQUIRE is redefined. Fixed minor bugs in redefinition
;;;                 of require.
;;; 12-APR-91 mk    (pathname-host nil) causes an error in MCL 2.0b1
;;; 12-APR-91 mc    Ported to MCL2.0b1.
;;; 16-APR-91 mk    Fixed bug in needs-loading where load-time and
;;;                 file-write-date got swapped.
;;; 16-APR-91 mk    If the component is load-only, defsystem shouldn't
;;;                 tell you that there is no binary and ask you if you
;;;                 want to load the source.
;;; 17-APR-91 mc    Two additional operations for MCL.
;;; 21-APR-91 mk    Added feature requested by ik. *files-missing-is-an-error*
;;;                 new global variable which controls whether files (source
;;;                 and binary) missing cause a continuable error or just a
;;;                 warning.
;;; 21-APR-91 mk    Modified load-file-operation to allow compilation of source
;;;                 files during load if the binary files are old or
;;;                 non-existent. This adds a :compile-during-load keyword to
;;;                 oos, and load-system. Global *compile-during-load* sets
;;;                 the default (currently :query).
;;; 21-APR-91 mk    Modified find-system so that there is a preference for
;;;                 loading system files from disk, even if the system is
;;;                 already defined in the environment.
;;; 25-APR-91 mk    Removed load-time slot from component defstruct and added
;;;                 function COMPONENT-LOAD-TIME to store the load times in a
;;;                 hash table. This is safer than the old definition because
;;;                 it doesn't wipe out load times every time the system is
;;;                 redefined.
;;; 25-APR-91 mk    Completely rewrote load-file-operation. Fixed some bugs
;;;                 in :compile-during-load and in the behavior of defsystem
;;;                 when multiple users are compiling and loading a system
;;;                 instead of just a single user.
;;; 16-MAY-91 mk    Modified FIND-SYSTEM to do the right thing if the system
;;;                 definition file cannot be found.
;;; 16-MAY-91 mk    Added globals *source-pathname-default* and
;;;                 *binary-pathname-default* to contain default values for
;;;                 :source-pathname and :binary-pathname. For example, set
;;;                 *source-pathname-default* to "" to avoid having to type
;;;                 :source-pathname "" all the time.
;;; 27-MAY-91 mk    Fixed bug in new-append-directories where directory
;;;                 components of the form "foo4.0" would appear as "foo4",
;;;                 since pathname-name truncates the type. Changed
;;;                 pathname-name to file-namestring.
;;;  3-JUN-91 gc    Small bug in new-append-directories; replace (when
;;;                 abs-name) with (when (not (null-string abs-name)))
;;;  4-JUN-91 mk    Additional small change to new-append-directories for
;;;                 getting the device from the relative pname if the abs
;;;                 pname is "". This is to fix a small behavior in CMU CL old
;;;                 compiler. Also changed (when (not (null-string abs-name)))
;;;                 to have an (and abs-name) in there.
;;;  8-JAN-92 sb    Added filename extension for defsystem under Lucid Common
;;;                 Lisp/SGO 3.0.1+.
;;;  8-JAN-92 mk    Changed the definition of prompt-string to work around an
;;;                 AKCL bug. Essentially, AKCL doesn't default the colinc to
;;;                 1 if the colnum is provided, so we hard code it.
;;;  8-JAN-92 rs    (pathname-directory (pathname "")) returns '(:relative) in
;;;                 Lucid, instead of NIL. Changed new-append-directories and
;;;                 test-new-append-directories to reflect this.
;;;  8-JAN-92 mk    Fixed problem related to *load-source-if-no-binary*.
;;;                 compile-and-load-source-if-no-binary wasn't checking for
;;;                 the existence of the binary if this variable was true,
;;;                 causing the file to not be compiled.
;;;  8-JAN-92 mk    Fixed problem with null-string being called on a pathname
;;;                 by returning NIL if the argument isn't a string.
;;;  3-NOV-93 mk    In Allegro 4.2, pathname device is :unspecific by default.
;;; 11-NOV-93 fdmm  Fixed package definition lock problem when redefining
;;;                 REQUIRE on ACL.
;;; 11-NOV-93 fdmm  Added machine and software types for SGI and IRIX. It is
;;;                 important to distinguish the OS version and CPU type in
;;;                 SGI+ACL, since ACL 4.1 on IRIX 4.x and ACL 4.2 on IRIX 5.x
;;;                 have incompatible .fasl files.
;;; 01-APR-94 fdmm  Fixed warning problem when redefining REQUIRE on LispWorks.
;;; 01-NOV-94 fdmm  Replaced (software-type) call in ACL by code extracting
;;;                 the interesting parts from (software-version) [deleted
;;;                 machine name and id].
;;; 03-NOV-94 fdmm  Added a hook (*compile-file-function*), that is funcalled
;;;                 by compile-file-operation, so as to support other languages
;;;                 running on top of Common Lisp.
;;;                 The default is to compile  Common Lisp.
;;; 03-NOV-94 fdmm  Added SCHEME-COMPILE-FILE, so that defsystem can now
;;;                 compile Pseudoscheme files.
;;; 04-NOV-94 fdmm  Added the exported generic function SET-LANGUAGE, to
;;;                 have a clean, easy to extend  interface for telling
;;;                 defsystem which language to assume for compilation.
;;;                 Currently supported arguments: :common-lisp, :scheme.
;;; 11-NOV-94 kc    Ported to Allegro CL for Windows 2.0 (ACLPC) and CLISP.
;;; 18-NOV-94 fdmm  Changed the entry *filename-extensions* for LispWorks
;;;                 to support any platform.
;;;                 Added entries for :mcl and :clisp too.
;;; 16-DEC-94 fdmm  Added and entry for CMU CL on SGI to *filename-extensions*.
;;; 16-DEC-94 fdmm  Added OS version identification for CMU CL on SGI.
;;; 16-DEC-94 fdmm  For CMU CL 17 : Bypassed make-pathnames call fix
;;;                 in NEW-APPEND-DIRECTORIES.
;;; 16-DEC-94 fdmm  Added HOME-SUBDIRECTORY to fix CMU's ignorance about `~'
;;;                 when specifying registries.
;;; 16-DEC-94 fdmm  For CMU CL 17 : Bypassed :device fix in make-pathnames call
;;;                 in COMPONENT-FULL-PATHNAME. This fix was also reported
;;;                 by kc on 12-NOV-94. CMU CL 17 now supports CLtL2 pathnames.
;;; 16-DEC-94 fdmm  Removed a quote before the call to read in the readmacro
;;;                 #@. This fixes a really annoying misfeature (couldn't do
;;;                 #@(concatenate 'string "foo/" "bar"), for example).
;;; 03-JAN-95 fdmm  Do not include :pcl in *features* if :clos is there.
;;;  2-MAR-95 mk    Modified fdmm's *central-registry* change to use
;;;                 user-homedir-pathname and to be a bit more generic in the
;;;                 pathnames.
;;;  2-MAR-95 mk    Modified fdmm's updates to *filename-extensions* to handle
;;;                 any CMU CL binary extensions.
;;;  2-MAR-95 mk    Make kc's port to ACLPC a little more generic.
;;;  2-MAR-95 mk    djc reported a bug, in which GET-SYSTEM was not returning
;;;                 a system despite the system's just having been loaded.
;;;                 The system name specified in the :depends-on was a
;;;                 lowercase string. I am assuming that the system name
;;;                 in the defsystem form was a symbol (I haven't verified
;;;                 that this was the case with djc, but it is the only
;;;                 reasonable conclusion). So, CANONICALIZE-SYSTEM-NAME
;;;                 was storing the system in the hash table as an
;;;                 uppercase string, but attempting to retrieve it as a
;;;                 lowercase string. This behavior actually isn't a bug,
;;;                 but a user error. It was intended as a feature to
;;;                 allow users to use strings for system names when
;;;                 they wanted to distinguish between two different systems
;;;                 named "foo.system" and "Foo.system". However, this
;;;                 user error indicates that this was a bad design decision.
;;;                 Accordingly, CANONICALIZE-SYSTEM-NAME now uppercases
;;;                 even strings for retrieving systems, and the comparison
;;;                 in *modules* is now case-insensitive. The result of
;;;                 this change is if the user cannot have distinct
;;;                 systems in "Foo.system" and "foo.system" named "Foo" and
;;;                 "foo", because they will clobber each other. There is
;;;                 still case-sensitivity on the filenames (i.e., if the
;;;                 system file is named "Foo.system" and you use "foo" in
;;;                 the :depends-on, it won't find it). We didn't take the
;;;                 further step of requiring system filenames to be lowercase
;;;                 because we actually find this kind of case-sensitivity
;;;                 to be useful, when maintaining two different versions
;;;                 of the same system.
;;;  7-MAR-95 mk    Added simplistic handling of logical pathnames. Also
;;;                 modified new-append-directories so that it'll try to
;;;                 split up pathname directories that are strings into a
;;;                 list of the directory components. Such directories aren't
;;;                 ANSI CL, but some non-conforming implementations do it.
;;;  7-MAR-95 mk    Added :proclamations to defsystem form, which can be used
;;;                 to set the compiler optimization level before compilation.
;;;                 For example,
;;;                  :proclamations '(optimize (safety 3) (speed 3) (space 0))
;;;  7-MAR-95 mk    Defsystem now tells the user when it reloads the system
;;;                 definition.
;;;  7-MAR-95 mk    Fixed problem pointed out by yc. If
;;;                 *source-pathname-default* is "" and there is no explicit
;;;                 :source-pathname specified for a file, the file could
;;;                 wind up with an empty file name. In other words, this
;;;                 global default shouldn't apply to :file components. Added
;;;                 explicit test for null strings, and when present replaced
;;;                 them with NIL (for binary as well as source, and also for
;;;                 :private-file components).
;;;  7-MAR-95 tar   Fixed defsystem to work on TI Explorers (TI CL).
;;;  7-MAR-95 jk    Added machine-type-translation for Decstation 5000/200
;;;                 under Allegro 3.1
;;;  7-MAR-95 as    Fixed bug in AKCL-1-615 in which defsystem added a
;;;                 subdirectory "RELATIVE" to all filenames.
;;;  7-MAR-95 mk    Added new test to test-new-append-directories to catch the
;;;                 error fixed by as. Essentially, this error occurs when the
;;;                 absolute-pathname has no directory (i.e., it has a single
;;;                 pathname component as in "foo" and not "foo/bar"). If
;;;                 RELATIVE ever shows up in the Result, we now know to
;;;                 add an extra conditionalization to prevent abs-keyword
;;;                 from being set to :relative.
;;;  7-MAR-95 ss    Miscellaneous fixes for MCL 2.0 final.
;;;                 *compile-file-verbose* not in MCL, *version variables
;;;                 need to occur before AFS-SOURCE-DIRECTORY definition,
;;;                 and certain code needed to be in the CCL: package.
;;;  8-MAR-95 mk    Y-OR-N-P-WAIT uses a busy-waiting. On Lisp systems where
;;;                 the time functions cons, such as CMU CL, this can cause a
;;;                 lot of ugly garbage collection messages. Modified the
;;;                 waiting to include calls to SLEEP, which should reduce
;;;                 some of the consing.
;;;  8-MAR-95 mk    Replaced fdmm's SET-LANGUAGE enhancement with a more
;;;                 general extension, along the lines suggested by akd.
;;;                 Defsystem now allows components to specify a :language
;;;                 slot, such as :language :lisp, :language :scheme. This
;;;                 slot is inherited (with the default being :lisp), and is
;;;                 used to obtain compilation and loading functions for
;;;                 components, as well as source and binary extensions. The
;;;                 compilation and loading functions can be overridden by
;;;                 specifying a :compiler or :loader in the system
;;;                 definition. Also added :documentation slot to the system
;;;                 definition.
;;;                    Where this comes in real handy is if one has a
;;;                 compiler-compiler implemented in Lisp, and wants the
;;;                 system to use the compiler-compiler to create a parser
;;;                 from a grammar and then compile parser. To do this one
;;;                 would create a module with components that looked
;;;                 something like this:
;;;               ((:module cc :components ("compiler-compiler"))
;;;                (:module gr :compiler 'cc :loader #'ignore
;;;                         :source-extension "gra"
;;;                         :binary-extension "lisp"
;;;                         :depends-on (cc)
;;;                         :components ("sample-grammar"))
;;;                (:module parser :depends-on (gr)
;;;                         :components ("sample-grammar")))
;;;                 Defsystem would then compile and load the compiler, use
;;;                 it (the function cc) to compile the grammar into a parser,
;;;                 and then compile the parser. The only tricky part is
;;;                 cc is defined by the system, and one can't include #'cc
;;;                 in the system definition. However, one could include
;;;                 a call to mk:define-language in the compiler-compiler file,
;;;                 and define :cc as a language. This is the prefered method.
;;;  8-MAR-95 mk    New definition of topological-sort suggested by rs2. This
;;;                 version avoids the call to SORT, but in practice isn't
;;;                 much faster. However, it avoids the need to maintain a
;;;                 TIME slot in the topsort-node structure.
;;;  8-MAR-95 mk    rs2 also pointed out that the calls to MAKE-PATHNAME and
;;;                 NAMESTRING in COMPONENT-FULL-PATHNAME are a major reason
;;;                 why defsystem is slow. Accordingly, I've changed
;;;                 COMPONENT-FULL-PATHNAME to include a call to NAMESTRING
;;;                 (and removed all other calls to NAMESTRING), and also made
;;;                 a few changes to minimize the number of calls to
;;;                 COMPONENT-FULL-PATHNAME, such as memoizing it. See To Do
;;;                 below for other related comments.
;;;  8-MAR-95 mk    Added special hack requested by Steve Strassman, which
;;;                 allows one to specify absolute pathnames in the shorthand
;;;                 for a list of components, and have defsystem recognize
;;;                 which are absolute and which are relative.
;;;                 I actually think this would be a good idea, but I haven't
;;;                 tested it, so it is disabled by default. Search for
;;;                 *enable-straz-absolute-string-hack* to enable it.
;;;  8-MAR-95 kt    Fixed problem with EXPORT in AKCL 1.603, in which it wasn't
;;;                 properly exporting the value of the global export
;;;                 variables.
;;;  8-MAR-95 mk    Added UNMUNGE-LUCID to fix nasty problem with COMPILE-FILE
;;;                 in Lucid. Lucid apparently tries to merge the :output-file
;;;                 with the source file when the :output-file is a relative
;;;                 pathname. Wierd, and definitely non-standard.
;;;  9-MAR-95 mk    Changed ALLEGRO-MAKE-SYSTEM-FASL to also include the files
;;;                 in any systems the system depends on, as per a
;;;                 request of oc.
;;;  9-MAR-95 mk    Some version of CMU CL couldn't hack a call to
;;;                 MAKE-PATHNAME with :host NIL. I'm not sure which version
;;;                 it is, but the current version doesn't have this problem.
;;;                 If given :host nil, it defaults the host to
;;;                 COMMON-LISP::*UNIX-HOST*. So I haven't "fixed" this
;;;                 problem.
;;;  9-MAR-95 mk    Integrated top-level commands for Allegro designed by bha
;;;                 into the code, with slight modifications.
;;;  9-MAR-95 mk    Instead of having COMPUTE-SYSTEM-PATH check the current
;;;                 directory in a hard-coded fashion, include the current
;;;                 directory in the *central-registry*, as suggested by
;;;                 bha and others.
;;;  9-MAR-95 bha   Support for Logical Pathnames in Allegro.
;;;  9-MAR-95 mk    Added modified version of bha's DEFSYSPATH idea.
;;; 13-MAR-95 mk    Added a macro for the simple serial case, where a system
;;;                 (or module) is simple a list of files, each of which
;;;                 depends on the previous one. If the value of :components
;;;                 is a list beginning with :serial, it expands each
;;;                 component and makes it depend on the previous component.
;;;                 For example, (:serial "foo" "bar" "baz") would create a
;;;                 set of components where "baz" depended on "bar" and "bar"
;;;                 on "foo".
;;; 13-MAR-95 mk    *** Now version 3.0. This version is a interim bug-fix and
;;;                 update, since I do not have the time right now to complete
;;;                 the complete overhaul and redesign.
;;;                 Major changes in 3.0 include CMU CL 17, CLISP, ACLPC, TI,
;;;                 LispWorks and ACL(SGI) support, bug fixes for ACL 4.1/4.2.
;;; 14-MAR-95 fdmm  Finally added the bit of code to discriminate cleanly
;;;                 among different lisps without relying on (software-version)
;;;                 idiosyncracies.
;;;                 You can now customize COMPILER-TYPE-TRANSLATION so that
;;;                 AFS-BINARY-DIRECTORY can return a different value for
;;;                 different lisps on the same platform.
;;;                 If you use only one compiler, do not care about supporting
;;;                 code for multiple versions of it, and want less verbose
;;;                 directory names, just set *MULTIPLE-LISP-SUPPORT* to nil.
;;; 17-MAR-95 lmh   Added EVAL-WHEN for one of the MAKE-PACKAGE calls.
;;;                 CMU CL's RUN-PROGRAM is in the extensions package.
;;;                 ABSOLUTE-FILE-NAMESTRING-P was missing :test keyword
;;;                 Rearranged conditionalization in DIRECTORY-TO-LIST to
;;;                 suppress compiler warnings in CMU CL.
;;; 17-MAR-95 mk    Added conditionalizations to avoid certain CMU CL compiler
;;;                 warnings reported by lmh.
;;; 19990610  ma    Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed.

;;; 19991211  ma    NEW VERSION 4.0 started.
;;; 19991211  ma    Merged in changes requested by T. Russ of
;;;                 ISI. Please refer to the special "ISI" comments to
;;;                 understand these changes
;;; 20000228 ma     The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM,
;;;                 COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer
;;;                 imported in the COMMON-LISP-USER package.
;;;                 Cfr. the definitions of *EXPORTS* and
;;;                 *SPECIAL-EXPORTS*.
;;; 2000-07-21 rlt  Add COMPILER-OPTIONS to defstruct to allow user to
;;;                 specify special compiler options for a particular
;;;                 component.
;;; 2002-01-08 kmr  Changed allegro symbols to lowercase to support
;;;                 case-sensitive images

;;;---------------------------------------------------------------------------
;;; ISI Comments
;;;
;;; 19991211 Marco Antoniotti
;;; These comments come from the "ISI Branch".  I believe I did
;;; include the :load-always extension correctly.  The other commets
;;; seem superseded by other changes made to the system in the
;;; following years.  Some others are now useless with newer systems
;;; (e.g. filename truncation for new Windows based CL
;;; implementations.)

;;;  1-OCT-92 tar   Fixed problem with TI Lisp machines and append-directory.
;;;  1-OCT-92 tar   Made major modifications to compile-file-operation and
;;;                 load-file-operation to reduce the number of probe-file
;;;                 and write-date inquiries.  This makes the system run much
;;;                 faster through slow network connections.
;;; 13-OCT-92 tar   Added :load-always slot to components. If this slot is
;;;                 specified as non-NIL, always loads the component.
;;;                 This does not trigger dependent compilation.
;;;                 (This can be useful when macro definitions needed
;;;                 during compilation are changed by later files.  In
;;;                 this case, not reloading up-to-date files can
;;;                 cause different results.)
;;; 28-OCT-93 tar   Allegro 4.2 causes an error on (pathname-device nil)
;;; 14-SEP-94 tar   Disable importing of symbols into (CL-)USER package
;;;                 to minimize conflicts with other defsystem utilities.
;;; 10-NOV-94 tar   Added filename truncation code to support Franz Allegro
;;;                 PC with it's 8 character filename limitation.
;;; 15-MAY-98 tar   Changed host attribute for pathnames to support LispWorks
;;;                 (Windows) pathnames which reference other Drives.  Also
;;;                 updated file name convention.
;;;  9-NOV-98 tar   Updated new-append-directories for Lucid 5.0
;;;

\f
;;; ********************************
;;; Ports **************************
;;; ********************************
;;;
;;;    DEFSYSTEM has been tested (successfully) in the following lisps:
;;;       CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
;;;       CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach)
;;;       CMU Common Lisp 17f (Python 1.0)
;;;       Franz Allegro Common Lisp 3.1.12 (ExCL 3/30/90)
;;;       Franz Allegro Common Lisp 4.0/4.1/4.2
;;;       Franz Allegro Common Lisp for Windows (2.0)
;;;       Lucid Common Lisp (Version 2.1 6-DEC-87)
;;;       Lucid Common Lisp (3.0 [SPARC,SUN3])
;;;       Lucid Common Lisp (4.0 [SPARC,SUN3])
;;;       VAXLisp (v2.2) [VAX/VMS]
;;;       VAXLisp (v3.1)
;;;       Harlequin LispWorks
;;;       CLISP (CLISP3 [SPARC])
;;;       Symbolics XL12000 (Genera 8.3)
;;;       Scieneer Common Lisp (SCL) 1.1
;;;       Macintosh Common Lisp
;;;       ECL
;;;
;;;    DEFSYSTEM needs to be tested in the following lisps:
;;;       OpenMCL
;;;       Symbolics Common Lisp (8.0)
;;;       KCL (June 3, 1987 or later)
;;;       AKCL (1.86, June 30, 1987 or later)
;;;       TI (Release 4.1 or later)
;;;       Ibuki Common Lisp (01/01, October 15, 1987)
;;;       Golden Common Lisp (3.1 IBM-PC)
;;;       HP Common Lisp (same as Lucid?)
;;;       Procyon Common Lisp
\f
;;; ********************************
;;; To Do **************************
;;; ********************************
;;;
;;; COMPONENT-FULL-PATHNAME is a major source of slowness in the system
;;; because of all the calls to the expensive operations MAKE-PATHNAME
;;; and NAMESTRING. To improve performance, DEFSYSTEM should be reworked
;;; to avoid any need to call MAKE-PATHNAME and NAMESTRING, as the logical
;;; pathnames package does. Unfortunately, I don't have the time to do this
;;; right now. Instead, I installed a temporary improvement by memoizing
;;; COMPONENT-FULL-PATHNAME to cache previous calls to the function on
;;; a component by component and type by type basis. The cache is
;;; cleared before each call to OOS, in case filename extensions change.
;;; But DEFSYSTEM should really be reworked to avoid this problem and
;;; ensure greater portability and to also handle logical pathnames.
;;;
;;; Also, PROBE-FILE and FILE-WRITE-DATE are other sources of slowness.
;;; Perhaps by also memoizing FILE-WRITE-DATE and reimplementing PROBE-FILE
;;; in terms of FILE-WRITE-DATE, can achieve a further speed-up. This was
;;; suggested by Steven Feist (feist@ils.nwu.edu).
;;;
;;; True CLtL2 logical pathnames support -- can't do it, because CLtL2
;;; doesn't have all the necessary primitives, and even in Allegro CL 4.2
;;;   (namestring #l"foo:bar;baz.lisp")
;;; does not work properly.
;;;
;;; Create separate stand-alone documentation for defsystem, and also
;;; a test suite.
;;;
;;; Change SYSTEM to be a class instead of a struct, and make it a little
;;; more generic, so that it permits alternate system definitions.
;;; Replace OPERATE-ON-SYSTEM with MAP-SYSTEM (args: function, system-name,
;;; &rest options)
;;;
;;; Add a patch directory mechanism. Perhaps have several directories
;;; with code in them, and the first one with the specified file wins?
;;; LOAD-PATCHES function.
;;;
;;; Need way to load old binaries even if source is newer.
;;;
;;; Allow defpackage forms/package definitions in the defsystem? If
;;; a package not defined, look for and load a file named package.pkg?
;;;
;;; need to port for GNU CL (ala kcl)?
;;;
;;; Someone asked whether one can have :file components at top-level. I believe
;;; this is the case, but should double-check that it is possible (and if
;;; not, make it so).
;;;
;;; A common error/misconception seems to involve assuming that :system
;;; components should include the name of the system file, and that
;;; defsystem will automatically load the file containing the system
;;; definition and propagate operations to it. Perhaps this would be a
;;; nice feature to add.
;;;
;;; If a module is :load-only t, then it should not execute its :finally-do
;;; and :initially-do clauses during compilation operations, unless the
;;; module's files happen to be loaded during the operation.
;;;
;;; System Class. Customizable delimiters.
;;;
;;; Load a system (while not loading anything already loaded)
;;; and inform the user of out of date fasls with the choice
;;; to load the old fasl or recompile and then load the new
;;; fasl?
;;;
;;; modify compile-file-operation to handle a query keyword....
;;;
;;; Perhaps systems should keep around the file-write-date of the system
;;; definition file, to prevent excessive reloading of the system definition?
;;;
;;; load-file-operation needs to be completely reworked to simplify the
;;; logic of when files get loaded or not.
;;;
;;; Need to revamp output: Nesting and indenting verbose output doesn't
;;; seem cool, especially when output overflows the 80-column margins.
;;;
;;; Document various ways of writing a system. simple (short) form
;;; (where :components is just a list of filenames) in addition to verbose.
;;; Put documentation strings in code.
;;;
;;; :load-time for modules and systems -- maybe record the time the system
;;; was loaded/compiled here and print it in describe-system?
;;;
;;; Make it easy to define new functions that operate on a system. For
;;; example, a function that prints out a list of files that have changed,
;;; hardcopy-system, edit-system, etc.
;;;
;;; If a user wants to have identical systems for different lisps, do we
;;; force the user to use logical pathnames? Or maybe we should write a
;;; generic-pathnames package that parses any pathname format into a
;;; uniform underlying format (i.e., pull the relevant code out of
;;; logical-pathnames.lisp and clean it up a bit).
;;;
;;;    Verify that Mac pathnames now work with append-directories.
;;;
;;; A common human error is to violate the modularization by making a file
;;; in one module depend on a file in another module, instead of making
;;; one module depend on the other. This is caught because the dependency
;;; isn't found. However, is there any way to provide a more informative
;;; error message? Probably not, especially if the system has multiple
;;; files of the same name.
;;;
;;; For a module none of whose files needed to be compiled, have it print out
;;; "no files need recompilation".
;;;
;;; Write a system date/time to a file? (version information) I.e., if the
;;; filesystem supports file version numbers, write an auxiliary file to
;;; the system definition file that specifies versions of the system and
;;; the version numbers of the associated files.
;;;
;;; Add idea of a patch directory.
;;;
;;; In verbose printout, have it log a date/time at start and end of
;;; compilation:
;;;     Compiling system "test" on 31-Jan-91 21:46:47
;;;     by Defsystem version v2.0 01-FEB-91.
;;;
;;; Define other :force options:
;;;    :query    allows user to specify that a file not normally compiled
;;;              should be. OR
;;;    :confirm  allows user to specify that a file normally compiled
;;;              shouldn't be. AND
;;;
;;; We currently assume that compilation-load dependencies and if-changed
;;; dependencies are identical. However, in some cases this might not be
;;; true. For example, if we change a macro we have to recompile functions
;;; that depend on it (except in lisps that automatically do this, such
;;; as the new CMU Common Lisp), but not if we change a function. Splitting
;;; these apart (with appropriate defaulting) would be nice, but not worth
;;; doing immediately since it may save only a couple of file recompilations,
;;; while making defsystem much more complex than it already is.
;;;
;;; Current dependencies are limited to siblings. Maybe we should allow
;;; nephews and uncles? So long as it is still a DAG, we can sort it.
;;; Answer: No. The current setup enforces a structure on the modularity.
;;; Otherwise, why should we have modules if we're going to ignore it?
;;;
;;; Currently a file is recompiled more or less if the source is newer
;;; than the binary or if the file depends on a file that has changed
;;; (i.e., was recompiled in this session of a system operation).
;;; Neil Goldman <goldman@isi.edu> has pointed out that whether a file
;;; needs recompilation is really independent of the current session of
;;; a system operation, and depends only on the file-write-dates of the
;;; source and binary files for a system. Thus a file should require
;;; recompilation in the following circumstances:
;;;   1. If a file's source is newer than its binary, or
;;;   2. If a file's source is not newer than its binary, but the file
;;;      depends directly or indirectly on a module (or file) that is newer.
;;;      For a regular file use the file-write-date (FWD) of the source or
;;;      binary, whichever is more recent. For a load-only file, use the only
;;;      available FWD. For a module, use the most recent (max) FWD of any of
;;;      its components.
;;; The impact of this is that instead of using a boolean CHANGED variable
;;; throughout the code, we need to allow CHANGED to be NIL/T/<FWD> or
;;; maybe just the FWD timestamp, and to use the value of CHANGED in
;;; needs-compilation decisions. (Use of NIL/T as values is an optimization.
;;; The FWD timestamp which indicates the most recent time of any changes
;;; should be sufficient.) This will affect not just the
;;; compile-file-operation, but also the load-file-operation because of
;;; compilation during load. Also, since FWDs will be used more prevalently,
;;; we probably should couple this change with the inclusion of load-times
;;; in the component defstruct. This is a tricky and involved change, and
;;; requires more thought, since there are subtle cases where it might not
;;; be correct. For now, the change will have to wait until the DEFSYSTEM
;;; redesign.
\f
;;; ********************************************************************
;;; How to Use this System *********************************************
;;; ********************************************************************

;;; To use this system,
;;; 1. If you want to have a central registry of system definitions,
;;;    modify the value of the variable *central-registry* below.
;;; 2. Load this file (defsystem.lisp) in either source or compiled form,
;;; 3. Load the file containing the "defsystem" definition of your system,
;;; 4. Use the function "operate-on-system" to do things to your system.

;;; For more information, see the documentation and examples in
;;; lisp-utilities.ps.

;;; ********************************
;;; Usage Comments *****************
;;; ********************************

;;; If you use symbols in the system definition file, they get interned in
;;; the COMMON-LISP-USER package, which can lead to name conflicts when
;;; the system itself seeks to export the same symbol to the COMMON-LISP-USER
;;; package. The workaround is to use strings instead of symbols for the
;;; names of components in the system definition file. In the major overhaul,
;;; perhaps the user should be precluded from using symbols for such
;;; identifiers.
;;;
;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp",
;;; file name expansion is much slower than if you use the full pathname,
;;; as in "/user/USERID/lisp".
;;;


;;; ****************************************************************
;;; Lisp Code ******************************************************
;;; ****************************************************************

;;; ********************************
;;; Massage CLtL2 onto *features* **
;;; ********************************
;;; Let's be smart about CLtL2 compatible Lisps:
(eval-when (compile load eval)
  #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl)
  (pushnew :cltl2 *features*))

;;; ********************************
;;; Provide/Require/*modules* ******
;;; ********************************

;;; Since CLtL2 has dropped require and provide from the language, some
;;; lisps may not have the functions PROVIDE and REQUIRE and the
;;; global *MODULES*. So if lisp::provide and user::provide are not
;;; defined, we define our own.

;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions
;;; and variables not being declared or bound, apparently because it
;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns
;;; T, so it doesn't really bother when compiling the body of the unless.
;;; The new compiler does this properly, so I'm not going to bother
;;; working around this.

;;; Some Lisp implementations return bogus warnings about assuming
;;; *MODULE-FILES* and *LIBRARY* to be special, and CANONICALIZE-MODULE-NAME
;;; and MODULE-FILES being undefined. Don't worry about them.

;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code
;;; necessary?

#-(or :CMU
      :vms
      :mcl
      :lispworks
      :clisp
      :gcl
      :sbcl
      :cormanlisp
      :scl
      (and allegro-version>= (version>= 4 1)))
(eval-when #-(or :lucid)
           (:compile-toplevel :load-toplevel :execute)
           #+(or :lucid)
           (compile load eval)

  (unless (or (fboundp 'lisp::require)
              (fboundp 'user::require)

              #+(and :excl (and allegro-version>= (version>= 4 0)))
              (fboundp 'cltl1::require)

              #+:lispworks
              (fboundp 'system::require))

    #-:lispworks
    (in-package "LISP")
    #+:lispworks
    (in-package "SYSTEM")

    (export '(*modules* provide require))

    ;; Documentation strings taken almost literally from CLtL1.

    (defvar *modules* ()
      "List of names of the modules that have been loaded into Lisp so far.
     It is used by PROVIDE and REQUIRE.")

    ;; We provide two different ways to define modules. The default way
    ;; is to put either a source or binary file with the same name
    ;; as the module in the library directory. The other way is to define
    ;; the list of files in the module with defmodule.

    ;; The directory listed in *library* is implementation dependent,
    ;; and is intended to be used by Lisp manufacturers as a place to
    ;; store their implementation dependent packages.
    ;; Lisp users should use systems and *central-registry* to store
    ;; their packages -- it is intended that *central-registry* is
    ;; set by the user, while *library* is set by the lisp.

    (defvar *library* nil               ; "/usr/local/lisp/Modules/"
      "Directory within the file system containing files, where the name
     of a file is the same as the name of the module it contains.")

    (defvar *module-files* (make-hash-table :test #'equal)
      "Hash table mapping from module names to list of files for the
     module. REQUIRE loads these files in order.")

    (defun canonicalize-module-name (name)
      ;; if symbol, string-downcase the printrep to make nicer filenames.
      (if (stringp name) name (string-downcase (string name))))

    (defmacro defmodule (name &rest files)
      "Defines a module NAME to load the specified FILES in order."
      `(setf (gethash (canonicalize-module-name ,name) *module-files*)
             ',files))
    (defun module-files (name)
      (gethash name *module-files*))

    (defun provide (name)
      "Adds a new module name to the list of modules maintained in the
     variable *modules*, thereby indicating that the module has been
     loaded. Name may be a string or symbol -- strings are case-senstive,
     while symbols are treated like lowercase strings. Returns T if
     NAME was not already present, NIL otherwise."
      (let ((module (canonicalize-module-name name)))
        (unless (find module *modules* :test #'string=)
          ;; Module not present. Add it and return T to signify that it
          ;; was added.
          (push module *modules*)
          t)))

    (defun require (name &optional pathname)
      "Tests whether a module is already present. If the module is not
     present, loads the appropriate file or set of files. The pathname
     argument, if present, is a single pathname or list of pathnames
     whose files are to be loaded in order, left to right. If the
     pathname is nil, the system first checks if a module was defined
     using defmodule and uses the pathnames so defined. If that fails,
     it looks in the library directory for a file with name the same
     as that of the module. Returns T if it loads the module."
      (let ((module (canonicalize-module-name name)))
        (unless (find module *modules* :test #'string=)
          ;; Module is not already present.
          (when (and pathname (not (listp pathname)))
            ;; If there's a pathname or pathnames, ensure that it's a list.
            (setf pathname (list pathname)))
          (unless pathname
            ;; If there's no pathname, try for a defmodule definition.
            (setf pathname (module-files module)))
          (unless pathname
            ;; If there's still no pathname, try the library directory.
            (when *library*
              (setf pathname (concatenate 'string *library* module))
              ;; Test if the file exists.
              ;; We assume that the lisp will default the file type
              ;; appropriately. If it doesn't, use #+".fasl" or some
              ;; such in the concatenate form above.
              (if (probe-file pathname)
                  ;; If it exists, ensure we've got a list
                  (setf pathname (list pathname))
                  ;; If the library file doesn't exist, we don't want
                  ;; a load error.
                  (setf pathname nil))))
          ;; Now that we've got the list of pathnames, let's load them.
          (dolist (pname pathname t)
            (load pname :verbose nil))))))
  ) ; eval-when

;;; ********************************
;;; Set up Package *****************
;;; ********************************


;;; Unfortunately, lots of lisps have their own defsystems, some more
;;; primitive than others, all uncompatible, and all in the DEFSYSTEM
;;; package. To avoid name conflicts, we've decided to name this the
;;; MAKE package. A nice side-effect is that the short nickname
;;; MK is my initials.

#+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))

#-(or :sbcl :cltl2 :lispworks :ecl :scl)
(in-package "MAKE" :nicknames '("MK"))

;;; For CLtL2 compatible lisps...
#+(and :excl :allegro-v4.0 :cltl2)
(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
            (:import-from cltl1 *modules* provide require))

;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
;;; In Allegro 4.1, 'provide' and 'require' are not external in
;;; 'CLTL1'.  However they are in 'COMMON-LISP'.  Hence the change.
#+(and :excl :allegro-v4.1 :cltl2)
(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) )

#+(and :excl :allegro-version>= (version>= 4 2))
(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp))

#+:lispworks
(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
            (:import-from "SYSTEM" *modules* provide require)
            (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
                     "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))

#+:mcl
(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
  (:import-from ccl *modules* provide require))

;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
;;; The code below, is originally executed also for CMUCL. However I
;;; believe this is wrong, since CMUCL comes with its own defpackage.
;;; I added the extra :CMU in the 'or'.
#+(and :cltl2 (not (or :cmu :clisp :sbcl
                       (and :excl (or :allegro-v4.0 :allegro-v4.1))
                       :mcl)))
(eval-when (compile load eval)
  (unless (find-package "MAKE")
    (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))

;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19951012
;;; Here I add the proper defpackage for CMU
#+:CMU
(defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
  (:nicknames "MK")
  (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
           "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"
           "FIND-SYSTEM"))

#+:sbcl
(defpackage "MAKE" (:use "COMMON-LISP")
  (:nicknames "MK"))

#+:scl
(defpackage :make (:use :common-lisp)
  (:nicknames :mk))

#+(or :cltl2 :lispworks :scl)
(eval-when (compile load eval)
  (in-package "MAKE"))

#+ecl
(in-package "MAKE")

;;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19970105
;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
#+(and :excl :allegro-v4.0 :cltl2)
(cltl1:provide 'make)
#+(and :excl :allegro-v4.0 :cltl2)
(provide 'make)

#+:openmcl
(cl:provide 'make)

#+(and :mcl (not :openmcl))
(ccl:provide 'make)

#+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)))
(provide 'make)

#+:lispworks
(provide 'make)

#-(or :cltl2 :lispworks)
(progn
  (provide 'make)
  (provide 'defsystem))

(pushnew :mk-defsystem *features*)

;;; Some compatibility issues.  Mostly for CormanLisp.
;;; 2002-02-20 Marco Antoniotti

#+cormanlisp
(defun compile-file-pathname (pathname-designator)
 (merge-pathnames (make-pathname :type "fasl")
                  (etypecase pathname-designator
                    (pathname pathname-designator)
                    (string (parse-namestring pathname-designator))
                    ;; We need FILE-STREAM here as well.
                    )))

#+cormanlisp
(defun file-namestring (pathname-designator)
  (let ((p (etypecase pathname-designator
             (pathname pathname-designator)
             (string (parse-namestring pathname-designator))
             ;; We need FILE-STREAM here as well.
             )))
    (namestring (make-pathname :directory ()
                               :name (pathname-name p)
                               :type (pathname-type p)
                               :version (pathname-version p)))))

;;; The external interface consists of *exports* and *other-exports*.

;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in
;;; the compile form, so that you can't use a defvar with a default value and
;;; then a succeeding export as well.

(eval-when (compile load eval)
  (defvar *special-exports* nil)
  (defvar *exports* nil)
  (defvar *other-exports* nil)

  (export (setq *exports*
                '(operate-on-system
                  oos
                  afs-binary-directory afs-source-directory
                  files-in-system)))
  (export (setq *special-exports*
                '()))
  (export (setq *other-exports*
                '(*central-registry*
                  *bin-subdir*

                  add-registry-location
                  list-central-registry-directories
                  print-central-registry-directories
                  find-system
                  defsystem compile-system load-system hardcopy-system

                  system-definition-pathname

                  missing-component
                  missing-component-name
                  missing-component-component
                  missing-module
                  missing-system

                  register-foreign-system

                  machine-type-translation
                  software-type-translation
                  compiler-type-translation
                  ;; require
                  define-language
                  allegro-make-system-fasl
                  files-which-need-compilation
                  undefsystem
                  defined-systems
                  describe-system clean-system edit-system ;hardcopy-system
                  system-source-size make-system-tag-table
                  *defsystem-version*
                  *compile-during-load*
                  *minimal-load*
                  *dont-redefine-require*
                  *files-missing-is-an-error*
                  *reload-systems-from-disk*
                  *source-pathname-default*
                  *binary-pathname-default*
                  *multiple-lisp-support*

                  run-unix-program
                  *default-shell*
                  run-shell-command
                  )))
  )


;;; We import these symbols into the USER package to make them
;;; easier to use. Since some lisps have already defined defsystem
;;; in the user package, we may have to shadowing-import it.
#|
#-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
(eval-when (compile load eval)
  (import *exports* #-(or :cltl2 :lispworks) "USER"
                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
  (import *special-exports* #-(or :cltl2 :lispworks) "USER"
                            #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
#+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
(eval-when (compile load eval)
  (import *exports* #-(or :cltl2 :lispworks) "USER"
                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
  (shadowing-import *special-exports*
                    #-(or :cltl2 :lispworks) "USER"
                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
|#

#-(or :PCL :CLOS :scl)
(when (find-package "PCL")
  (pushnew :pcl *modules*)
  (pushnew :pcl *features*))


;;; ********************************
;;; Defsystem Version **************
;;; ********************************
(defparameter *defsystem-version* "3.6 Interim, 2008-12-18"
  "Current version number/date for MK:DEFSYSTEM.")


;;; ********************************
;;; Customizable System Parameters *
;;; ********************************

(defvar *dont-redefine-require*
  #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil)
  #+(or clisp sbcl) t
  #+allegro t
  #-(or cmu sbcl clisp allegro) nil
  "If T, prevents the redefinition of REQUIRE.
This is useful for lisps that treat REQUIRE specially in the compiler.")


(defvar *multiple-lisp-support* t
  "If T, afs-binary-directory will try to return a name dependent
on the particular lisp compiler version being used.")


;;; home-subdirectory --
;;; HOME-SUBDIRECTORY is used only in *central-registry* below.
;;; Note that CMU CL 17e does not understand the ~/ shorthand for home
;;; directories.
;;;
;;; Note:
;;; 20020220 Marco Antoniotti
;;; The #-cormanlisp version is the original one, which is broken anyway, since
;;; it is UNIX dependent.
;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing
;;; the ANSI USER-HOMEDIR-PATHNAME function.

#-cormanlisp
(defun home-subdirectory (directory)
  (concatenate 'string
        #+(or :sbcl :cmu :scl)
        "home:"
        #-(or :sbcl :cmu :scl)
        (let ((homedir (user-homedir-pathname)))
          (or (and homedir (namestring homedir))
              "~/"))
        directory))


#+cormanlisp
(defun home-subdirectory (directory)
  (declare (type string directory))
  (concatenate 'string "C:\\" directory))


;;; The following function is available for users to add
;;;   (setq mk:*central-registry* (defsys-env-search-path))
;;; to Lisp init files in order to use the value of the DEFSYSPATH
;;; instead of directly coding it in the file.

#+:allegro
(defun defsys-env-search-path ()
  "This function grabs the value of the DEFSYSPATH environment variable
   and breaks the search path into a list of paths."
  (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
                     :test #'string-equal))


;;; Change this variable to set up the location of a central
;;; repository for system definitions if you want one.
;;; This is a defvar to allow users to change the value in their
;;; lisp init files without worrying about it reverting if they
;;; reload defsystem for some reason.

;;; Note that if a form is included in the registry list, it will be evaluated
;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check.

(defvar *central-registry*
  `(;; Current directory
    "./"
    #+:LUCID     (working-directory)
    #+ACLPC      (current-directory)
    #+:allegro   (excl:current-directory)
    #+:clisp     (ext:default-directory)
    #+:sbcl      (progn *default-pathname-defaults*)
    #+(or :cmu :scl)       (ext:default-directory)
    ;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu>
    ;; Somehow it is better to qualify default-directory in CMU with
    ;; the appropriate package (i.e. "EXTENSIONS".)
    ;; Same for Allegro.
    #+(and :lispworks (not :lispworks4) (not :lispworks5))
    ,(multiple-value-bind (major minor)
                          #-:lispworks-personal-edition
                          (system::lispworks-version)
                          #+:lispworks-personal-edition
                          (values system::*major-version-number*
                                  system::*minor-version-number*)
       (if (or (> major 3)
               (and (= major 3) (> minor 2))
               (and (= major 3) (= minor 2)
                    (equal (lisp-implementation-version) "3.2.1")))
           `(make-pathname :directory
                           ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
                                         (find-package "SYSTEM")))
           (find-symbol "*CURRENT-WORKING-DIRECTORY*"
                        (find-package "LW"))))
    #+(or :lispworks4 :lispworks5)
    (hcl:get-working-directory)
    ;; Home directory
    #-sbcl
    (mk::home-subdirectory "lisp/systems/")

    ;; Global registry
    #+unix (pathname "/usr/local/lisp/Registry/")
    )
  "Central directory of system definitions.
May be either a single directory pathname, or a list of directory
pathnames to be checked after the local directory.")


(defun add-registry-location (pathname)
  "Adds a path to the central registry."
  (pushnew pathname *central-registry* :test #'equal))


(defun registry-pathname (registry)
  "Return the pathname represented by the element of *CENTRAL-REGISTRY*."
  (typecase registry
    (string (pathname registry))
    (pathname registry)
    (otherwise (pathname (eval registry)))))


(defun print-central-registry-directories (&optional (stream *standard-output*))
  (dolist (registry *central-registry*)
    (print (registry-pathname registry) stream)))


(defun list-central-registry-directories ()
  (mapcar #'registry-pathname *central-registry*))


(defvar *bin-subdir* ".bin/"
  "The subdirectory of an AFS directory where the binaries are really kept.")


;;; These variables set up defaults for operate-on-system, and are used
;;; for communication in lieu of parameter passing. Yes, this is bad,
;;; but it keeps the interface small. Also, in the case of the -if-no-binary
;;; variables, parameter passing would require multiple value returns
;;; from some functions. Why make life complicated?

(defvar *tell-user-when-done* nil
  "If T, system will print ...DONE at the end of an operation")

(defvar *oos-verbose* nil
  "Operate on System Verbose Mode")

(defvar *oos-test* nil
  "Operate on System Test Mode")

(defvar *load-source-if-no-binary* nil
  "If T, system will try loading the source if the binary is missing")

(defvar *bother-user-if-no-binary* t
  "If T, the system will ask the user whether to load the source if
   the binary is missing")

(defvar *load-source-instead-of-binary* nil
  "If T, the system will load the source file instead of the binary.")

(defvar *compile-during-load* :query
  "If T, the system will compile source files during load if the
binary file is missing. If :query, it will ask the user for
permission first.")

(defvar *minimal-load* nil
  "If T, the system tries to avoid reloading files that were already loaded
and up to date.")

(defvar *files-missing-is-an-error* t
  "If both the source and binary files are missing, signal a continuable
   error instead of just a warning.")

(defvar *operations-propagate-to-subsystems* t
  "If T, operations like :COMPILE and :LOAD propagate to subsystems
   of a system that are defined either using a component-type of :system
   or by another defsystem form.")

;;; Particular to CMULisp

(defvar *compile-error-file-type* "err"
  "File type of compilation error file in cmulisp")

(defvar *cmu-errors-to-terminal* t
  "Argument to :errors-to-terminal in compile-file in cmulisp")

(defvar *cmu-errors-to-file* t
  "If T, cmulisp will write an error file during compilation")


;;; ********************************
;;; Global Variables ***************
;;; ********************************

;;; Massage people's *features* into better shape.
(eval-when (compile load eval)
  (dolist (feature *features*)
    (when (and (symbolp feature)   ; 3600
               (equal (symbol-name feature) "CMU"))
      (pushnew :CMU *features*)))

  #+Lucid
  (when (search "IBM RT PC" (machine-type))
    (pushnew :ibm-rt-pc *features*))
  )


;;; *filename-extensions* is a cons of the source and binary extensions.
(defvar *filename-extensions*
  (car `(#+(and Symbolics Lispm)              ("lisp" . "bin")
         #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
         #+(and dec common vax ultrix)        ("lsp"  . "fas")
         #+ACLPC                              ("lsp"  . "fsl")
         #+CLISP                              ("lisp" . "fas")
         #+KCL                                ("lsp"  . "o")
         ;;#+ECL                                ("lsp"  . "so")
         #+IBCL                               ("lsp"  . "o")
         #+Xerox                              ("lisp" . "dfasl")
         ;; Lucid on Silicon Graphics
         #+(and Lucid MIPS)                   ("lisp" . "mbin")
         ;; the entry for (and lucid hp300) must precede
         ;; that of (and lucid mc68000) for hp9000/300's running lucid,
         ;; since *features* on hp9000/300's also include the :mc68000
         ;; feature.
         #+(and lucid hp300)                  ("lisp" . "6bin")
         #+(and Lucid MC68000)                ("lisp" . "lbin")
         #+(and Lucid Vax)                    ("lisp" . "vbin")
         #+(and Lucid Prime)                  ("lisp" . "pbin")
         #+(and Lucid SUNRise)                ("lisp" . "sbin")
         #+(and Lucid SPARC)                  ("lisp" . "sbin")
         #+(and Lucid :IBM-RT-PC)             ("lisp" . "bbin")
         ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
         #+(and Lucid PA)                     ("lisp" . "hbin")
         #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
         #+(or :cmu :scl)  ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
;        #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
         #+PRIME                              ("lisp" . "pbin")
         #+HP                                 ("l"    . "b")
         #+TI ("lisp" . #.(string (si::local-binary-file-type)))
         #+:gclisp                            ("LSP"  . "F2S")
         #+pyramid                            ("clisp" . "o")

         ;; Harlequin LispWorks
         #+:lispworks         ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
;        #+(and :sun4 :lispworks)             ("lisp" . "wfasl")
;        #+(and :mips :lispworks)             ("lisp" . "mfasl")
         #+:mcl                               ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
         #+:coral                             ("lisp" . "fasl")

         ;; Otherwise,
         ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
  "Filename extensions for Common Lisp.
A cons of the form (Source-Extension . Binary-Extension). If the
system is unknown (as in *features* not known), defaults to lisp and
fasl.")

(defvar *system-extension*
  ;; MS-DOS systems can only handle three character extensions.
  #-ACLPC "system"
  #+ACLPC "sys"
  "The filename extension to use with systems.")


;;; The above variables and code should be extended to allow a list of
;;; valid extensions for each lisp implementation, instead of a single
;;; extension. When writing a file, the first extension should be used.
;;; But when searching for a file, every extension in the list should
;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and
;;; "lsp" (*load-source-types*) as source code extensions, and
;;; (c:backend-fasl-file-type c:*backend*)
;;; (c:backend-byte-fasl-file-type c:*backend*)
;;; and "fasl" as binary (object) file extensions (*load-object-types*).

;;; Note that the above code is used below in the LANGUAGE defstruct.

;;; There is no real support for this variable being nil, so don't change it.
;;; Note that in any event, the toplevel system (defined with defsystem)
;;; will have its dependencies delayed. Not having dependencies delayed
;;; might be useful if we define several systems within one defsystem.

(defvar *system-dependencies-delayed* t
  "If T, system dependencies are expanded at run time")


;;; Replace this with consp, dammit!
(defun non-empty-listp (list)
  (and list (listp list)))


;;; ********************************
;;; Component Operation Definition *
;;; ********************************
(eval-when (:compile-toplevel :load-toplevel :execute)

(defvar *version-dir* nil
  "The version subdir. bound in operate-on-system.")

(defvar *version-replace* nil
  "The version replace. bound in operate-on-system.")

(defvar *version* nil
  "Default version."))

(defvar *component-operations* (make-hash-table :test #'equal)
  "Hash table of (operation-name function) pairs.")

(defun component-operation (name &optional operation)
  (if operation
      (setf (gethash name *component-operations*) operation)
      (gethash name *component-operations*)))


;;; ********************************
;;; AFS @sys immitator *************
;;; ********************************

;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.
#-:mcl
(eval-when (compile load eval)
  ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo").
  ;; For example,
  ;;    <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)))))


(defvar *find-irix-version-script*
    "\"1,4 d\\
s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
/./,$ d\\
\"")


(defun operating-system-version ()
  #+(and :sgi :excl)
  (let* ((full-version (software-version))
         (blank-pos (search " " full-version))
         (os (subseq full-version 0 blank-pos))
         (version-rest (subseq full-version
                               (1+ blank-pos)))
         os-version)
    (setq blank-pos (search " " version-rest))
    (setq version-rest (subseq version-rest
                               (1+ blank-pos)))
    (setq blank-pos (search " " version-rest))
    (setq os-version (subseq version-rest 0 blank-pos))
    (setq version-rest (subseq version-rest
                               (1+ blank-pos)))
    (setq blank-pos (search " " version-rest))
    (setq version-rest (subseq version-rest
                               (1+ blank-pos)))
    (concatenate 'string
      os " " os-version))      ; " " version-rest
  #+(and :sgi :cmu :sbcl)
  (concatenate 'string
    (software-type)
    (software-version))
  #+(and :lispworks :irix)
  (let ((soft-type (software-type)))
    (if (equalp soft-type "IRIX5")
        (progn
          (foreign:call-system
            (format nil "versions ~A | sed -e ~A > ~A"
                         "eoe1"
                         *find-irix-version-script*
                         "irix-version")
            "/bin/csh")
          (with-open-file (s "irix-version")
                          (format nil "IRIX ~S"
                                  (read s))))
      soft-type))
  #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
  (software-type))


(defun compiler-version ()
  #+:lispworks (concatenate 'string
                "lispworks" " " (lisp-implementation-version))
  #+excl      (concatenate 'string
                "excl" " " excl::*common-lisp-version-number*)
  #+sbcl      (concatenate 'string
                           "sbcl" " " (lisp-implementation-version))
  #+cmu       (concatenate 'string
                "cmu" " " (lisp-implementation-version))
  #+scl       (concatenate 'string
                "scl" " " (lisp-implementation-version))

  #+kcl       "kcl"
  #+IBCL      "ibcl"
  #+akcl      "akcl"
  #+gcl       "gcl"
  #+ecl       "ecl"
  #+lucid     "lucid"
  #+ACLPC     "aclpc"
  #+CLISP     "clisp"
  #+Xerox     "xerox"
  #+symbolics "symbolics"
  #+mcl       "mcl"
  #+coral     "coral"
  #+gclisp    "gclisp"
  )


(defun afs-binary-directory (root-directory)
  ;; Function for obtaining the directory AFS's @sys feature would have
  ;; chosen when we're not in AFS. This function is useful as the argument
  ;; to :binary-pathname in defsystem. For example,
  ;; :binary-pathname (afs-binary-directory "scanner/")
  (let ((machine (machine-type-translation
                  #-(and :sgi :allegro-version>= (version>= 4 2))
                  (machine-type)
                  #+(and :sgi :allegro-version>= (version>= 4 2))
                  (machine-version)))
        (software (software-type-translation
                   #-(and :sgi (or :cmu :sbcl :scl
                                   (and :allegro-version>= (version>= 4 2))))
                   (software-type)
                   #+(and :sgi (or :cmu :sbcl :scl
                                   (and :allegro-version>= (version>= 4 2))))
                   (operating-system-version)))
        (lisp (compiler-type-translation (compiler-version))))
    ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
    (setq root-directory (namestring root-directory))
    (setq root-directory (ensure-trailing-slash root-directory))
    (format nil "~A~@[~A~]~@[~A/~]"
            root-directory
            *bin-subdir*
            (if *multiple-lisp-support*
                (afs-component machine software lisp)
              (afs-component machine software)))))

(defun afs-source-directory (root-directory &optional version-flag)
  ;; Function for obtaining the directory AFS's @sys feature would have
  ;; chosen when we're not in AFS. This function is useful as the argument
  ;; to :source-pathname in defsystem.
  (setq root-directory (namestring root-directory))
  (setq root-directory (ensure-trailing-slash root-directory))
  (format nil "~A~@[~A/~]"
          root-directory
          (and version-flag (translate-version *version*))))


(defun null-string (s)
  (when (stringp s)
    (string-equal s "")))


(defun ensure-trailing-slash (dir)
  (if (and dir
           (not (null-string dir))
           (not (char= (char dir
                             (1- (length dir)))
                       #\/))
           (not (char= (char dir
                             (1- (length dir)))
                       #\\))
           )
      (concatenate 'string dir "/")
      dir))


(defun afs-component (machine software &optional lisp)
  (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
            machine
            (or software "mach")
            lisp))


(defvar *machine-type-alist* (make-hash-table :test #'equal)
  "Hash table for retrieving the machine-type")

(defun machine-type-translation (name &optional operation)
  (if operation
      (setf (gethash (string-upcase name) *machine-type-alist*) operation)
      (gethash (string-upcase name) *machine-type-alist*)))


(machine-type-translation "IBM RT PC"                        "rt")
(machine-type-translation "DEC 3100"                         "pmax")
(machine-type-translation "DEC VAX-11"                       "vax")
(machine-type-translation "DECstation"                       "pmax")
(machine-type-translation "Sun3"                             "sun3")
(machine-type-translation "Sun-4"                            "sun4")
(machine-type-translation "MIPS Risc"                        "mips")
(machine-type-translation "SGI"                              "sgi")
(machine-type-translation "Silicon Graphics Iris 4D"         "sgi")
(machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi")
(machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi")
(machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi")
(machine-type-translation "IP22"                             "sgi")
;;; MIPS R4000 Processor Chip Revision: 3.0
;;; MIPS R4400 Processor Chip Revision: 5.0
;;; MIPS R4600 Processor Chip Revision: 1.0
(machine-type-translation "IP20"                             "sgi")
;;; MIPS R4000 Processor Chip Revision: 3.0
(machine-type-translation "IP17"                             "sgi")
;;; MIPS R4000 Processor Chip Revision: 2.2
(machine-type-translation "IP12"                             "sgi")
;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
(machine-type-translation "IP7"                              "sgi")
;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0

(machine-type-translation "x86"                              "x86")
;;; ACL
(machine-type-translation "IBM PC Compatible"                "x86")
;;; LW
(machine-type-translation "I686"                             "x86")
;;; LW
(machine-type-translation "PC/386"                           "x86")
;;; CLisp Win32

#+(and :lucid :sun :mc68000)
(machine-type-translation "unknown"     "sun3")


(defvar *software-type-alist* (make-hash-table :test #'equal)
  "Hash table for retrieving the software-type")

(defun software-type-translation (name &optional operation)
  (if operation
      (setf (gethash (string-upcase name) *software-type-alist*) operation)
      (gethash (string-upcase name) *software-type-alist*)))


(software-type-translation "BSD UNIX"      "mach") ; "unix"
(software-type-translation "Ultrix"        "mach") ; "ultrix"
(software-type-translation "SunOS"         "SunOS")
(software-type-translation "MACH/4.3BSD"   "mach")
(software-type-translation "IRIX System V" "irix") ; (software-type)
(software-type-translation "IRIX5"         "irix5")
;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version)

(software-type-translation "IRIX 5.2" "irix5")
(software-type-translation "IRIX 5.3" "irix5")
(software-type-translation "IRIX5.2"  "irix5")
(software-type-translation "IRIX5.3"  "irix5")

(software-type-translation "Linux" "linux") ; Lispworks for Linux
(software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL
(software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32")
(software-type-translation "Windows NT" "win32") ; LW for Windows
(software-type-translation "ANSI C program" "ansi-c") ; CLISP
(software-type-translation "C compiler" "ansi-c") ; CLISP for Win32

(software-type-translation nil             "")

#+:lucid
(software-type-translation "Unix"
                           #+:lcl4.0 "4.0"
                           #+(and :lcl3.0 (not :lcl4.0)) "3.0")


(defvar *compiler-type-alist* (make-hash-table :test #'equal)
  "Hash table for retrieving the Common Lisp type")

(defun compiler-type-translation (name &optional operation)
  (if operation
      (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
    (gethash (string-upcase name) *compiler-type-alist*)))


(compiler-type-translation "lispworks 3.2.1"         "lispworks")
(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
(compiler-type-translation "lispworks 4.2.0"         "lispworks")


#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (or (find :case-sensitive common-lisp:*features*)
              (find :case-insensitive common-lisp:*features*))
    (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
            (eq excl:*current-case-mode* :case-sensitive-upper))
        (push :case-sensitive common-lisp:*features*)
      (push :case-insensitive common-lisp:*features*))))


#+(and allegro case-sensitive ics)
(compiler-type-translation "excl 6.1" "excl-m")
#+(and allegro case-sensitive (not ics))
(compiler-type-translation "excl 6.1" "excl-m8")

#+(and allegro case-insensitive ics)
(compiler-type-translation "excl 6.1" "excl-a")
#+(and allegro case-insensitive (not ics))
(compiler-type-translation "excl 6.1" "excl-a8")

(compiler-type-translation "excl 4.2" "excl")
(compiler-type-translation "excl 4.1" "excl")
(compiler-type-translation "cmu 17f" "cmu")
(compiler-type-translation "cmu 17e" "cmu")
(compiler-type-translation "cmu 17d" "cmu")


;;; ********************************
;;; System Names *******************
;;; ********************************

;;; If you use strings for system names, be sure to use the same case
;;; as it appears on disk, if the filesystem is case sensitive.

(defun canonicalize-system-name (name)
  ;; Originally we were storing systems using GET. This meant that the
  ;; name of a system had to be a symbol, so we interned the symbols
  ;; in the keyword package to avoid package dependencies. Now that we're
  ;; storing the systems in a hash table, we've switched to using strings.
  ;; Since the hash table is case sensitive, we use uppercase strings.
  ;; (Names of modules and files may be symbols or strings.)
  #||(if (keywordp name)
      name
      (intern (string-upcase (string name)) "KEYWORD"))||#
  (if (stringp name) (string-upcase name) (string-upcase (string name))))


(defvar *defined-systems* (make-hash-table :test #'equal)
  "Hash table containing the definitions of all known systems.")


(defun get-system (name)
  "Returns the definition of the system named NAME."
  (gethash (canonicalize-system-name name) *defined-systems*))


(defsetf get-system (name) (value)
  `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))


(defun undefsystem (name)
  "Removes the definition of the system named NAME."
  (remhash (canonicalize-system-name name) *defined-systems*))


(defun defined-systems ()
  "Returns a list of defined systems."
  (let ((result nil))
    (maphash #'(lambda (key value)
                 (declare (ignore key))
                 (push value result))
             *defined-systems*)
    result))


(defun defined-names-and-systems ()
  "Returns a a-list of defined systems along with their names."
  (loop for sname being the hash-keys of *defined-systems*
        using (hash-value s)
        collect (cons sname s)))


;;; ********************************
;;; Directory Pathname Hacking *****
;;; ********************************

;;; Unix example: An absolute directory starts with / while a
;;; relative directory doesn't. A directory ends with /, while
;;; a file's pathname doesn't. This is important 'cause
;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".

;;; I haven't been able to test the fix to the problem with symbolics
;;; hosts. Essentially, append-directories seems to have been tacking
;;; the default host onto the front of the pathname (e.g., mk::source-pathname
;;; gets a "B:" on front) and this overrides the :host specified in the
;;; component. The value of :host should override that specified in
;;; the :source-pathname and the default file server. If this doesn't
;;; fix things, specifying the host in the root pathname "F:>root-dir>"
;;; may be a good workaround.

;;; Need to verify that merging of pathnames where modules are located
;;; on different devices (in VMS-based VAXLisp) now works.

;;; Merge-pathnames works for VMS systems. In VMS systems, the directory
;;; part is enclosed in square brackets, e.g.,
;;;     "[root.child.child_child]" or "[root.][child.][child_child]"
;;; To concatenate directories merge-pathnames works as follows:
;;;     (merge-pathnames "" "[root]")               ==> "[root]"
;;;     (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
;;;     (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
;;;     (merge-pathnames "[root]file.ext" "[son]")  ==> "[root]file.ext"
;;; Thus the problem with the #-VMS code was that it was merging x y into
;;; [[x]][y] instead of [x][y] or [x]y.

;;; Miscellaneous notes:
;;;   On GCLisp, the following are equivalent:
;;;       "\\root\\subdir\\BAZ"
;;;       "/root/subdir/BAZ"
;;;   On VAXLisp, the following are equivalent:
;;;       "[root.subdir]BAZ"
;;;       "[root.][subdir]BAZ"
;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2

(defun new-append-directories (absolute-dir relative-dir)
  ;; Version of append-directories for CLtL2-compliant lisps. In particular,
  ;; they must conform to section 23.1.3 "Structured Directories". We are
  ;; willing to fix minor aberations in this function, but not major ones.
  ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
  ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
  (setf absolute-dir (or absolute-dir "")
        relative-dir (or relative-dir ""))
  (let* ((abs-dir (pathname absolute-dir))
         (rel-dir (pathname relative-dir))
         (host (pathname-host abs-dir))
         (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
                     (pathname-device rel-dir)
                   (pathname-device abs-dir)))
         (abs-directory (directory-to-list (pathname-directory abs-dir)))
         (abs-keyword (when (keywordp (car abs-directory))
                        (pop abs-directory)))
         ;; Stig (July 2001):
         ;; Somehow CLISP dies on the next line, but NIL is ok.
         (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
         (rel-directory (directory-to-list (pathname-directory rel-dir)))
         (rel-keyword (when (keywordp (car rel-directory))
                        (pop rel-directory)))
         ;; rtoy: Why should any Lisp want rel-file?  Shouldn't using
         ;; rel-name and rel-type work for every Lisp?
         #-(or :MCL :sbcl :clisp :cmu) (rel-file (file-namestring rel-dir))
         ;; Stig (July 2001);
         ;; These values seems to help clisp as well
         #+(or :MCL :sbcl :clisp :cmu) (rel-name (pathname-name rel-dir))
         #+(or :MCL :sbcl :clisp :cmu) (rel-type (pathname-type rel-dir))
         (directory nil))

    ;; TI Common Lisp pathnames can return garbage for file names because
    ;; of bizarreness in the merging of defaults.  The following code makes
    ;; sure that the name is a valid name by comparing it with the
    ;; pathname-name.  It also strips TI specific extensions and handles
    ;; the necessary case conversion.  TI maps upper back into lower case
    ;; for unix files!
    #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal)
             (setf abs-name (string-right-trim ".\17" (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 ".\17" (string-upcase rel-file)))
             (setf rel-file nil))
    ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
    ;; and filename "foo". The namestring of a pathname with
    ;; directory '(:absolute :root "foo") ignores everything after the
    ;; :root.
    #+(and allegro-version>= (version>= 4 0))
    (when (eq (car abs-directory) :root) (pop abs-directory))
    #+(and allegro-version>= (version>= 4 0))
    (when (eq (car rel-directory) :root) (pop rel-directory))

    (when (and abs-name (not (null-string abs-name))) ; was abs-name
      (cond ((and (null abs-directory) (null abs-keyword))
             #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
             (setf abs-directory (list abs-name)))
            (t
             (setf abs-directory (append abs-directory (list abs-name))))))
    (when (and (null abs-directory)
               (or (null abs-keyword)
                   ;; In Lucid, an abs-dir of nil gets a keyword of
                   ;; :relative since (pathname-directory (pathname ""))
                   ;; returns (:relative) instead of nil.
                   #+:lucid (eq abs-keyword :relative))
               rel-keyword)
      ;; The following feature switches seem necessary in CMUCL
      ;; Marco Antoniotti 19990707
      #+(or :sbcl :CMU)
      (if (typep abs-dir 'logical-pathname)
          (setf abs-keyword :absolute)
          (setf abs-keyword rel-keyword))
      #-(or :sbcl :CMU)
      (setf abs-keyword rel-keyword))
    (setf directory (append abs-directory rel-directory))
    (when abs-keyword (setf directory (cons abs-keyword directory)))
    (namestring
     (make-pathname :host host
                    :device device
                    :directory
                    directory
                    :name
                    #-(or :sbcl :MCL :clisp :cmu) rel-file
                    #+(or :sbcl :MCL :clisp :cmu) rel-name

                    #+(or :sbcl :MCL :clisp :cmu) :type
                    #+(or :sbcl :MCL :clisp :cmu) rel-type
                    ))))


(defun directory-to-list (directory)
  ;; The directory should be a list, but nonstandard implementations have
  ;; been known to use a vector or even a string.
  (cond ((listp directory)
         directory)
        ((stringp directory)
         (cond ((find #\; directory)
                ;; It's probably a logical pathname, so split at the
                ;; semicolons:
                (split-string directory :item #\;))
               #+MCL
               ((and (find #\: directory)
                     (not (find #\/ directory)))
                ;; It's probably a MCL pathname, so split at the colons.
                (split-string directory :item #\:))
               (t
                ;; It's probably a unix pathname, so split at the slash.
                (split-string directory :item #\/))))
        (t
         (coerce directory 'list))))


(defparameter *append-dirs-tests*
  '("~/foo/" "baz/bar.lisp"
     "~/foo" "baz/bar.lisp"
     "/foo/bar/" "baz/barf.lisp"
     "/foo/bar/" "/baz/barf.lisp"
     "foo/bar/" "baz/barf.lisp"
     "foo/bar" "baz/barf.lisp"
     "foo/bar" "/baz/barf.lisp"
     "foo/bar/" "/baz/barf.lisp"
     "/foo/bar/" nil
     "foo/bar/" nil
     "foo/bar" nil
     "foo" nil
     "foo" ""
     nil "baz/barf.lisp"
     nil "/baz/barf.lisp"
     nil nil))


(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
  (do* ((dir-list test-dirs (cddr dir-list))
        (abs-dir (car dir-list) (car dir-list))
        (rel-dir (cadr dir-list) (cadr dir-list)))
      ((null dir-list) (values))
    (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
            abs-dir rel-dir (new-append-directories abs-dir rel-dir))))


#||
<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
     ;; KMR commented out because: when appending two logical pathnames,
     ;; using this code translates the first logical pathname then appends
     ;; the second logical pathname -- an error.
     #|
      ;; We need a reliable way to determine if a pathname is logical.
      ;; Allegro 4.1 does not recognize the syntax of a logical pathname
      ;;  as being logical unless its logical host is already defined.

      #+(or (and allegro-version>= (version>= 4 1))
            :logical-pathnames-mk)
      ((and absolute-directory
            (logical-pathname-p absolute-directory)
            relative-directory)
       ;; For use with logical pathnames package.
       (append-logical-directories-mk absolute-directory relative-directory))
     |#
      ((namestring-probably-logical absolute-directory)
       ;; A simplistic stab at handling logical pathnames
       (append-logical-pnames absolute-directory relative-directory))
      (t
       ;; In VMS, merge-pathnames actually does what we want!!!
       #+:VMS
       (namestring (merge-pathnames (or absolute-directory "")
                                    (or relative-directory "")))
       #+:macl1.3.2
       (namestring (make-pathname :directory absolute-directory
                                  :name relative-directory))
       ;; Cross your fingers and pray.
       #-(or :VMS :macl1.3.2)
       (new-append-directories absolute-directory relative-directory)))))


#+:logical-pathnames-mk
(defun append-logical-directories-mk (absolute-dir relative-dir)
  (lp:append-logical-directories absolute-dir relative-dir))


;;; append-logical-pathnames-mk --
;;; The following is probably still bogus and it does not solve the
;;; problem of appending two logical pathnames.
;;; Anyway, as per suggetsion by KMR, the function is not called
;;; anymore.
;;; Hopefully this will not cause problems for ACL.

#+(and (and allegro-version>= (version>= 4 1))
       (not :logical-pathnames-mk))
(defun append-logical-directories-mk (absolute-dir relative-dir)
  ;; We know absolute-dir and relative-dir are non nil.  Moreover
  ;; absolute-dir is a logical pathname.
  (setq absolute-dir (logical-pathname absolute-dir))
  (etypecase relative-dir
    (string (setq relative-dir (parse-namestring relative-dir)))
    (pathname #| do nothing |#))

  (translate-logical-pathname
   (merge-pathnames relative-dir absolute-dir)))


#| Old version 2002-03-02
#+(and (and allegro-version>= (version>= 4 1))
       (not :logical-pathnames-mk))
(defun append-logical-directories-mk (absolute-dir relative-dir)
  ;; We know absolute-dir and relative-dir are non nil.  Moreover
  ;; absolute-dir is a logical pathname.
  (setq absolute-dir (logical-pathname absolute-dir))
  (etypecase relative-dir
    (string (setq relative-dir (parse-namestring relative-dir)))
    (pathname #| do nothing |#))

  (translate-logical-pathname
   (make-pathname
    :host (or (pathname-host absolute-dir)
              (pathname-host relative-dir))
    :directory (append (pathname-directory absolute-dir)
                       (cdr (pathname-directory relative-dir)))
    :name (or (pathname-name absolute-dir)
              (pathname-name relative-dir))
    :type (or (pathname-type absolute-dir)
              (pathname-type relative-dir))
    :version (or (pathname-version absolute-dir)
                 (pathname-version relative-dir)))))

;; Old version
#+(and (and allegro-version>= (version>= 4 1))
       (not :logical-pathnames-mk))
(defun append-logical-directories-mk (absolute-dir relative-dir)
  (when (or absolute-dir relative-dir)
    (setq absolute-dir (logical-pathname (or absolute-dir ""))
          relative-dir (logical-pathname (or relative-dir "")))
    (translate-logical-pathname
     (make-pathname
      :host (or (pathname-host absolute-dir)
                (pathname-host relative-dir))
      :directory (append (pathname-directory absolute-dir)
                         (cdr (pathname-directory relative-dir)))
      :name (or (pathname-name absolute-dir)
                (pathname-name relative-dir))
      :type (or (pathname-type absolute-dir)
                (pathname-type relative-dir))
      :version (or (pathname-version absolute-dir)
                   (pathname-version relative-dir))))))
|#

;;; determines if string or pathname object is logical
#+:logical-pathnames-mk
(defun logical-pathname-p (thing)
  (eq (lp:pathname-host-type thing) :logical))

;;; From Kevin Layer for 4.1final.
#+(and (and allegro-version>= (version>= 4 1))
       (not :logical-pathnames-mk))
(defun logical-pathname-p (thing)
  (typep (parse-namestring thing) 'logical-pathname))

(defun pathname-logical-p (thing)
  (typecase thing
    (logical-pathname t)
    #+clisp ; CLisp has non conformant Logical Pathnames.
    (pathname (pathname-logical-p (namestring thing)))
    (string (and (= 1 (count #\: thing)) ; Shortcut.
                 (ignore-errors (translate-logical-pathname thing))
                 t))
    (t nil)))

;;; This affects only one thing.
;;; 19990707 Marco Antoniotti
;;; old version

(defun namestring-probably-logical (namestring)
  (and (stringp namestring)
       ;; unix pathnames don't have embedded semicolons
       (find #\; namestring)))
#||
;;; New version
(defun namestring-probably-logical (namestring)
  (and (stringp namestring)
       (typep (parse-namestring namestring) 'logical-pathname)))


;;; New new version
;;; 20000321 Marco Antoniotti
(defun namestring-probably-logical (namestring)
  (pathname-logical-p namestring))
||#


#|| This is incorrect, as it strives to keep strings around, when it
    shouldn't.  MERGE-PATHNAMES already DTRT.
(defun append-logical-pnames (absolute relative)
  (declare (type (or null string pathname) absolute relative))
  (let ((abs (if absolute
                 #-clisp (namestring absolute)
                 #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
                 ""))
        (rel (if relative (namestring relative) ""))
        )
    ;; Make sure the absolute directory ends with a semicolon unless
    ;; the pieces are null strings
    (unless (or (null-string abs) (null-string rel)
                (char= (char abs (1- (length abs)))
                       #\;))
      (setq abs (concatenate 'string abs ";")))
    ;; Return the concatenate pathnames
    (concatenate 'string abs rel)))
||#


(defun append-logical-pnames (absolute relative)
  (declare (type (or null string pathname) absolute relative))
  (let ((abs (if absolute
                 (pathname absolute)
                 (make-pathname :directory (list :absolute)
                                :name nil
                                :type nil)
                 ))
        (rel (if relative
                 (pathname relative)
                 (make-pathname :directory (list :relative)
                                :name nil
                                :type nil)
                 ))
        )
    ;; The following is messed up because CMUCL and LW use different
    ;; defaults for host (in particular LW uses NIL).  Thus
    ;; MERGE-PATHNAMES has legitimate different behaviors on both
    ;; implementations. Of course this is disgusting, but that is the
    ;; way it is and the rest tries to circumvent this crap.
    (etypecase abs
      (logical-pathname
       (etypecase rel
         (logical-pathname
          (namestring (merge-pathnames rel abs)))
         (pathname
          ;; The following potentially translates the logical pathname
          ;; very early, but we cannot avoid it.
          (namestring (merge-pathnames rel (translate-logical-pathname abs))))
         ))
      (pathname
       (namestring (merge-pathnames rel abs)))
      )))

#||
;;; This was a try at appending a subdirectory onto a directory.
;;; It failed. We're keeping this around to prevent future mistakes
;;; of a similar sort.
(defun merge-directories (absolute-directory relative-directory)
  ;; replace concatenate with something more intelligent
  ;; i.e., concatenation won't work with some directories.
  ;; it should also behave well if the parent directory
  ;; has a filename at the end, or if the relative-directory ain't relative
  (when absolute-directory
    (setq absolute-directory (pathname-directory absolute-directory)))
  (concatenate 'string
               (or absolute-directory "")
               (or relative-directory "")))
||#

#||
<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)
""

||#

;;; The following is a change proposed by DTC for SCL.
;;; Maybe it could be used all the time.

#-scl
(defun new-file-type (pathname type)
  ;; why not (make-pathname :type type :defaults pathname)?
  (make-pathname
   :host (pathname-host pathname)
   :device (pathname-device pathname)
   :directory (pathname-directory pathname)
   :name (pathname-name pathname)
   :type type
   :version (pathname-version pathname)))


#+scl
(defun new-file-type (pathname type)
  ;; why not (make-pathname :type type :defaults pathname)?
  (make-pathname
   :host (pathname-host pathname :case :common)
   :device (pathname-device pathname :case :common)
   :directory (pathname-directory pathname :case :common)
   :name (pathname-name pathname :case :common)
   :type (string-upcase type)
   :version (pathname-version pathname :case :common)))



;;; ********************************
;;; Component Defstruct ************
;;; ********************************

(defvar *source-pathname-default* nil
  "Default value of :source-pathname keyword in DEFSYSTEM. Set this to
   \"\" to avoid having to type :source-pathname \"\" all the time.")

(defvar *binary-pathname-default* nil
  "Default value of :binary-pathname keyword in DEFSYSTEM.")


(defstruct (topological-sort-node (:conc-name topsort-))
  (color :white :type (member :gray :black :white))
  )


(defparameter *component-evaluated-slots*
  '(:source-root-dir :source-pathname :source-extension
    :binary-root-dir :binary-pathname :binary-extension))


(defparameter *component-form-slots*
  '(:initially-do :finally-do :compile-form :load-form))


(defstruct (component (:include topological-sort-node)
                      (:print-function print-component))
  (type :file     ; to pacify the CMUCL compiler (:type is alway supplied)
        :type (member :defsystem
                      :system
                      :subsystem
                      :module
                      :file
                      :private-file
                      ))
  (name nil :type (or symbol string))
  (indent 0 :type (mod 1024))           ; Number of characters of indent in
                                        ; verbose output to the user.
  host                                  ; The pathname host (i.e., "/../a").
  device                                ; The pathname device.
  source-root-dir                       ; Relative or absolute (starts
                                        ; with "/"), directory or file
                                        ; (ends with "/").
  (source-pathname *source-pathname-default*)
  source-extension                      ; A string, e.g., "lisp"
                                        ; if NIL, inherit
  (binary-pathname *binary-pathname-default*)
  binary-root-dir
  binary-extension                      ; A string, e.g., "fasl". If
                                        ; NIL, uses default for
                                        ; machine-type.
  package                               ; Package for use-package.

  ;; The following three slots are used to provide for alternate compilation
  ;; and loading functions for the files contained within a component. If
  ;; a component has a compiler or a loader specified, those functions are
  ;; used. Otherwise the functions are derived from the language. If no
  ;; language is specified, it defaults to Common Lisp (:lisp). Other current
  ;; possible languages include :scheme (PseudoScheme) and :c, but the user
  ;; can define additional language mappings. Compilation functions should
  ;; accept a pathname argument and a :output-file keyword; loading functions
  ;; just a pathname argument. The default functions are #'compile-file and
  ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to
  ;; mix languages.
  (language nil :type (or null symbol))
  (compiler nil :type (or null symbol function))
  (loader   nil :type (or null symbol function))
  (compiler-options nil :type list)     ; A list of compiler options to
                                        ; use for compiling this
                                        ; component.  These must be
                                        ; keyword options supported by
                                        ; the compiler.

  (components () :type list)            ; A list of components
                                        ; comprising this component's
                                        ; definition.
  (depends-on () :type list)            ; A list of the components
                                        ; this one depends on. may
                                        ; refer only to the components
                                        ; at the same level as this
                                        ; one.
  proclamations                         ; Compiler options, such as
                                        ; '(optimize (safety 3)).
  (initially-do (lambda () nil))        ; Form to evaluate before the
                                        ; operation.
  (finally-do (lambda () nil))          ; Form to evaluate after the operation.
  (compile-form (lambda () nil))        ; For foreign libraries.
  (load-form (lambda () nil))           ; For foreign libraries.

  ;; load-time                          ; The file-write-date of the
                                        ; binary/source file loaded.

  ;; If load-only is T, will not compile the file on operation :compile.
  ;; In other words, for files which are :load-only T, loading the file
  ;; satisfies any demand to recompile.
  load-only                             ; If T, will not compile this
                                        ; file on operation :compile.
  ;; If compile-only is T, will not load the file on operation :compile.
  ;; Either compiles or loads the file, but not both. In other words,
  ;; compiling the file satisfies the demand to load it. This is useful
  ;; for PCL defmethod and defclass definitions, which wrap a
  ;; (eval-when (compile load eval) ...) around the body of the definition.
  ;; This saves time in some lisps.
  compile-only                          ; If T, will not load this
                                        ; file on operation :compile.
  #|| ISI Extension ||#
  load-always                           ; If T, will force loading
                                        ; even if file has not
                                        ; changed.
  ;; PVE: add banner
  (banner nil :type (or null string))

  (documentation nil :type (or null string)) ; Optional documentation slot
  (long-documentation nil :type (or null string)) ; Optional long documentation slot

  ;; Added AUTHOR, MAINTAINER, VERSION and LICENCE slots.
  (author nil :type (or null string))
  (licence nil :type (or null string))
  (maintainer nil :type (or null string))
  (version nil :type (or null string))

  ;; Added NON-REQUIRED-P slot.  Useful for optional items.
  (non-required-p nil :type boolean)    ; If T a missing file or
                                        ; sub-directory will not cause
                                        ; an error.
  )


;;; To allow dependencies from "foreign systems" like ASDF or one of
;;; the proprietary ones like ACL or LW.

(defstruct (foreign-system (:include component (type :system)))
  kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...)
  object ; The actual foreign system object.
  )


(defun register-foreign-system (name &key representation kind)
  (declare (type (or symbol string) name))
  (let ((fs (make-foreign-system :name name
                                 :kind kind
                                 :object representation)))
    (setf (get-system name) fs)))



(define-condition missing-component (simple-condition)
  ((name :reader missing-component-name
         :initarg :name)
   (component :reader missing-component-component
              :initarg :component)
   )
  #-gcl (:default-initargs :component nil)
  (:report (lambda (mmc stream)
             (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
                     (missing-component-name mmc)
                     (missing-component-component mmc))))
  )

(define-condition missing-module (missing-component)
  ()
  (:report (lambda (mmc stream)
             (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
                     (missing-component-name mmc)
                     (missing-component-component mmc))))
  )

(define-condition missing-system (missing-module)
  ()
  (:report (lambda (msc stream)
             (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
                     (missing-component-name msc)
                     (missing-component-component msc))))
  )



(defvar *file-load-time-table* (make-hash-table :test #'equal)
  "Hash table of file-write-dates for the system definitions and files in the system definitions.")


(defun component-load-time (component)
  (when component
    (etypecase component
      (string    (gethash component *file-load-time-table*))
      (pathname (gethash (namestring component) *file-load-time-table*))
      (component
       (ecase (component-type component)
         (:defsystem
          (let* ((name (component-name component))
                 (path (when name (compute-system-path name nil))))
            (declare (type (or string pathname null) path))
            (when path
              (gethash (namestring path) *file-load-time-table*))))
         ((:file :private-file)
          ;; Use only :source pathname to identify component's
          ;; load time.
          (let ((path (component-full-pathname component :source)))
            (when path
              (gethash path *file-load-time-table*)))))))))

#-(or :cmu)
(defsetf component-load-time (component) (value)
  `(when ,component
    (etypecase ,component
      (string   (setf (gethash ,component *file-load-time-table*) ,value))
      (pathname (setf (gethash (namestring (the pathname ,component))
                               *file-load-time-table*)
                      ,value))
      (component
       (ecase (component-type ,component)
         (:defsystem
          (let* ((name (component-name ,component))
                 (path (when name (compute-system-path name nil))))
            (declare (type (or string pathname null) path))
            (when path
              (setf (gethash (namestring path) *file-load-time-table*)
                    ,value))))
         ((:file :private-file)
          ;; Use only :source pathname to identify file.
          (let ((path (component-full-pathname ,component :source)))
            (when path
              (setf (gethash path *file-load-time-table*)
                    ,value)))))))
    ,value))

#+(or :cmu)
(defun (setf component-load-time) (value component)
  (declare
   (type (or null string pathname component) component)
   (type (or unsigned-byte null) value))
  (when component
    (etypecase component
      (string   (setf (gethash component *file-load-time-table*) value))
      (pathname (setf (gethash (namestring (the pathname component))
                               *file-load-time-table*)
                      value))
      (component
       (ecase (component-type component)
         (:defsystem
             (let* ((name (component-name component))
                    (path (when name (compute-system-path name nil))))
               (declare (type (or string pathname null) path))
               (when path
                 (setf (gethash (namestring path) *file-load-time-table*)
                       value))))
         ((:file :private-file)
          ;; Use only :source pathname to identify file.
          (let ((path (component-full-pathname component :source)))
            (when path
              (setf (gethash path *file-load-time-table*)
                    value)))))))
    value))


;;; compute-system-path --

(defun compute-system-path (module-name definition-pname)
  (let* ((module-string-name
          (etypecase module-name
            (symbol (string-downcase
                     (string module-name)))
            (string module-name)))

         (file-pathname
          (make-pathname :name module-string-name
                         :type *system-extension*))

         (lib-file-pathname
          (make-pathname :directory (list :relative module-string-name)
                         :name module-string-name
                         :type *system-extension*))
         )
    (or (when definition-pname          ; given pathname for system def
          (probe-file definition-pname))
        ;; Then the central registry. Note that we also check the current
        ;; directory in the registry, but the above check is hard-coded.
        (cond (*central-registry*
               (if (listp *central-registry*)
                   (dolist (registry *central-registry*)
                     (let* ((reg-path (registry-pathname registry))
                            (file (or (probe-file
                                       (append-directories
                                        reg-path file-pathname))
                                      (probe-file
                                       (append-directories
                                        reg-path lib-file-pathname)))))
                       (when file (return file))))
                   (or (probe-file (append-directories *central-registry*
                                                       file-pathname))
                       (probe-file (append-directories *central-registry*
                                                       lib-file-pathname))
                       ))
               )
              (t
               ;; No central registry. Assume current working directory.
               ;; Maybe this should be an error?
               (or (probe-file file-pathname)
                   (probe-file lib-file-pathname)))))
    ))


(defun system-definition-pathname (system-name)
  (let ((system (ignore-errors (find-system system-name :error))))
    (if system
        (let ((system-def-pathname
               (make-pathname
                :type "system"
                :defaults (pathname (component-full-pathname system :source))))
              )
          (values system-def-pathname
                  (probe-file system-def-pathname)))
        (values nil nil))))




#|

 (defun compute-system-path (module-name definition-pname)
  (let* ((filename (format nil "~A.~A"
                           (if (symbolp module-name)
                               (string-downcase (string module-name))
                             module-name)
                           *system-extension*)))
    (or (when definition-pname          ; given pathname for system def
          (probe-file definition-pname))
        ;; Then the central registry. Note that we also check the current
        ;; directory in the registry, but the above check is hard-coded.
        (cond (*central-registry*
               (if (listp *central-registry*)
                   (dolist (registry *central-registry*)
                     (let ((file (probe-file
                                  (append-directories
                                   (registry-pathname registry) filename))))
                       (when file (return file))))
                 (probe-file (append-directories *central-registry*
                                                 filename))))
              (t
               ;; No central registry. Assume current working directory.
               ;; Maybe this should be an error?
               (probe-file filename))))))
|#


(defvar *reload-systems-from-disk* t
  "If T, always tries to reload newer system definitions from disk.
   Otherwise first tries to find the system definition in the current
   environment.")

(defun find-system (system-name &optional (mode :ask) definition-pname)
  "Returns the system named SYSTEM-NAME.
If not already loaded, loads it, depending on the value of
*RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK,
:ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default.
This allows OPERATE-ON-SYSTEM to work on non-loaded as well as
loaded system definitions. DEFINITION-PNAME is the pathname for
the system definition, if provided."
  (ecase mode
    (:ask
     (or (get-system system-name)
         (when (y-or-n-p-wait
                #\y 20
                "System ~A not loaded. Shall I try loading it? "
                system-name)
           (find-system system-name :load definition-pname))))
    (:error
     (or (get-system system-name)
         (error 'missing-system :name system-name)))
    (:load-or-nil
     (let ((system (get-system system-name)))
       ;; (break "System ~S ~S." system-name system)
       (or (unless *reload-systems-from-disk* system)
           ;; If SYSTEM-NAME is a symbol, it will lowercase the
           ;; symbol's string.
           ;; If SYSTEM-NAME is a string, it doesn't change the case of the
           ;; string. So if case matters in the filename, use strings, not
           ;; symbols, wherever the system is named.
           (when (foreign-system-p system)
             (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
                   system)
             (return-from find-system nil))
           (let ((path (compute-system-path system-name definition-pname)))
             (when (and path
                        (or (null system)
                            (null (component-load-time path))
                            (< (component-load-time path)
                               (file-write-date path))))
               (tell-user-generic
                (format nil "Loading system ~A from file ~A"
                        system-name
                        path))
               (load path)
               (setf system (get-system system-name))
               (when system
                 (setf (component-load-time path)
                       (file-write-date path))))
             system)
           system)))
    (:load
     (or (unless *reload-systems-from-disk* (get-system system-name))
         (when (foreign-system-p (get-system system-name))
           (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
                 (get-system system-name))
           (return-from find-system nil))
         (or (find-system system-name :load-or-nil definition-pname)
             (error "Can't find system named ~s." system-name))))))


(defun print-component (component stream depth)
  (declare (ignore depth))
  (format stream "#<~:@(~A~): ~A>"
          (component-type component)
          (component-name component)))


(defun describe-system (name &optional (stream *standard-output*))
  "Prints a description of the system to the stream. If NAME is the
   name of a system, gets it and prints a description of the system.
   If NAME is a component, prints a description of the component."
  (let ((system (if (typep name 'component) name (find-system name :load))))
    (format stream "~&~A ~A: ~
                    ~@[~&   Host: ~A~]~
                    ~@[~&   Device: ~A~]~
                    ~@[~&   Package: ~A~]~
                    ~&   Source: ~@[~A~] ~@[~A~] ~@[~A~]~
                    ~&   Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
                    ~@[~&   Depends On: ~A ~]~&   Components:~{~15T~A~&~}"
            (component-type system)
            (component-name system)
            (component-host system)
            (component-device system)
            (component-package system)
            (component-root-dir system :source)
            (component-pathname system :source)
            (component-extension system :source)
            (component-root-dir system :binary)
            (component-pathname system :binary)
            (component-extension system :binary)
            (component-depends-on system)
            (component-components system))
    #||(when recursive
      (dolist (component (component-components system))
        (describe-system component stream recursive)))||#
    system))


(defun canonicalize-component-name (component)
  ;; Within the component, the name is a string.
  (if (typep (component-name component) 'string)
      ;; Unnecessary to change it, so just return it, same case
      (component-name component)
    ;; Otherwise, make it a downcase string -- important since file
    ;; names are often constructed from component names, and unix
    ;; prefers lowercase as a default.
    (setf (component-name component)
          (string-downcase (string (component-name component))))))


(defun component-pathname (component type)
  (when component
    (ecase type
      (:source (component-source-pathname component))
      (:binary (component-binary-pathname component))
      (:error  (component-error-pathname component)))))


(defun component-error-pathname (component)
  (let ((binary (component-pathname component :binary)))
    (new-file-type binary *compile-error-file-type*)))

(defsetf component-pathname (component type) (value)
  `(when ,component
     (ecase ,type
       (:source (setf (component-source-pathname ,component) ,value))
       (:binary (setf (component-binary-pathname ,component) ,value)))))


(defun component-root-dir (component type)
  (when component
    (ecase type
      (:source (component-source-root-dir component))
      ((:binary :error) (component-binary-root-dir component))
      )))

(defsetf component-root-dir (component type) (value)
  `(when ,component
     (ecase ,type
       (:source (setf (component-source-root-dir ,component) ,value))
       (:binary (setf (component-binary-root-dir ,component) ,value)))))


(defvar *source-pathnames-table* (make-hash-table :test #'equal)
  "Table which maps from components to full source pathnames.")


(defvar *binary-pathnames-table* (make-hash-table :test #'equal)
  "Table which maps from components to full binary pathnames.")


(defparameter *reset-full-pathname-table* t
  "If T, clears the full-pathname tables before each call to OPERATE-ON-SYSTEM.
Setting this to NIL may yield faster performance after multiple calls
to LOAD-SYSTEM and COMPILE-SYSTEM, but could result in changes to
system and language definitions to not take effect, and so should be
used with caution.")


(defun clear-full-pathname-tables ()
  (clrhash *source-pathnames-table*)
  (clrhash *binary-pathnames-table*))


(defun component-full-pathname (component type &optional (version *version*))
  (when component
    (case type
      (:source
       (let ((old (gethash component *source-pathnames-table*)))
         (or old
             (let ((new (component-full-pathname-i component type version)))
               (setf (gethash component *source-pathnames-table*) new)
               new))))
      (:binary
        (let ((old (gethash component *binary-pathnames-table*)))
         (or old
             (let ((new (component-full-pathname-i component type version)))
               (setf (gethash component *binary-pathnames-table*) new)
               new))))
      (otherwise
       (component-full-pathname-i component type version)))))


(defun component-full-pathname-i (component type
                                            &optional (version *version*)
                                            &aux version-dir version-replace)
  ;; If the pathname-type is :binary and the root pathname is null,
  ;; distribute the binaries among the sources (= use :source pathname).
  ;; This assumes that the component's :source pathname has been set
  ;; before the :binary one.
  (if version
      (multiple-value-setq (version-dir version-replace)
        (translate-version version))
      (setq version-dir *version-dir* version-replace *version-replace*))
  ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace)
  (let ((pathname
         (append-directories
          (if version-replace
              version-dir
              (append-directories (component-root-dir component type)
                                  version-dir))
          (component-pathname component type))))

    ;; When a logical pathname is used, it must first be translated to
    ;; a physical pathname. This isn't strictly correct. What should happen
    ;; is we fill in the appropriate slots of the logical pathname, and
    ;; then return the logical pathname for use by compile-file & friends.
    ;; But calling translate-logical-pathname to return the actual pathname
    ;; should do for now.

    ;; (format t "pathname = ~A~%" pathname)
    ;; (format t "type = ~S~%" (component-extension component type))

    ;; 20000303 Marco Antoniotti
    ;; Changed the following according to suggestion by Ray Toy.  I
    ;; just collapsed the tests for "logical-pathname-ness" into a
    ;; single test (heavy, but probably very portable) and added the
    ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES
    ;; beacuse of possible null names (e.g. :defsystem components)
    ;; causing problems with the subsequenct call to NAMESTRING.
    ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname)

    ;; 20050309 Marco Antoniotti
    ;; The treatment of PATHNAME-HOST and PATHNAME-DEVICE in the call
    ;; to MAKE-PATHNAME in the T branch is bogus.   COMPONENT-DEVICE
    ;; and COMPONENT-HOST must respect the ANSI definition, hence,
    ;; they cannot be PATHNAMEs.  The simplification of the code is
    ;; useful.  SCL compatibility may be broken, but I doubt it will.

    ;; 20050310 Marco Antoniotti
    ;; After a suggestion by David Tolpin, the code is simplified even
    ;; more, and the logic should be now more clear: use the user
    ;; supplied pieces of the pathname if non nil.

    ;; 20050613 Marco Antoniotti
    ;; Added COMPONENT-NAME extraction to :NAME part, in case the
    ;; PATHNAME-NAME is NIL.

    (cond ((pathname-logical-p pathname) ; See definition of test above.
           (setf pathname
                 (merge-pathnames pathname
                                  (make-pathname
                                   :name (component-name component)
                                   :type (component-extension component
                                                              type))))
           (namestring (translate-logical-pathname pathname)))
          (t
           (namestring
            (make-pathname :host (or (component-host component)
                                     (pathname-host pathname))

                           :directory (pathname-directory pathname
                                                          #+scl :case
                                                          #+scl :common
                                                          )

                           :name (or (pathname-name pathname
                                                    #+scl :case
                                                    #+scl :common
                                                    )
                                     (component-name component))

                           :type
                           #-scl (component-extension component type)
                           #+scl (string-upcase
                                  (component-extension component type))

                           :device
                           #+sbcl
                           :unspecific
                           #-(or :sbcl)
                           (or (component-device component)
                               (pathname-device pathname
                                                #+scl :case
                                                #+scl :common
                                                ))
                           ;; :version :newest
                           ))))))


#-lispworks
(defun translate-version (version)
  ;; Value returns the version directory and whether it replaces
  ;; the entire root (t) or is a subdirectory.
  ;; Version may be nil to signify no subdirectory,
  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
  ;; specifies a subdirectory of the root, or
  ;; a string, which replaces the root.
  (cond ((null version)
         (values "" nil))
        ((symbolp version)
         (values (let ((sversion (string version)))
                   (if (find-if #'lower-case-p sversion)
                       sversion
                       (string-downcase sversion)))
                 nil))
        ((stringp version)
         (values version t))
        (t (error "~&; Illegal version ~S" version))))


;;; Looks like LW has a bug in MERGE-PATHNAMES.
;;;
;;;  (merge-pathnames "" "LP:foo;bar;") ==> "LP:"
;;;
;;; Which is incorrect.
;;; The change here ensures that the result of TRANSLATE-VERSION is
;;; appropriate.

#+lispworks
(defun translate-version (version)
  ;; Value returns the version directory and whether it replaces
  ;; the entire root (t) or is a subdirectory.
  ;; Version may be nil to signify no subdirectory,
  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
  ;; specifies a subdirectory of the root, or
  ;; a string, which replaces the root.
  (cond ((null version)
         (values (pathname "") nil))
        ((symbolp version)
         (values (let ((sversion (string version)))
                   (if (find-if #'lower-case-p sversion)
                       (pathname sversion)
                       (pathname (string-downcase sversion))))
                 nil))
        ((stringp version)
         (values (pathname version) t))
        (t (error "~&; Illegal version ~S" version))))


(defun component-extension (component type &key local)
  (ecase type
    (:source (or (component-source-extension component)
                 (unless local
                   (default-source-extension component)) ; system default
                 ;; (and (component-language component))
                 ))
    (:binary (or (component-binary-extension component)
                 (unless local
                   (default-binary-extension component)) ; system default
                 ;; (and (component-language component))
                 ))
    (:error  *compile-error-file-type*)))


(defsetf component-extension (component type) (value)
  `(ecase ,type
     (: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))))

    ;; Set up :compiler-options attribute
    (unless (find :compiler-options definition-body)
      ;; If the :compiler-option attribute wasn't specified,
      ;; inherit it from the parent.  If no parent, default it to NIL.
      (setf (component-compiler-options component)
            (when parent
              (component-compiler-options parent))))

    #|| ISI Extension ||#
    ;; Set up :load-always attribute
    (unless (find :load-always definition-body)
      ;; If the :load-always attribute wasn't specified,
      ;; inherit it from the parent. If no parent, default it to nil.
      (setf (component-load-always component)
            (when parent
              (component-load-always 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)
      #|(unless (component-language component)
        (setf (component-language component) :lisp))|#)

    ;; 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))


;;; preprocess-component-definition --
;;; New function introduced to manipulate the "evaluated" slots as per
;;; SDS' suggestions.
;;; 20050824

(defun preprocess-component-definition (definition-body)
  `(list* ,@(loop for slot in *component-evaluated-slots*
                  for value = (getf definition-body slot)
                  when value
                    do (remf definition-body slot)
                    and nconc `(,slot ,value))
          ,@(loop for slot in *component-form-slots*
                  for form = (getf definition-body slot)
                  do (remf definition-body slot)
                  nconc `(,slot (lambda () ,form)))
          ',definition-body))


;;; defsystem --
;;; The main macro.
;;;
;;; 2002-11-22 Marco Antoniotti
;;; Added code to achieve a first cut "pathname less" operation,
;;; following the ideas in ASDF.  If the DEFSYSTEM form is loaded from
;;; a file, then the location of the file (intended as a directory) is
;;; computed from *LOAD-PATHNAME* and stored as the :SOURCE-PATHNAME
;;; of the system.

(defmacro defsystem (name &rest definition-body)
  (unless (find :source-pathname definition-body)
    (setf definition-body
          (list* :source-pathname
                 '(when #-gcl *load-pathname* #+gcl si::*load-pathname*
                    (make-pathname :name nil
                                   :type nil
                                   :defaults
                                   #-gcl *load-pathname*
                                   #+gcl si::*load-pathname*
                                   ))
                 definition-body)))
  `(create-component :defsystem ',name
                     ,(preprocess-component-definition 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))
            (pathname-host *default-pathname-defaults*)))
  (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 #| (component-language component) |#
                                 t
                                 ) ; local default
            (when (component-language component)
              (default-source-extension component))
            (when parent                ; parent's default
              (component-extension parent :source))))
  (setf (component-extension component :binary)
        (or (component-extension component :binary
                                 :local #| (component-language component) |#
                                 t
                                 ) ; local default
            (when (component-language component)
              (default-binary-extension component))
            (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))


;;; generate-component-pathnames --
;;; 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
                           (first definition)
                           ;; (preprocess-component-definition (rest definition)) ; Not working.
                           (rest definition)
                           parent
                           indent))
        ((listp definition)
         ;; Otherwise, it is (we hope) a normal form definition
         (create-component (first definition)   ; type
                           (second definition)  ; name

                           ;; definition body
                           ;; (preprocess-component-definition (cddr definition)) ; Not working.
                           (cddr definition)

                           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