Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacHaskell 2.2/support/compile.scm

Text File | 1994-09-27 | 14.3 KB | 448 lines | [TEXT/CCL2]

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