Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!tut.cis.ohio-state.edu!bloom-beacon!primerd!zaphod!doug
From: doug@zaphod.prime.com
Newsgroups: comp.lang.lisp
Subject: Re: Public defsystem
Message-ID: <26500005@zaphod>
Date: 10 Apr 89 15:02:00 GMT
References: <23321@coherent.com>
Lines: 460
Nf-ID: #R:coherent.com:-2332100:zaphod:26500005:000:16375
Nf-From: zaphod.prime.com!doug    Apr 10 11:02:00 1989


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:   doug@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:
;;;
;;; dougr@eddie.mit.edu -or- doug@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)