From: Douglas S. Rand
Subject: portable defsystem (source)
Date:
Message-ID: <DSR.91Feb22135904@mir.mitre.org>
Source for PD defsystem.
;;; $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:
;;;
;;; ······@mitre.org (·····@eddie.mit.edu if mail bounces)
;;;
;;;
;;; $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 (cdr (assoc subsystem *all-systems*)))
)
(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)
--
Douglas S. Rand
Internet: <······@mitre.org>
Snail: MITRE, Burlington Road, Bedford, MA
Disclaimer: MITRE might agree with me - then again...
Amateur Radio: KC1KJ