compile-and-load.lsp 1.96 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2
#-(and gcl (not ansi-cl)) (in-package :common-lisp-user)
#+(and gcl (not ansi-cl)) (in-package "USER")
3

4 5 6 7 8
#+allegro
(progn
  (setq *ignore-package-name-case* t)
  (when (eq excl:*current-case-mode* :case-sensitive-lower)
    (push :lower-case *features*)))
9

10
(eval-when (:load-toplevel :compile-toplevel :execute)
pfdietz's avatar
pfdietz committed
11
  ;; (intern "==>" "CL-USER")
12 13 14 15
  (unless (fboundp 'compile-file-pathname)
    (defun compile-file-pathname (pathname)
      (make-pathname :defaults pathname :type "o"))))

16 17 18 19 20 21
;;; On-demand compile and load

(defvar *compiled-and-loaded-files* nil
  "List containing pathname, creation times for files that have already
   been loaded.")

22 23 24
(defun compile-and-load* (pathspec &key force)
  (compile-and-load (merge-pathnames pathspec *aux-dir*) :force force))

25
(defun compile-and-load (pathspec &key force)
26 27 28
  "Find the file indicated by PATHSPEC, compiling it first if
   the associated compiled file is out of date."
  (let* ((pathname (pathname pathspec))
sds's avatar
sds committed
29 30 31 32 33 34 35 36 37
         (pathname (if *load-pathname*
                       (merge-pathnames pathname *load-pathname*)
                     pathname))
         (former-data (assoc pathname *compiled-and-loaded-files*
                             :test #'equalp))
         (compile-pathname (compile-file-pathname pathname))
         (source-write-time (file-write-date pathname))
         (target-write-time (and (probe-file compile-pathname)
                                 (file-write-date compile-pathname))))
38
    (unless (and (not force)
sds's avatar
sds committed
39 40
                 former-data
                 (>= (cadr former-data) source-write-time))
41
      (when (or (not target-write-time)
sds's avatar
sds committed
42 43 44 45 46
                (<= target-write-time source-write-time))
        (handler-bind
         #-sbcl ()
         #+sbcl ((sb-ext:code-deletion-note #'muffle-warning))
         (compile-file pathname)))
47
      (if former-data
sds's avatar
sds committed
48 49
          (setf (cadr former-data) source-write-time)
        (push (list pathname source-write-time) *compiled-and-loaded-files*))
50
      (load compile-pathname))))