X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=b1ad18477ce21744f61ddb7d7dde63f39ffb1ba1;hb=ce2002271034469dc3ccdcaef7d13db76403b90d;hp=b0006ed09c74e41e0b01fc028e25fc276b5aecae;hpb=4fcb3af93227cd8c35aba48f6e18834753c9e0f6;p=sbcl.git

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index b0006ed..b1ad184 100644
--- a/contrib/asdf/asdf.lisp
+++ b/contrib/asdf/asdf.lisp
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  1.97
+;;; 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.97")
+(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
 
@@ -730,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
@@ -739,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)
@@ -771,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)))
@@ -790,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)))
@@ -825,10 +832,43 @@ 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 &key (verbose t) version)
+(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))
@@ -906,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)
@@ -1145,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 (and home (not (string= 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 (and home (not (string= home "")))
+        (merge-pathnames "site-systems/" (truename home))))
    *central-registry*)
 
   (pushnew
@@ -1170,3 +1218,4 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
   (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
 
 (provide 'asdf)
+