Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

Public defsystem

8 views
Skip to first unread message

Reed Hastings

unread,
Apr 7, 1989, 5:33:49 PM4/7/89
to

Does anyone know where I can get a public domain defsystem
facility?

Thanks,
-Reed.

Richard Harris

unread,
Apr 7, 1989, 8:10:47 PM4/7/89
to

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

Aaron Larson

unread,
Apr 8, 1989, 11:35:49 AM4/8/89
to
In article <23...@coherent.com> hast...@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 ala...@SRC.Honeywell.COM (internet)
3660 Technology Drive alarson@srcsip (uucp)
Mpls, MN 55418 {umn-cs,ems,bthpyd}!srcsip!alarson

do...@zaphod.prime.com

unread,
Apr 10, 1989, 11:02:00 AM4/10/89
to

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
)

do...@zaphod.prime.com

unread,
Apr 10, 1989, 11:02:00 AM4/10/89
to

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

0 new messages