source: trunk/source/tests/ansi-tests/compile-and-load.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 1.7 KB
Line 
1#-(and gcl (not ansi-cl)) (in-package :common-lisp-user)
2#+(and gcl (not ansi-cl)) (in-package "USER")
3
4#+allegro
5(progn
6  (setq *ignore-package-name-case* t)
7  (when (eq excl:*current-case-mode* :case-sensitive-lower)
8    (push :lower-case *features*)))
9
10(eval-when (:load-toplevel :compile-toplevel :execute)
11  ;; (intern "==>" "CL-USER")
12  (unless (fboundp 'compile-file-pathname)
13    (defun compile-file-pathname (pathname)
14      (make-pathname :defaults pathname :type "o"))))
15
16;;; On-demand compile and load
17
18(defvar *compiled-and-loaded-files* nil
19  "List containing pathname, creation times for files that have already
20   been loaded.")
21
22(defun compile-and-load (pathspec &key force)
23  "Find the file indicated by PATHSPEC, compiling it first if
24   the associated compiled file is out of date."
25  (let* ((pathname (pathname pathspec))
26         (pathname (if *load-pathname*
27                       (merge-pathnames pathname *load-pathname*)
28                     pathname))             
29         (former-data (assoc pathname *compiled-and-loaded-files*
30                             :test #'equalp))
31         (compile-pathname (compile-file-pathname pathname))
32         (source-write-time (file-write-date pathname))
33         (target-write-time (and (probe-file compile-pathname)
34                                 (file-write-date compile-pathname))))
35    (unless (and (not force)
36                 former-data
37                 (>= (cadr former-data) source-write-time))
38      (when (or (not target-write-time)
39                (<= target-write-time source-write-time))
40        (handler-bind
41         #-sbcl ()
42         #+sbcl ((sb-ext:code-deletion-note #'muffle-warning))
43         (compile-file pathname)))
44      (if former-data
45          (setf (cadr former-data) source-write-time)
46        (push (list pathname source-write-time) *compiled-and-loaded-files*))
47      (load compile-pathname))))
Note: See TracBrowser for help on using the repository browser.