;;; compile.scm -- compilation utilities
;;;
;;; author : Sandra Loosemore
;;; date : 24 Oct 1991
;;;
;;; This file defines a makefile-like compilation system that supports
;;; a hierarchy of dependencies.
;;; The external entry points are define-compilation-unit, load-unit, and
;;; compile-and-load-unit.
;;;=====================================================================
;;; Parsing
;;;=====================================================================
;;; Establish global defaults for filenames.
(define compile.source-filename source-file-type)
(define compile.binary-filename binary-file-type)
(define compile.binary-subdir (string-append lisp-implementation-name "/"))
(define compile.delayed-loads '())
;;; Top level units are stored in this table.
;;; This is really a slight wart on the whole scheme of things; this
;;; is done instead of storing the top-level units in variables because
;;; we were getting unintentional name collisions.
(define compile.unit-table (make-table))
(define-syntax (compile.lookup-unit name)
`(table-entry compile.unit-table ,name))
(define (mung-global-units names lexical-units)
(map (lambda (n)
(if (memq n lexical-units)
n
`(compile.lookup-unit ',n)))
names))
;;; Top-level compilation units are defined with define-compilation-unit.
;;; The body can consist of the following clauses:
;;;
;;; (source-filename <filename>)
;;; (binary-filename <filename>)
;;; Specify source and/or binary file names. For nested units, these
;;; are merged with defaults from outer units. If you don't specify
;;; an explicit binary filename, it's inherited from the source file
;;; name.
;;; (require ...)
;;; Specify compile/load dependencies. Arguments are names of other
;;; units/component files; these names have scoping like let*, so a unit
;;; can require previously listed units at the same or outer level.
;;; (unit name ....)
;;; Specifies a nested unit. This can appear multiple times.
;;; If a unit doesn't include any nested units, then it's a leaf
;;; consisting of a single source file.
;;; (load <boolean>)
;;; If supplied and false, the unit isn't loaded unless it is needed
;;; to satisfy a require clause. Used for files containing compilation
;;; support stuff.
;;; (compile <boolean>)
;;; If supplied and false, the unit isn't compiled. Only useful for
;;; leaf nodes. Typically used in combination with (load '#f) to suppress
;;; compilation of stuff only used at compile time.
(define-syntax (define-compilation-unit name . clauses)
`(begin
(let ((unit ,(compile.process-unit-spec name clauses '#t '())))
(setf (compile.lookup-unit ',name) unit)
(setf compilation-units (append compilation-units (list unit))))
',name))
;;; The basic approach is to turn the compilation unit definition into
;;; a big LET*, and put calls to build the actual unit object inside
;;; of this.
;;;
(define (compile.process-unit-spec name clauses top-level? lexical-units)
(multiple-value-bind
(source-filename binary-filename require nested-units
load? compile?)
(compile.parse-unit-spec clauses lexical-units)
`(let* ((compile.source-filename ,source-filename)
(compile.binary-filename ,binary-filename)
(compile.unit-require (list ,@require))
(compile.delayed-loads (append compile.delayed-loads
(compile.select-delayed-loads
compile.unit-require)))
,@nested-units)
(make compile.unit
(name ',name)
(source-filename compile.source-filename)
(binary-filename compile.binary-filename)
(components (list ,@(map (function car) nested-units)))
(require compile.unit-require)
(top-level? ',top-level?)
(load? ,load?)
(compile? ,compile?)
(delayed-loads compile.delayed-loads)))))
(define (compile.parse-unit-spec clauses lexical-units)
(let ((source-filename '#f)
(binary-filename '#f)
(require '#f)
(nested-units '())
(load? ''#t)
(compile? ''#t))
(dolist (c clauses)
(cond ((not (pair? c))
(compile.unit-syntax-error c))
((eq? (car c) 'source-filename)
(if source-filename
(compile.unit-duplicate-error c)
(setf source-filename (cadr c))))
((eq? (car c) 'binary-filename)
(if binary-filename
(compile.unit-duplicate-error c)
(setf binary-filename (cadr c))))
((eq? (car c) 'require)
(if require
(compile.unit-duplicate-error c)
(setf require (mung-global-units (cdr c) lexical-units))))
((eq? (car c) 'unit)
(push (list (cadr c)
(compile.process-unit-spec (cadr c) (cddr c)
'#f lexical-units))
nested-units)
(push (cadr c) lexical-units))
((eq? (car c) 'load)
(setf load? (cadr c)))
((eq? (car c) 'compile)
(setf compile? (cadr c)))
(else
(compile.unit-syntax-error c))))
(values
(if source-filename
`(compile.merge-filenames ,source-filename
compile.source-filename '#f)
'compile.source-filename)
(if binary-filename
`(compile.merge-filenames ,binary-filename
compile.binary-filename '#f)
(if source-filename
'(compile.merge-filenames compile.binary-filename
compile.source-filename
compile.binary-subdir)
'compile.binary-filename))
(or require '())
(nreverse nested-units)
load?
compile?)))
(predefine (error format . args))
(define (compile.unit-syntax-error c)
(error "Invalid compilation unit clause ~s." c))
(define (compile.unit-duplicate-error c)
(error "Duplicate compilation unit clause ~s." c))
;;;=====================================================================
;;; Representation and utilities
;;;=====================================================================
;;; Here are constructors and accessors for unit objects.
;;; Implementationally, the compilation unit has the following slots:
;;;
;;; * The unit name.
;;; * The source file name.
;;; * The binary file name.
;;; * A list of component file/units.
;;; * A list of units/files to require.
;;; * A load timestamp.
;;; * A timestamp to keep track of the newest source file.
;;; * Flags for compile and load.
(define-struct compile.unit
(predicate compile.unit?)
(slots
(name (type symbol))
(source-filename (type string))
(binary-filename (type string))
(components (type list))
(require (type list))
(top-level? (type bool))
(load? (type bool))
(compile? (type bool))
(delayed-loads (type list))
(load-time (type (maybe integer)) (default '#f))
(source-time (type (maybe integer)) (default '#f))
(last-update (type (maybe integer)) (default 0))
))
(define (compile.newer? t1 t2)
(and t1
t2
(> t1 t2)))
(define (compile.select-newest t1 t2)
(if (compile.newer? t1 t2) t1 t2))
(define (compile.get-source-time u)
(let ((source-file (compile.unit-source-filename u)))
(if (file-exists? source-file)
(file-write-date source-file)
'#f)))
(define (compile.get-binary-time u)
(let ((binary-file (compile.unit-binary-filename u)))
(if (file-exists? binary-file)
(file-write-date binary-file)
'#f)))
(define (compile.load-source u)
(load (compile.unit-source-filename u))
(setf (compile.unit-load-time u) (current-date)))
(define (compile.load-binary u)
(load (compile.unit-binary-filename u))
(setf (compile.unit-load-time u) (current-date)))
(define (compile.compile-and-load u)
(let ((source-file (compile.unit-source-filename u))
(binary-file (compile.unit-binary-filename u)))
(compile-file source-file binary-file)
(load binary-file)
(setf (compile.unit-load-time u) (current-date))))
(define (compile.do-nothing u)
u)
;;;=====================================================================
;;; Runtime support for define-compilation-unit
;;;=====================================================================
(define (compile.select-delayed-loads require)
(let ((result '()))
(dolist (r require)
(if (not (compile.unit-load? r))
(push r result)))
(nreverse result)))
(define (compile.merge-filenames fname1 fname2 add-subdir)
(let ((place1 (filename-place fname1))
(name1 (filename-name fname1))
(type1 (filename-type fname1)))
(assemble-filename
(if (string=? place1 "")
(if add-subdir
(string-append (filename-place fname2) add-subdir)
fname2)
place1)
(if (string=? name1 "") fname2 name1)
(if (string=? type1 "") fname2 type1))))
;;;=====================================================================
;;; Load operation
;;;=====================================================================
;;; Load-unit and compile-and-load-unit are almost identical. The only
;;; difference is that load-unit will load source files as necessary, while
;;; compile-and-load-unit will compile them and load binaries instead.
(define (load-unit u)
(compile.update-unit-source-times u '#f (current-date))
(compile.load-unit-aux u))
(define (compile.load-unit-aux u)
(with-compilation-unit ()
(compile.load-unit-recursive u '#f)))
(define (compile-and-load-unit u)
(compile.update-unit-source-times u '#f (current-date))
(compile.compile-and-load-unit-aux u))
(define (compile.compile-and-load-unit-aux u)
(with-compilation-unit ()
(compile.load-unit-recursive u '#t)))
;;; Load a bunch of compilation units as a group. This is useful because
;;; it can prevent repeated lookups of file timestamps. Basically, the
;;; assumption is that none of the source files will change while the loading
;;; is in progress.
;;; In case of an error, store the units left to be compiled in a global
;;; variable.
(define remaining-units '())
(define (load-unit-list l)
(let ((timestamp (current-date)))
(dolist (u l)
(compile.update-unit-source-times u '#f timestamp))
(setf remaining-units l)
(dolist (u l)
(compile.load-unit-aux u)
(pop remaining-units))))
(define (compile-and-load-unit-list l)
(let ((timestamp (current-date)))
(dolist (u l)
(compile.update-unit-source-times u '#f timestamp))
(setf remaining-units l)
(dolist (u l)
(compile.compile-and-load-unit-aux u)
(pop remaining-units))))
;;; Walk the compilation unit, updating the source timestamps.
(define (compile.update-unit-source-times u newest-require timestamp)
(unless (eqv? timestamp (compile.unit-last-update u))
(setf (compile.unit-last-update u) timestamp)
(dolist (r (compile.unit-require u))
(if (compile.unit-top-level? r)
(compile.update-unit-source-times r '#f timestamp))
(setf newest-require
(compile.select-newest newest-require
(compile.unit-source-time r))))
(let ((components (compile.unit-components u)))
(if (not (null? components))
(let ((source-time newest-require))
(dolist (c components)
(compile.update-unit-source-times c newest-require timestamp)
(setf source-time
(compile.select-newest source-time
(compile.unit-source-time c))))
(setf (compile.unit-source-time u) source-time))
(setf (compile.unit-source-time u)
(compile.select-newest
newest-require
(compile.get-source-time u)))))))
;;; Load a compilation unit. Do this by first loading its require list,
;;; then by recursively loading each of its components, in sequence.
;;; Note that because of the way scoping of units works and the
;;; sequential nature of the load operation, only top-level
;;; units in the require list have to be loaded explicitly.
(define (compile.load-unit-recursive u compile?)
(let ((components (compile.unit-components u)))
;; First recursively load dependencies.
;; No need to update time stamps again here.
(dolist (r (compile.unit-require u))
(if (compile.unit-top-level? r)
(compile.load-unit-aux r)))
(if (not (null? components))
;; Now recursively load subunits.
(dolist (c components)
(unless (not (compile.unit-load? c))
(compile.load-unit-recursive c compile?)))
;; For a leaf node, load either source or binary if necessary.
(let ((source-time (compile.unit-source-time u))
(binary-time (compile.get-binary-time u))
(load-time (compile.unit-load-time u)))
(cond ((compile.newer? load-time source-time)
;; The module has been loaded since it was last changed,
;; but maybe we want to compile it now.
(if (and compile?
(compile.unit-compile? u)
(compile.newer? source-time binary-time))
(begin
(compile.do-delayed-loads
(compile.unit-delayed-loads u)
compile?)
(compile.compile-and-load u))
(compile.do-nothing u)))
((compile.newer? binary-time source-time)
;; The binary is up-to-date, so load it.
(compile.load-binary u))
(else
;; The binary is out-of-date, so either load source or
;; recompile the binary.
(compile.do-delayed-loads
(compile.unit-delayed-loads u)
compile?)
(if (and compile? (compile.unit-compile? u))
(compile.compile-and-load u)
(compile.load-source u)))
)))))
(define (compile.do-delayed-loads units compile?)
(dolist (u units)
(compile.load-unit-recursive u compile?)))
;;;=====================================================================
;;; Extra stuff
;;;=====================================================================
;;; Reload a unit without testing to see if any of its dependencies are
;;; out of date.
(define (reload-unit-source u)
(let ((components (compile.unit-components u)))
(if (not (null? components))
(dolist (c components)
(reload-unit-source c))
(compile.load-source u))))
(define (reload-unit-binary u)
(let ((components (compile.unit-components u)))
(if (not (null? components))
(dolist (c components)
(reload-unit-binary c))
(compile.load-binary u))))
;;; Find a (not necessarily top-level) compilation unit with the given
;;; name.
(define (find-unit name)
(compile.find-unit-aux name compilation-units))
(define (compile.find-unit-aux name units)
(block find-unit-aux
(dolist (u units '#f)
(if (eq? name (compile.unit-name u))
(return-from find-unit-aux u)
(let* ((components (compile.unit-components u))
(result (compile.find-unit-aux name components)))
(if result
(return-from find-unit-aux result)))))))
;;; Combine the two above: reload a compilation unit.
(define-syntax (reload name)
`(reload-unit-source
(or (find-unit ',name)
(error "Couldn't find unit named ~s." ',name))))