X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=4005dc83fac1473ed79c337025286e5564108676;hb=74b85683465d011de59b1ca9486f55d594fb43d6;hp=ad2e99c828c47fd9116d8c9dd06931e1ad545c61;hpb=11e1cd9c04181469f61558abd6133f085c0914fb;p=sbcl.git

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index ad2e99c..4005dc8 100644
--- a/contrib/asdf/asdf.lisp
+++ b/contrib/asdf/asdf.lisp
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  1.94
+;;; This is asdf: Another System Definition Facility.  1.102
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome: please mail to
 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -78,6 +78,7 @@
            #:system-author
            #:system-maintainer
            #:system-license
+           #:system-licence
 
            #:operation-on-warnings
            #:operation-on-failure
@@ -100,6 +101,8 @@
            #:retry
            #:accept                     ; restarts
 
+           #:preference-file-for-system/operation
+           #:load-preferences
            )
   (:use :cl))
 
@@ -109,7 +112,7 @@
 
 (in-package #:asdf)
 
-(defvar *asdf-revision* (let* ((v "1.94")
+(defvar *asdf-revision* (let* ((v "1.102")
                                (colon (or (position #\: v) -1))
                                (dot (position #\. v)))
                           (and v colon dot
@@ -285,7 +288,8 @@ and NIL NAME and TYPE components"
     :accessor system-long-description :initarg :long-description)
    (author :accessor system-author :initarg :author)
    (maintainer :accessor system-maintainer :initarg :maintainer)
-   (licence :accessor system-licence :initarg :licence)))
+   (licence :accessor system-licence :initarg :licence
+            :accessor system-license :initarg :license)))
 
 ;;; version-satisfies
 
@@ -583,26 +587,40 @@ system."))
 (defmethod input-files ((operation operation) (c module)) nil)
 
 (defmethod operation-done-p ((o operation) (c component))
-  (let ((out-files (output-files o c))
-        (in-files (input-files o c)))
-    (cond ((and (not in-files) (not out-files))
-           ;; arbitrary decision: an operation that uses nothing to
-           ;; produce nothing probably isn't doing much
-           t)
-          ((not out-files)
-           (let ((op-done
-                  (gethash (type-of o)
-                           (component-operation-times c))))
-             (and op-done
-                  (>= op-done
-                      (or (apply #'max
-                                 (mapcar #'file-write-date in-files)) 0)))))
-          ((not in-files) nil)
-          (t
-           (and
-            (every #'probe-file out-files)
-            (> (apply #'min (mapcar #'file-write-date out-files))
-               (apply #'max (mapcar #'file-write-date in-files)) ))))))
+  (flet ((fwd-or-return-t (file)
+           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
+           ;; user or some other agent has deleted an input file.  If
+           ;; that's the case, well, that's not good, but as long as
+           ;; the operation is otherwise considered to be done we
+           ;; could continue and survive.
+           (let ((date (file-write-date file)))
+             (cond
+               (date)
+               (t
+                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
+                       operation ~S on component ~S as done.~@:>"
+                      file o c)
+                (return-from operation-done-p t))))))
+    (let ((out-files (output-files o c))
+          (in-files (input-files o c)))
+      (cond ((and (not in-files) (not out-files))
+             ;; arbitrary decision: an operation that uses nothing to
+             ;; produce nothing probably isn't doing much
+             t)
+            ((not out-files)
+             (let ((op-done
+                    (gethash (type-of o)
+                             (component-operation-times c))))
+               (and op-done
+                    (>= op-done
+                        (apply #'max
+                               (mapcar #'fwd-or-return-t in-files))))))
+            ((not in-files) nil)
+            (t
+             (and
+              (every #'probe-file out-files)
+              (> (apply #'min (mapcar #'file-write-date out-files))
+                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
 
 ;;; So you look at this code and think "why isn't it a bunch of
 ;;; methods".  And the answer is, because standard method combination
@@ -716,7 +734,8 @@ system."))
 
 (defmethod perform :after ((operation operation) (c component))
   (setf (gethash (type-of operation) (component-operation-times c))
-        (get-universal-time)))
+        (get-universal-time))
+  (load-preferences c operation))
 
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
@@ -725,8 +744,8 @@ system."))
   (let ((source-file (component-pathname c))
         (output-file (car (output-files operation c))))
     (multiple-value-bind (output warnings-p failure-p)
-        (compile-file source-file
-                      :output-file output-file)
+                         (compile-file source-file
+                                       :output-file output-file)
       ;(declare (ignore output))
       (when warnings-p
         (case (operation-on-warnings operation)
@@ -757,7 +776,9 @@ system."))
 
 ;;; load-op
 
-(defclass load-op (operation) ())
+(defclass basic-load-op (operation) ())
+
+(defclass load-op (basic-load-op) ())
 
 (defmethod perform ((o load-op) (c cl-source-file))
   (mapcar #'load (input-files o c)))
@@ -776,7 +797,7 @@ system."))
 
 ;;; load-source-op
 
-(defclass load-source-op (operation) ())
+(defclass load-source-op (basic-load-op) ())
 
 (defmethod perform ((o load-source-op) (c cl-source-file))
   (let ((source (component-pathname c)))
@@ -811,40 +832,73 @@ system."))
 (defmethod perform ((operation test-op) (c component))
   nil)
 
+(defgeneric load-preferences (system operation)
+  (:documentation "Called to load system preferences after <perform operation system>. Typical uses are to set parameters that don't exist until after the system has been loaded."))
+
+(defgeneric preference-file-for-system/operation (system operation)
+  (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load."))
+
+(defmethod load-preferences ((s t) (operation t))
+  ;; do nothing
+  (values))
+
+(defmethod load-preferences ((s system) (operation basic-load-op))
+  (let* ((*package* (find-package :common-lisp))
+         (file (probe-file (preference-file-for-system/operation s operation))))
+    (when file
+      (when *verbose-out*
+        (format *verbose-out*
+                "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
+                (component-name s)
+                (type-of operation) file))
+      (load file))))
+
+(defmethod preference-file-for-system/operation ((system t) (operation t))
+  ;; cope with anything other than systems
+  (preference-file-for-system/operation (find-system system t) operation))
+
+(defmethod preference-file-for-system/operation ((s system) (operation t))
+  (merge-pathnames
+   (make-pathname :name (component-name s)
+                  :type "lisp"
+                  :directory '(:relative ".asdf"))
+   (truename (user-homedir-pathname))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; invoking operations
 
-(defun operate (operation-class system &rest args)
+(defun operate (operation-class system &rest args &key (verbose t) version
+                                &allow-other-keys)
   (let* ((op (apply #'make-instance operation-class
-                    :original-initargs args args))
-         (*verbose-out*
-          (if (getf args :verbose t)
-              *trace-output*
-              (make-broadcast-stream)))
-         (system (if (typep system 'component) system (find-system system)))
-         (steps (traverse op system)))
-    (with-compilation-unit ()
-      (loop for (op . component) in steps do
-            (loop
-             (restart-case
-                 (progn (perform op component)
-                        (return))
-               (retry ()
-                 :report
-                 (lambda (s)
-                   (format s "~@<Retry performing ~S on ~S.~@:>"
-                           op component)))
-               (accept ()
-                 :report
-                 (lambda (s)
-                   (format s
-                           "~@<Continue, treating ~S on ~S as ~
-                            having been successful.~@:>"
-                           op component))
-                 (setf (gethash (type-of op)
-                                (component-operation-times component))
-                       (get-universal-time))
-                 (return))))))))
+                    :original-initargs args
+                    args))
+         (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
+         (system (if (typep system 'component) system (find-system system))))
+    (unless (version-satisfies system version)
+      (error 'missing-component :requires system :version version))
+    (let ((steps (traverse op system)))
+      (with-compilation-unit ()
+        (loop for (op . component) in steps do
+             (loop
+                (restart-case
+                    (progn (perform op component)
+                           (return))
+                  (retry ()
+                    :report
+                    (lambda (s)
+                      (format s "~@<Retry performing ~S on ~S.~@:>"
+                              op component)))
+                  (accept ()
+                    :report
+                    (lambda (s)
+                      (format s
+                              "~@<Continue, treating ~S on ~S as ~
+                               having been successful.~@:>"
+                              op component))
+                    (setf (gethash (type-of op)
+                                   (component-operation-times component))
+                          (get-universal-time))
+                    (return)))))))))
 
 (defun oos (&rest args)
   "Alias of OPERATE function"
@@ -892,11 +946,16 @@ system."))
 
 
 (defun class-for-type (parent type)
-  (let ((class
-         (find-class
-          (or (find-symbol (symbol-name type) *package*)
-              (find-symbol (symbol-name type) #.(package-name *package*)))
-          nil)))
+  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
+                              (find-symbol (symbol-name type)
+                                           #.(package-name *package*))))
+         (class (dolist (symbol (if (keywordp type)
+                                    extra-symbols
+                                    (cons type extra-symbols)))
+                  (when (and symbol
+                             (find-class symbol nil)
+                             (subtypep symbol 'component))
+                    (return (find-class symbol))))))
     (or class
         (and (eq type :file)
              (or (module-default-component-class parent)
@@ -1062,11 +1121,11 @@ Returns the new tree (which probably shares structure with the old one)"
 (defun run-shell-command (control-string &rest args)
   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 synchronously execute the result using a Bourne-compatible shell, with
-output to *verbose-out*.  Returns the shell's exit code."
+output to *VERBOSE-OUT*.  Returns the shell's exit code."
   (let ((command (apply #'format nil control-string args)))
     (format *verbose-out* "; $ ~A~%" command)
     #+sbcl
-    (sb-impl::process-exit-code
+    (sb-ext:process-exit-code
      (sb-ext:run-program
       #+win32 "sh" #-win32 "/bin/sh"
       (list  "-c" command)
@@ -1131,20 +1190,23 @@ output to *verbose-out*.  Returns the shell's exit code."
           t))))
 
   (defun contrib-sysdef-search (system)
-    (let* ((name (coerce-name system))
-           (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
-           (contrib (merge-pathnames
-                     (make-pathname :directory `(:relative ,name)
-                                    :name name
-                                    :type "asd"
-                                    :case :local
-                                    :version :newest)
-                     home)))
-      (probe-file contrib)))
+    (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+      (when home
+        (let* ((name (coerce-name system))
+               (home (truename home))
+               (contrib (merge-pathnames
+                         (make-pathname :directory `(:relative ,name)
+                                        :name name
+                                        :type "asd"
+                                        :case :local
+                                        :version :newest)
+                         home)))
+          (probe-file contrib)))))
 
   (pushnew
-   '(merge-pathnames "site-systems/"
-     (truename (sb-ext:posix-getenv "SBCL_HOME")))
+   '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+      (when home
+        (merge-pathnames "site-systems/" (truename home))))
    *central-registry*)
 
   (pushnew
@@ -1156,3 +1218,4 @@ output to *verbose-out*.  Returns the shell's exit code."
   (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
 
 (provide 'asdf)
+