home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / clever.lisp < prev    next >
Encoding:
Text File  |  1991-09-09  |  3.5 KB  |  123 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-HACKS; -*-
  2. ; File clever.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. (export '(clever-load))
  5.  
  6. (eval-when (eval load compile)
  7.   (when (find-if #'(lambda (feature)
  8.              (and (symbolp feature)
  9.               (string= (symbol-name feature) "DEC")))
  10.          *features*)
  11.     (pushnew ':DEC *features*)))
  12.  
  13. (eval-when (eval load compile)
  14.   (when (find-if #'(lambda (feature)
  15.              (and (symbolp feature)
  16.               (string= (symbol-name feature) "VMS")))
  17.          *features*)
  18.     (pushnew ':VMS *features*)))
  19.  
  20. ; File loader
  21.  
  22. (defun source-file-type (pathname)
  23.   (or #+Symbolics (car (zl:send pathname
  24.                 ':types-for-canonical-type
  25.                 ':lisp))
  26.       #+(and :DEC :Ultrix) "lsp"
  27.       #+:VMS "LSP"
  28.       #+:ccl "LISP"            ;Coral
  29.       #+allegro "cl"
  30.       "lisp"                ;For Unix, Exploder, and anyone else
  31.       ))
  32.  
  33. (defun object-file-type (pathname)
  34.   (or #+Symbolics (car (zl:send pathname
  35.                 ':types-for-canonical-type
  36.                 si:*default-binary-file-type*))
  37.       #+Explorer  "xld"
  38.       #+(and :DEC :Ultrix) "fas"
  39.       #+(and :DEC :VMS) "FAS"
  40.       #+Lucid (car lucid::*load-binary-pathname-types*)  ;?
  41.       #+KCL "o"
  42.       #+:ccl "FASL"            ;Coral
  43.       #+allegro "fasl"
  44.       ))   ;(or) => nil otherwise
  45.  
  46. (defun clever-load (filespec &rest keys
  47.                  &key source-type
  48.                   object-type
  49.                   (compile-if-necessary nil)
  50.                   (verbose :not-very)
  51.                   (message "")
  52.                  &allow-other-keys)
  53.   (let* ((path (merge-pathnames (if (symbolp filespec)
  54.                     (symbol-name filespec)
  55.                     filespec)
  56.                 (make-pathname :type nil
  57.                            :defaults *default-pathname-defaults*)))
  58.      (source-type (or source-type (source-file-type path)))
  59.      (object-type (or object-type (object-file-type path))))
  60.     (flet ((load-it (path)
  61.          (apply #'load
  62.             path
  63.             :verbose (cond ((eq verbose :not-very)
  64.                     (format t "~&Loading ~A ~A~%"
  65.                         (namestring path)
  66.                         message)
  67.                     nil)
  68.                    (t
  69.                     (format t "~&Loading ~A~%"
  70.                         message)
  71.                     verbose))
  72.             :allow-other-keys t
  73.             keys))
  74.        (compile-it (src obj)
  75.          (apply #'compile-file src
  76.             :output-file obj
  77.             #+:DEC :listing #+:DEC t
  78.             :allow-other-keys t
  79.             keys)))
  80.     (cond ((and (pathname-type path)    ;No ifs, ands, or buts
  81.             (not (eq (pathname-type path) :unspecific)))
  82.            (load-it (truename path)))
  83.           ((or (not source-type) (not object-type))
  84.            (when compile-if-necessary
  85.          (cerror "Load file ~S without checking to see whether ~
  86.               it needs to be compiled."
  87.              "CLEVER-LOAD improperly configured -- it doesn't ~
  88.               have necessary file type information."
  89.              (namestring path)))
  90.            (load-it path))
  91.           (t
  92.            (let* ((src (make-pathname :type source-type
  93.                       :defaults path))
  94.               (src? (probe-file src))
  95.               (obj (make-pathname :type object-type
  96.                       :defaults path))
  97.               (obj? (probe-file obj)))
  98.          (cond ((not src?)
  99.             (warn "~A not found, attempting to load ~A."
  100.                   (namestring src) (namestring obj))
  101.             (load-it (or obj? obj)))
  102.                ((not obj?)
  103.             (cond (compile-if-necessary
  104.                    (compile-it src obj)
  105.                    (load-it obj))
  106.                   (t
  107.                    (load-it src?))))
  108.                ((let ((obj-date (file-write-date obj?))
  109.                   (src-date (file-write-date src?)))
  110.               (or (not obj-date)
  111.                   (not src-date)
  112.                   (>= obj-date src-date)))
  113.             (load-it obj?))
  114.                (compile-if-necessary
  115.             (compile-it src obj)
  116.             (load-it obj))
  117.                (t
  118.             (format *error-output*
  119.                 "~&There is an object file ~A,~
  120.                     ~%but loading source because it's newer.~%"
  121.                 (namestring obj?))
  122.             (load-it src?)))))))))
  123.