From: Douglas Rand
Subject: CLOS version of defsys
Date:
Message-ID: <1992Jun11.213140.19377@osf.org>
Use with extreme caution. I'm interested in comments, but I don't currently
have time to commit to maintaining or extending this implementation.
There is work left to be done to make it perfectly extensible, the basic-module
and basic-system classes should work ok. The hacks for pathname in CMU
Common LISP should be removable for the newer versions is Rob informed
me correctly.
;;; $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 using
;;; the Common LISP Object System (CLOS)
;;;
;;; Copyright (c) 1992 The MITRE Corporation, Bedford, MA 01730
;;;
;;; 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 the MITRE Corporation 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:
;;;
;;; ·····@osf.org (·····@eddie.mit.edu if mail bounces)
;;;
;;; $Log: defsys.lisp,v $
;;;
;;; Revision 1.1 87/04/25 13:00:09 doug
;;; Initial Revision of non-clos defsystem
;;;
;;; Contains definitions for defsystem, undefsystem, load-system,
;;; compile-system and show-system. See defsystem.doc for more
;;; information.
;;;
(defpackage "DEFSYS"
(:use "PCL")
(:nicknames "defsys" "defsystem" "DEFSYSTEM")
(:export "DEFSYSTEM" "LOAD-SYSTEM" "COMPILE-SYSTEM" "SHOW-SYSTEM"
"*SUFFIXES*" "*ALL-SYSTEMS*" "UNDEFSYSTEM" "*DEFSYSTEM-VERSION*"
"*DEFSYSTEM-HEADER*" "*CURRENT-SYSTEM*")
(:import-from "PCL" "DESCRIBE-OBJECT")
)
(in-package "DEFSYS")
;;;
;;; Add the feature
;;;
(push :defsystem *features*)
;;;
;;; Many thanks to Gregor Kiczales for the list from PCL
;;;
(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")
#+(and CMU (or SUN4 SPARC)) '("lisp" . "sparcf")
#+PRIME '("lisp" . "pbin")
#+HP '("l" . "b")
#+TI '("lisp" . "xfasl")
)
(defvar *downcase-path-from-module-name*
#+UNIX T
#+CMU T
#-UNIX NIL)
(defvar *module-type-alist*
'((:module . basic-module)
(:file . file-module)
(:foreign . foreign-module)))
(defun class-from-module-alias (alias)
(let ((classname (cdr (assoc alias *module-type-alist*))))
(if classname
classname
alias))
)
(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)
(defclass system ()
(
;; Semi public ivs
(name :initform ""
:initarg :name)
(default-pathname
:initform (pathname "")
:initarg :default-pathname
:type pathname)
(default-package :initform nil
:initarg :default-package
:type symbol)
(needed-systems :initform nil
:initarg :needed-systems
:type list)
(load-before-compile :initform nil
:initarg :load-before-compile
:type list)
;; Private
(module-list :initform nil
:type list)
(needs-update :initform nil
:reader system-needs-update)
(modules :initform (make-hash-table))
)
)
(defmethod print-object ((system system) stream)
(with-slots (name) system
(format stream "#<System ~A>" name))
)
(defclass basic-module ()
((name :initform ""
:initarg :name)
(load-before-compile :initform nil
:initarg :load-before-compile)
(compile-satisfies-load :initform nil
:initarg :compile-satisfies-load)
(load-after :initform nil
:initarg :load-after)
(recompile-on :initform nil
:initarg :recompile-on)
(pathname :initform nil
:initarg :pathname)
(package :initform nil
:initarg :package)
(compile-function :initform nil
:initarg :compile-function)
(funcall-after :initform nil
:initarg :funcall-after)
(funcall-after-args :initform nil
:initarg :funcall-after-args)
;; Private
(dtm :initform 0)
(in-process :initform nil)
(loaded :initform nil)
)
)
(defmethod print-object ((module basic-module) stream)
(with-slots (name) module
(format stream "#<Module ~A>" name)
)
)
(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 module-descriptions)
`(let ((system (make-instance 'system :name ',system-name ,@options))
(a-module NIL)
(mod-list NIL))
(undefsystem ',system-name)
(push (cons ',system-name system) *all-systems*)
(with-slots (modules module-list) system
;; Scan list of modules and create
(dolist (module ',module-descriptions)
;; Module definition of one of three forms:
;; module-name - implies basic-module, no init
;; (module-name ...) - implies basic-module, w/init
;; (:type module-name ...)
;; - implies :type basic-module, w/init
;; First case: module-name
(if (symbolp module)
(setq a-module (make-instance 'basic-module :name module))
;; (module-name ... or (:type module-name ...
(let ((module-class 'basic-module)
module-name
module-initargs)
;; If keywordp then the type is given
(when (keywordp (car module))
(setq module-class
(class-from-module-alias (pop module)))
(when (keywordp module-class)
(setq module-class
(intern (symbol-name module-class))))
)
;; Extract other info
(setq module-name (pop module))
(if (keywordp module-name)
(error "Keyword found where symbol expected <~A>"
module-name))
(setq module-initargs module)
(setq a-module (apply #'make-instance module-class
:name module-name
module-initargs))
)
)
(with-slots (name) a-module
(push name mod-list)
(setf (gethash name modules) a-module)
)
)
(setq module-list (reverse mod-list))
)
system
)
)
(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))
(with-slots (needed-systems
module-list
needs-update) system
;; Load subsystems
(when include-components
(dolist (subsystem needed-systems)
(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 module-list)
(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)
(setq needs-update 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
(with-slots (needed-systems
module-list
load-before-compile) system
(when include-components
(dolist (subsystem needed-systems)
(format T ";;; Compiling System ~S~%" subsystem)
(compile-system subsystem
:recompile recompile :top-level NIL
:include-components include-components))
)
;; Load Compile subsystem dependencies
(dolist (subsystem load-before-compile)
(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 module-list)
(compile-if-needed module reload recompile)
)
nil
)
)
(defmethod get-pathname ((module basic-module) system
&aux mpath sname bname sdtm bdtm)
(with-slots (pathname name) module
(with-slots (default-pathname) system
(unless (setq mpath pathname)
(setq mpath
(setq pathname
(make-pathname
#+CMU :device :absolute
:directory (pathname-directory default-pathname)
:name (mname-to-path name)))))
)
(setq sname (make-pathname :directory (pathname-directory mpath)
#+CMU :device :absolute
:name (pathname-name mpath)
:type (car *suffixes*)))
(setq bname (make-pathname :directory (pathname-directory mpath)
#+CMU :device :absolute
: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" name))
)
)
)
(defmethod load-if-needed ((module-description basic-module)
system &optional reload &aux path)
(setq path (get-pathname module-description system))
(with-slots (name loaded dtm pathname) module-description
(if (and loaded (not reload))
(when (< dtm (file-write-date path))
(do-load module-description system path reload)
(setf dtm (file-write-date path))
)
(progn (do-load module-description system path reload)
(unless pathname
(with-slots (default-pathname) system
(setq pathname
(make-pathname :directory (pathname-directory
default-pathname)
#+CMU :device :absolute
:name (mname-to-path name)))
)
)
(setq dtm (file-write-date path))
(setq loaded T)
)
)
)
)
(defmethod do-load ((module basic-module) system
path &optional reload &aux package)
(with-slots (load-after
funcall-after
funcall-after-args
(module-package package)) module
(when load-after
(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)
(with-slots (default-package) system
(setq package (or module-package default-package)))
(if package
(let ((spackage *package*))
(unwind-protect
(progn (in-package package)
(load path))
(in-package (package-name spackage))))
(load path))
;; do funcall after stuff
(when funcall-after
(apply funcall-after funcall-after-args))
)
)
(defmethod compile-if-needed (module-name &optional reload recompile
&aux module)
(declare (special system compiled-modules))
(setq module (getmod module-name system))
(compile-if-needed module reload recompile))
(defmethod compile-if-needed ((module basic-module) &optional reload recompile
&aux mpath sname bname
sdtm bdtm ddtm ddtms package)
(declare (special system compiled-modules))
(with-slots ((module-package package)) module
(with-slots (default-package) system
(setq package (or module-package default-package))
)
)
;; Do our dependents
(with-slots (recompile-on in-process) module
(if (or (null recompile-on) in-process)
(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 (setq in-process T)
(dolist (mod recompile-on)
(push (compile-if-needed mod) ddtms)
))
(setq in-process nil)
)
)
)
(setq ddtm (apply #'max ddtms))
(with-slots ((module-pathname pathname)
(module-name name)) module
(with-slots (default-pathname) system
(unless (setq mpath module-pathname)
(setq mpath
(setq module-pathname
(make-pathname
#+CMU :device :absolute
:directory (pathname-directory default-pathname)
:name (mname-to-path module-name)))))
)
)
(setq sname (make-pathname :directory (pathname-directory mpath)
#+CMU :device :absolute
:name (pathname-name mpath)
:type (car *suffixes*)))
(setq bname (make-pathname :directory (pathname-directory mpath)
#+CMU :device :absolute
:name (pathname-name mpath)
:type (cdr *suffixes*)))
(setq sdtm (file-write-date sname)
bdtm (file-write-date bname))
(unless bdtm (setq bdtm 0))
(with-slots (in-process
recompile-on
load-before-compile
compile-function
compile-satisfies-load
loaded
name) module
(unless sdtm
(error "Can't find the source file for ~S~%" name))
(if (and (or (< bdtm sdtm) (< bdtm ddtm)
(and recompile (not (member module-name compiled-modules))))
(not in-process))
;; Recompiling.. load necessary files
(progn
(dolist (name recompile-on)
(load-if-needed (getmod name system) system reload)
)
(dolist (name load-before-compile)
(load-if-needed (getmod name system) system reload)
)
(format T ";;; Compiling ~S..." name)
(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 compile-satisfies-load
(setq loaded T))
(format T "~%")
(push name compiled-modules)
(with-slots (needs-update) system
(setq needs-update 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))
(describe system))
(defmethod describe-object ((this system) stream)
(with-slots (name
needed-systems
default-package
default-pathname
load-before-compile
needs-update
module-list) this
(format stream ";;; System: ~S~%;;;~%" name)
(format stream ";;; Needed Systems: ~S~%" needed-systems)
(format stream ";;; Default Package: ~S~%" default-package)
(format stream ";;; Default Pathname: ~S~%" default-pathname)
(format stream ";;; Load-before-compile: ~S~%" load-before-compile)
(format stream ";;; Needs update: ~S~%" needs-update)
(format stream ";;;~%")
(dolist (module-name module-list)
(let ((module (getmod module-name this)))
(describe module)))
(format stream ";;; ---------------------------------")
)
)
(defmethod describe-object ((module basic-module) stream)
(with-slots (package
compile-satisfies-load
name
pathname
loaded
recompile-on
load-before-compile
load-after) module
(format stream
";;; Module: ~S Package: ~S Loaded: ~S Compile-satisfies-load: ~S~%"
name package loaded
compile-satisfies-load)
(format stream ";;; Load-before-compile: ~S ~%" load-before-compile)
(format stream ";;; Load-after: ~S~%" load-after)
(format stream ";;; Recompile-on: ~S~%" recompile-on)
(format stream ";;; Pathname: ~S~%" pathname)
)
)
(defun getmod (m s &aux md)
(with-slots (modules) s
(setq md (gethash m modules))
(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 <·····@osf.org> OSF/Motif Dev.
Snail: 11 Cambridge Center, Cambridge, MA 02142
Disclaimer: I don't know if OSF agrees with me... let's vote on it.
Amateur Radio: KC1KJ