From: Reed Hastings
Subject: Public defsystem
Date: 
Message-ID: <23321@coherent.com>
Does anyone know where I can get a public domain defsystem
facility?

Thanks,
  -Reed.

From: Richard Harris
Subject: Re: Public defsystem
Date: 
Message-ID: <1175@rpi.edu>
In article <·····@coherent.com> ········@coherent.com (Reed Hastings) writes:
>
>Does anyone know where I can get a public domain defsystem
>facility?
>
>Thanks,
>  -Reed.

Here are three:
  arisia.xerox.com:pcl/defsys.lisp
  rascal.ics.utexas.edu:pub/akcl-1-100.tar.Z  lsp/make.lsp
  turing.cs.rpi.edu:pub/lisp/xkcl.tar.Z  lsp/system.lsp
I am sure there are others around.

  Rick Harris

Here is all the documentation I can find on these three:
------------------------------------------------------------
  arisia.xerox.com:pcl/defsys.lisp
     ;;; Yet Another Sort Of General System Facility and friends.
     ;;;
     ;;; The entry points are defsystem and operate-on-system.  defsystem is used
     ;;; to define a new system and the files with their load/compile constraints.
     ;;; Operate-on-system is used to operate on a system defined that has been
     ;;; defined by defsystem.  For example:
     #||
     
     (defsystem my-very-own-system
     	   "/usr/myname/lisp/"
       ((classes   (precom)           ()                ())
        (methods   (precom classes)   (classes)         ())
        (precom    ()                 (classes methods) (classes methods))))
     
     This defsystem should be read as follows:
     
     * Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
       should be in the directory "/usr/me/lisp/".  There are three files
       in the system, there are named classes, methods and precom.  (The
       extension the filenames have depends on the lisp you are running in.)
       
     * For the first file, classes, the (precom) in the line means that
       the file precom should be loaded before this file is loaded.  The
       first () means that no other files need to be loaded before this
       file is compiled.  The second () means that changes in other files
       don't force this file to be recompiled.
     
     * For the second file, methods, the (precom classes) means that both
       of the files precom and classes must be loaded before this file
       can be loaded.  The (classes) means that the file classes must be
       loaded before this file can be compiled.  The () means that changes
       in other files don't force this file to be recompiled.
     
     * For the third file, precom, the first () means that no other files
       need to be loaded before this file is loaded.  The first use of
       (classes methods)  means that both classes and methods must be
       loaded before this file can be compiled.  The second use of (classes
       methods) mean that whenever either classes or methods changes precom
       must be recompiled.
     
     Then you can compile your system with:
     
      (operate-on-system 'my-very-own-system :compile)
     
     and load your system with:
     
      (operate-on-system 'my-very-own-system :load)
     ||#
------------------------------------------------------------
  rascal.ics.utexas.edu:pub/akcl-1-100.tar.Z  lsp/make.lsp
     ;;;  *******  Description of Make Facility ************
     ;;  We provide a simple MAKE facility to allow
     ;;compiling and loading of a tree of files
     ;;If the tree is '(a b (d e g h) i)
     ;;   a will be loaded before b is compiled,
     ;;   b will be loaded before d, e, g, h are compiled
     ;;   d e g h will be loaded before i is compiled.
     
     ;;  A record is kept of write dates of loaded compiled files, and a file
     ;;won't be reloaded if it is the same version (unless a force flag is t).
     
     ;;Thus if you do (make :uinfor) twice in a row, the second one would not
     ;;load anything.  NOTE: If you change a, and a macro in it would affect
     ;;b, b still will not be recompiled.  You must choose the :recompile t
     ;;option, to force the recompiling if you change macro files.
     ;;Alternately you may specify dependency information (see :depends below).
     
     ;;****** Sample file which when loaded causes system ALGEBRA 
     ;;              to be compiled and loaded ******
     
     ;;(require "MAKE")
     ;;(use-package "MAKE")
     ;;(setf (get :algebra :make) '(a b (d e) l))
     ;;(setf (get :algebra :source-path) "/usr2/wfs/algebra/foo.lisp")
     ;;(setf (get :algebra :object-path) "/usr2/wfs/algebra/o/foo.o")
     ;;(make :algebra :compile t)
     
     ;;  More complex systems may need to do some special operations
     ;;at certain points of the make.  
     ;;the tree of files may contain some keywords which have special meaning.
     ;;eg. '(a b (:progn (gbc) (if make::*compile*
     ;;                                  (format t "A and B finally compiled")))
     ;;          (:load-source h i)
     ;;          (d e) l)
     
     ;;then during the load and compile phases the function (gbc) will be
     ;;called after a and b have been acted on, and during the compile phase
     ;;the message about "A and B finally.." will be printed.
     ;;the lisp files h and i will be loaded after merging the paths with 
     ;;the source directory.  This feature is extensible: see the definitions
     ;;of :load-source and :progn.
     
     ;;  The keyword feature is extensible, and you may specify what 
     ;;happens during the load or compile phase for your favorite keyword.
     ;;To do this look at the definition of :progn, and :load-source
     ;;in the source for make.
     
     ;;Dependency feature:
     
     ;;   This make NEVER loads or compiles files in an order different from
     ;;that specified by the tree.  It will omit loading files which are
     ;;loaded and up to date, but if two files are out of date, the first (in
     ;;the printed representation of the tree), will always be loaded before
     ;;the second.  A consequence of this is that circular dependencies can
     ;;never occur.
     ;;
     ;;  If the :make tree contains (a b c d (:depends (c d) (a b))) then c
     ;;and d depend on a and b, so that if a or b need recompilation then c
     ;;and d will also be recompiled.  Thus the general form of a :depends
     ;;clause is (:depends later earlier) where LATER and EARLIER are either
     ;;a single file or a list of files. Read it as LATER depends on EARLIER.
     ;;A declaration of a (:depends (c) (d)) would have no effect, since the
     ;;order in the tree already rules out such a dependence.
     
     ;;  An easy way of specifying a linear dependence is by using :serial.
     ;;The tree (a (:serial b c d) e)  is completely equivalent to the tree
     ;;(a b c d e (:depends c b)(:depends d (b c))), but with a long list of
     ;;serial files, it is inconvenient to specify them in the
     ;;latter representation.
     
     ;;A common case is a set of macros whose dependence is serial followed by a set
     ;;of files whose order is unimportant.  A conventient way of building that
     ;;tree is
     ;;
     ;;(let ((macros '(a b c d))
     ;;      (files '(c d e f g)))
     ;;  `((:serial ,@ macros)
     ;;    ,files
     ;;    (:depends ,files ,macros)))
     
     ;;  The depends clause may occur anywhere within the tree, since
     ;;an initial pass collects all dependency information.
     
     ;;  Make takes a SHOW keyword argument.  It is almost impossible to simulate
     ;;all the possible features of make, for show.  Nonetheless, it is good
     ;;to get an idea of the compiling and loading sequence for a new system.
     ;;As a byproduct, you could use the output, as a simple sequence of calls
     ;;to compile-file and load, to do the required work, when make is not around
     ;;to help.
------------------------------------------------------------
  turing.cs.rpi.edu:pub/lisp/xkcl.tar.Z  lsp/system.lsp
     I wrote this one.  It (partially) implements the
     Symbolics Genera functions: set-system-source-file, defsystem,
     compile-system, and load-system. 
 
     An example:
      The directory "system/" contains files which point to various systems,
      and the defsystem facility has been told this with:
        (add-system-location-directory "system/")
      File "system/clx.lisp" contains:
        (in-package "USER")
        (defparameter clx-default-pathname (concatenate 'string lisp-root-directory "clx/"))
        (set-system-source-file 'clx "defsystem" clx-default-pathname)
      File "clx/defsystem.lisp" contains:
        (defsystem clx
            (:default-pathname #.clx-default-pathname
             :pretty-name "CLX")
          (:module clos pcl (:type :system))
          (:parallel
           clos "depdefs" "clx" "dependent" "macros" "bufmac" "buffer"
           "display" "gcontext" "requests" "input" "fonts" "graphics" "text"
           "attributes" "translate" "keysyms" "manager" "image" "resource"))
      The system CLX can be  compiled by typing:
         (compile-system 'clx)
      To load system CLX, type:
         (load-system 'clx)
------------------------------------------------------------
From: Aaron Larson
Subject: Re: Public defsystem
Date: 
Message-ID: <20198@srcsip.UUCP>
In article <·····@coherent.com> ········@coherent.com (Reed Hastings) writes:
>
>Does anyone know where I can get a public domain defsystem
>facility?
>
>Thanks,
>  -Reed.

Along with probably half the people doing lisp development, we too have
developed our own defsystem toolset.  We have been using it in house for
several months.  Its main features:

  - Supports a number of module types including systems, subsystems, and
    "foreign" languages. 
  - Supports multiple versions of systems using subdirectories.
  - Supports multiple binary types (in same directory tree) using
    subdirectories.  (e.g. you can compile the same system with different
    compilers, and it keeps the bins straight).
  - Has been fully ported to Franz Allegro & Symbolics 7.2, and partially
    ported to Lucid & KCL. (implemen specific stuff has mostly to do with
    pathnames and foreign modules.  Pathname stuff is done for Lucid & KCL
    but not tested).
  - Is written using PCL. (runs in 3/17 and 12/7)
  - does not support patches
  - does not (yet) have compile time only dependencies
  - has some user documentation

Aaron Larson  MN65-2100              (612) 782-7308
Honeywell Systems & Research Center  ·······@SRC.Honeywell.COM  (internet)
3660 Technology Drive                ·······@srcsip             (uucp)
Mpls, MN  55418                      {umn-cs,ems,bthpyd}!srcsip!alarson
From: ····@zaphod.prime.com
Subject: Re: Public defsystem
Date: 
Message-ID: <26500005@zaphod>
I have yet another public defsystem it's modelled after the Symbolics
6.x defsystem and friends.  It's entirely in the public domain.  It's been
tried on a wide variety of systems (including Franz, Lucid and Symbolics) and
it works.  The latest version follows.

Douglas Rand 
Internet:   ····@primerd.prime.com
Snail:	    Prime Computer, 500 Old Conn Path, MS10C-17, Framingham, Ma 01701
Disclaimer: PRIME doesn't believe a word I say, and fewer that I write.

-------- cut here ---------
;;; $Header: /hog/doug/lisp/RCS/defsys.lisp,v 2.3 89/02/21 19:55:48 doug Exp Locker: doug $
;;;
;;; A portable defsystem facility written in pure Common LISP.
;;;
;;; Copyright (c) 1987,1988,1989 Prime Computer, Inc., Natick, MA 01760
;;;                     All Rights Reserved
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Prime Computer Inc. makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;
;;; ·····@eddie.mit.edu -or- ····@enx.prime.com
;;;
;;;
;;; $Log:	defsys.lisp,v $
;;; Revision 2.3  89/02/21  19:55:48  doug
;;; Fixed to not reset *current-system* on recursion through systems.
;;; 
;;; Revision 2.2  87/12/08  10:53:42  doug
;;; Added *current-system*,  *downcase...* 
;;; make load,show,compile-system use *current-system* by default
;;; and set the *current-system*
;;; 
;;; Revision 2.1  87/05/23  14:56:18  doug
;;; Replaced use of concatenate with make-pathname to produce a more portable
;;; pathname generator.  Also added some declarations to quiet compiler error
;;; messages.
;;;
;;; Revision 2.0  87/05/04  10:52:32  doug
;;; First public version.
;;;
;;; Revision 1.6  87/05/01  16:23:49  doug
;;; Removed documentation to defsystem.mss,doc,quic
;;; Added :load-after dependencies.
;;; More error checking.  Separate package for defsystem and co.
;;;
;;; Revision 1.1  87/04/25  13:00:09  doug
;;; Initial Revision
;;;
;;; Contains definitions for defsystem, undefsystem, load-system,
;;; compile-system and show-system.  See defsystem.doc for more
;;; information.
;;;

(in-package '#:defsys)

(provide 'defsys)

(export '(defsystem load-system compile-system show-system *suffixes*
	   *all-systems* undefsystem *defsystem-version* *defsystem-header*
	   *current-system*)
	)

;; Add the feature

(push :defsystem *features*)

(defvar *suffixes*
  #+Symbolics                         '("lisp"  . "bin")
  #+(and dec common vax (not ultrix)) '("LSP"   . "FAS")
  #+(and dec common vax ultrix)       '("lsp"   . "fas")
  #+KCL                               '("lsp"   . "o")
  #+Xerox                             '("lisp"  . "dfasl")
  #+(and Lucid MC68000)               '("lisp"  . "lbin")
  #+(and Lucid VAX VMS)               '("lisp"  . "vbin")
  #+excl                              '("cl"    . "fasl")
  #+system::cmu                       '("slisp" . "sfasl")
  #+PRIME                             '("lisp" . "pbin")
  #+HP                                '("l"     . "b")
  #+TI                                '("lisp"  . "xfasl")
  )

(defvar *downcase-path-from-module-name*
  #+UNIX T
  #-UNIX NIL)

(defvar *defsystem-version* "$Revision: 2.3 $")
(defvar *defsystem-header* "$Header: /hog/doug/lisp/RCS/defsys.lisp,v 2.3 89/02/21 19:55:48 doug Exp Locker: doug $")
(defvar *current-system* nil)

(defstruct (system (:print-function print-system))
  (name "")
  (default-pathname (pathname "") :type pathname)
  (default-package nil :type symbol)
  (needed-systems nil :type list)
  (load-before-compile nil :type list)
  (module-list nil :type list) ;; internal
  (needs-update nil)           ;; internal
  (modules (make-hash-table))) ;; internal

(defun print-system (system stream level)
  (declare (ignore level))
  (format stream "#<System ~A>" (system-name system)))

(defstruct (module (:print-function print-module))
  (name "")
  (load-before-compile nil)
  (compile-satisfies-load nil)
  (load-after nil)
  (recompile-on nil)
  (pathname nil)
  (package nil)
  (compile-function nil)
  (funcall-after nil)
  (funcall-after-args nil)
  (dtm 0);; internal
  (in-process nil);; internal
  (loaded nil);; internal
  )

(defun print-module (module stream level)
  (declare (ignore level))
  (format stream "#<Module ~A>" (module-name module)))

(defvar *all-systems* nil)
(defvar *loaded-systems* nil)

(defmacro undefsystem (system-name)
  `(setq *all-systems* (remove-if #'(lambda (x) (eql (car x) ',system-name))
				  *all-systems*)))

(defmacro defsystem (system-name options &body modules)
  `(let ((system-construct (append '(:name ,system-name) ',options))
         mod-list
         )
     (let ((system (apply #'make-system system-construct)))
       (when (assoc ',system-name *all-systems*)
         (setq *all-systems* (remove-if #'(lambda (x) (eql (car x) 
							   ',system-name))
					*all-systems*)))
       (push (cons ',system-name system) *all-systems*)
       (let ((system-mods (system-modules system)))
         (dolist (module ',modules)
           (let ((mod-construct (cons :name module)))
             (if (symbolp module)
		 (setq mod-construct (list :name module)))
             (let ((module-structure (apply #'make-module mod-construct)))
               (push (module-name module-structure) mod-list)
               (setf (gethash (module-name module-structure) system-mods)
                     module-structure)
               ))
           )
         )
       (setf (system-module-list system) (reverse mod-list))
       )
     ',system-name
     )
  )

(defmacro do-default-system (system top-level)
  ;; Set system to *current-system* if NIL and set the
  ;; value of *current-system*
  `(if (and ,system ,top-level)
       (setq *current-system* ,system)
     (unless ,system
       (if *current-system*
	   (setq ,system *current-system*)
	 (error "Can't default, *current-system* has no value~%"))
       )
     )
  )

(defun load-system (&optional system-name 
			      &key reload (include-components T) (top-level T)
			      &aux system-entry system *load-verbose*)
  (declare (special *load-verbose*))
  (do-default-system system-name top-level)
  (setq *load-verbose* nil)
  (setq system-entry (find-system system-name))
  (setq system (cdr system-entry))
  ;; Load subsystems
  (when include-components
    (dolist (subsystem (system-needed-systems system))
      (when (or reload (not (member subsystem *loaded-systems*)))
        (format T ";;; Loading System ~S~%" subsystem)
        (load-system subsystem :reload reload :top-level NIL
		     :include-components include-components))))
  ;; Load modules
  (dolist (module (system-module-list system))
    (let ((module-description (getmod module system)))
      ;; If already loaded then only reload if needed
      (load-if-needed module-description system reload)
      )
    )
  (format T ";;; Done loading system ~S~%" system-name)
  (setf (system-needs-update system) nil)
  (unless (member system-name *loaded-systems*)
    (push system-name *loaded-systems*))
  )

(defun compile-load-system (&optional system-name 
				      &key reload recompile
				      (include-components T) (top-level T))
  (do-default-system system-name top-level)
  (compile-system system-name :reload reload :top-level NIL
		  :recompile recompile :include-components include-components)
  (load-system system-name :reload reload :top-level NIL
	       :include-components include-components)
  ) 

(defun compile-system (&optional system-name
				 &key reload recompile (include-components T)
				 (top-level T)
				 &aux system-entry system
				 compiled-modules *load-verbose*)
  (declare (special system compiled-modules *load-verbose*))
  (setq *load-verbose* nil)
  (do-default-system system-name top-level)
  (setq system-entry (find-system system-name))
  (setq system (cdr system-entry))
  ;; Recompile included systems
  (when include-components
    (dolist (subsystem (system-needed-systems system))
      (format T ";;; Compiling System ~S~%" subsystem)
      (compile-system subsystem
		      :recompile recompile :top-level NIL
		      :include-components include-components))
    )
  ;; Load Compile subsystem dependencies
  (dolist (subsystem (system-load-before-compile system))
    (when (or reload
              (not (member subsystem *loaded-systems*))
              (system-needs-update subsystem))
      (format T ";;; Loading System ~S~%" subsystem)
      (load-system subsystem
		   :reload reload :top-level NIL
		   :include-components include-components)))
  ;; Compile modules
  (dolist (module (system-module-list system))
    (compile-if-needed module reload recompile)
    )
  nil
  )

(defun get-pathname (module system &aux mpath sname bname sdtm bdtm)
  (unless (setq mpath (module-pathname module))
    (setq mpath
          (setf (module-pathname module)
                (make-pathname :directory (pathname-directory
					   (system-default-pathname system))
			       :name (mname-to-path (module-name module))))))
  (setq sname (make-pathname :directory (pathname-directory mpath)
			     :name (pathname-name mpath)
			     :type (car *suffixes*)))
  (setq bname (make-pathname :directory (pathname-directory mpath)
			     :name (pathname-name mpath)
			     :type (cdr *suffixes*)))
  (setq sdtm (file-write-date sname)
        bdtm (file-write-date bname))
  (cond
   ((and sdtm bdtm)			; Both exist take newer
    (if (> sdtm bdtm)
	sname
      bname))
   (bdtm bname)
   (sdtm sname)
   (T					; no file around
    (error "Can't find any file for module named ~S"
	   (module-name module))))
  )

(defun load-if-needed (module-description system &optional reload &aux path)
  (setq path (get-pathname module-description system))
  (if (and (module-loaded module-description) (not reload))
      (when (< (module-dtm module-description)
	       (file-write-date path))
	(do-load system module-description path reload)
	(setf (module-dtm module-description)
	      (file-write-date path))
	)
    (progn (do-load system module-description path reload)
           (unless (module-pathname module-description)
             (setf (module-pathname module-description)
                   (make-pathname :directory (pathname-directory
					      (system-default-pathname system))
				  :name (mname-to-path (module-name module-description))))
             )
           (setf (module-dtm module-description)
                 (file-write-date path))
           (setf (module-loaded module-description) T)
	   )
    )
  )


(defun do-load (system module path &optional reload &aux package load-after)
  (when (setq load-after (module-load-after module))
    (when (symbolp load-after) (setq load-after (list load-after)))
    (dolist (m load-after)
      (load-if-needed
       (getmod m system)
       system
       reload
       ))
    )
  (format T ";;; Loading file ~S~%" path)
  (setq package (or (module-package module)
                    (system-default-package system)))
  (if package
      (let ((spackage *package*))
	(unwind-protect
	    (progn (in-package package)
		   (load path))
	  (in-package (package-name spackage))))
    (load path))
  ;; do funcall after stuff
  (let ((f (module-funcall-after module)))
    (when f (apply f (module-funcall-after-args module)))
    )
  )


(defun compile-if-needed (module-name
			  &optional reload recompile
			  &aux mpath sname bname module
			  sdtm bdtm ddtm ddtms package
			  compile-function)
  (declare (special system compiled-modules))
  (setq module (getmod module-name system))
  (setq package (or (module-package module)
                    (system-default-package system)))
  ;; Do our dependents
  (if (or (null (module-recompile-on module))
          (module-in-process module))
      (setq ddtms '(0))
    (unwind-protect
	;; We don't want to recurse infinitely if one module has
	;; a reciprocal compile relation with another so we set the
	;; in-process flag to cause this to bottom out.  The
	;; unwind-protect makes sure it's cleaned up on error cases.
        (progn (setf (module-in-process module) T)
               (dolist (mod (module-recompile-on module))
                 (push (compile-if-needed mod) ddtms)
                 ))
      (setf (module-in-process module) nil)
      )
    )
  (setq ddtm (apply #'max ddtms))
  (unless (setq mpath (module-pathname module))
    (setq mpath
          (setf (module-pathname module)
                (make-pathname :directory (pathname-directory
					   (system-default-pathname system))
			       :name (mname-to-path module-name)))))
  (setq sname (make-pathname :directory (pathname-directory mpath)
			     :name (pathname-name mpath)
			     :type (car *suffixes*)))
  (setq bname (make-pathname :directory (pathname-directory mpath)
			     :name (pathname-name mpath)
			     :type (cdr *suffixes*)))
  (setq sdtm (file-write-date sname)
        bdtm (file-write-date bname))
  (unless bdtm (setq bdtm 0))
  (unless sdtm
    (error "Can't find the source file for ~S~%" module-name))
  (if (and (or (< bdtm sdtm) (< bdtm ddtm)
               (and recompile (not (member module-name compiled-modules))))
           (not (module-in-process module)))
      ;; Recompiling.. load necessary files
      (progn
	(dolist (name (module-recompile-on module))
	  (load-if-needed (getmod name system) system reload)
	  )
	(dolist (name (module-load-before-compile module))
	  (load-if-needed (getmod name system) system reload)
	  )
	(format T ";;; Compiling ~S..." (module-name module))
	(setq compile-function (module-compile-function module))
	(unless compile-function (setq compile-function #'compile-file))
	(if package
	    (let ((spackage *package*))
	      (unwind-protect
		  (progn (in-package package)
			 (funcall compile-function sname))
		(in-package (package-name spackage))))
	  (funcall compile-function sname))
	(when (module-compile-satisfies-load module)
	  (setf (module-loaded module) T))
	(format T "~%")
	(push module-name compiled-modules)
	(setf (system-needs-update system) T)
	;; recompiling produces a new file so...
	(get-universal-time)
	)
    ;; Not recompiling or in process..
    (max bdtm sdtm))
  )

(defun show-system (&optional system-name &aux system system-entry)
  (do-default-system system-name T)
  (setq system-entry (find-system system-name))
  (setq system (cdr system-entry))
  (format T ";;; System: ~S~%;;;~%" (system-name system))
  (format T ";;; Needed Systems: ~S~%" (system-needed-systems system))
  (format T ";;; Default Package: ~S~%" (system-default-package system))
  (format T ";;; Default Pathname: ~S~%" (system-default-pathname system))
  (format T ";;; Load-before-compile: ~S~%" (system-load-before-compile system))
  (format T ";;; Needs update: ~S~%" (system-needs-update system))
  (format T ";;;~%")
  (dolist (module-name (system-module-list system))
    (let ((module (getmod module-name  system)))
      (format T ";;; Module: ~S  Package: ~S  Loaded: ~S  Compile-satisfies-load: ~S~%"
	      module-name (module-package module)
	      (module-loaded module) (module-compile-satisfies-load module)
	      )
      (format T ";;;    Load-before-compile: ~S ~%"
	      (module-load-before-compile module))
      (format T ";;;    Load-after: ~S~%"
	      (module-load-after module))
      (format T ";;;    Recompile-on: ~S~%" (module-recompile-on module))
      (format T ";;;    Pathname: ~S~%" (module-pathname module))
      )
    )
  (format T ";;; ---------------------------------")
  )

(defun getmod (m s &aux md)
  (setq md (gethash m (system-modules s)))
  (if md
      md
    (error "Module ~S not present in System ~S~%"
	   m s)
    )
  )

(defun mname-to-path (module)
  ;; Convert module to entryname
  ;; Under UNIX downcase by default
  (if *downcase-path-from-module-name*
      (string-downcase (string module))
    (string module)
    )
  )

(defun find-system (system-name &aux system-entry)
  (setq system-entry (assoc system-name *all-systems*))
  (unless system-entry
    (error "No such system description loaded.  System ~S"
	   system-name))
  system-entry)
From: ····@zaphod.prime.com
Subject: Re: Public defsystem
Date: 
Message-ID: <26500006@zaphod>
Documentation for defsys.lisp:

Intro:

     Common  LISP  lacks  a  method for tying a group of files together under a
convenient name.  The common method for doing this in  ZetaLISP  is  defsystem.
This  is  a public domain implementation of defsystem.  Where possible the same
keywords are used as  in  ZetaLISP  but  this  implementation  has  a  slightly
different flavor from the ZetaLISP defsystem.

Changes (2.2):

     Compile-load-system   combines   compile-system   and   load-system  as  a
convenience.

     The package name is now  defsys  to  eliminate  name  conflicts  with  the
defsystem macro.

     All   the  system  oriented  functions  (load-system,  compile-system  and
show-system, compile-load-system) now  have  the  system-name  argument  as  an
optional argument.  If the argument is given then the variable *current-system*
is set to  that  value.    If  the  argument  is  ommited  then  the  value  of
*current-system* is used.  If *current-system* is NIL then an error is raised.

     A variable defsys::*downcase-path-from-module-name* is set to T under UNIX
and NIL otherwise.  Since module names are  normally  entered  as  symbols  the
mapping  is  normally  into uppercase.  Since UNIX is case sensitive this means
that one would then need to name the files in uppercase.

Defsystem macro:

(defsystem system-name
   (system-options*)
   module-descriptions*
   )
     Load order is implied by the order of the modules.    System  options  are
(defaults in {}s):

:default-pathname {#P""}
                The default place to find files in.

:default-package {nil, i.e. current}
                The default package to load/compile modules in.

:needed-systems {nil}
                A list of subsystems

:load-before-compile {nil}
                A list of subsystems needed for compilation

     A  module  is  a single name representing a file.  A module description is
either a module name or a list whose car is the module name and the  cdr  is  a
set of keywords and values.  The module options are:

:recompile-on (mod, mod, ...)
                This will cause the module list to be checked for dtm if one of
                the  listed  modules  is  newer then the current module will be
                recompiled.  If the current module is recompiled  the  list  of
                recompile dependencies will be loaded first.

                This  is  also a recursive recompilation.  If foo dependends on
                bar and bar is out of date then bar will be recompiled.  

:load-before-compile (mod, mod, ..)
                These  are  modules  that  are  loaded  before  recompiling the
                current module.

:load-after (mod, mod, ...)
                This  is  really  a  useful  option  only  for  modules  during
                compilation since the load order  will  normally  be  satisfied
                during  a load-system. These are followed until a loaded module
                is found.

:pathname path  If specified it gives a pathname to find this module.  Normally
                this  defaults to the concatenation of the default pathname for
                the system and the module name.

:package package-name
                What  package  to load/compile this module in.  Defaults to the
                system default package.

:compile-satisfies-load {nil}
                If   T  then  compiling  this  module  will  set  it's  loading
                information to T. This is usually  true  for  files  with  just
                macros.

UnDefSystem (macro)

(undefsystem system-name)
     Removes the system description from *all-systems*.

Load-system (function)

(load-system {system-name} {keys})
     Loads  modules  of  a  system.   Load-system is called recursively for all
required systems.  Keyword options are:
:reload {nil} - if T force a full reload of everything.
:included-components {T} - if T call load-system on subcomponents

Compile-system (function)

(compile-system {system-name} {keys})
     Compiles all modules requiring recompilation.  The recompile keyword  will
cause  all recompilations to occur regardless of 'need'.  Need is determined by
the date-time of the respective binary and source files.
:recompile {nil} - recompile everything if T
:included-components {T} - call compile-system on subcomponents
:reload {nil} - always reload needed modules

Show-System (function)

(show-system {system-name
     ) } Pretty output of system description.

Simple Sample Defsystems

 (defsystem life
   (:needed-systems (curses)
    :default-pathname #P"doug.x>lisp>life>")
   life
   )

 (defsystem curses
   (:default-pathname #P"doug.x>lisp>curses>"
    :default-package curses)
   curses
   (curses-internals :package curses-internals)
   )

 (defsystem profile
   ()
   profile timer
   )