X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=4005dc83fac1473ed79c337025286e5564108676;hb=4f87ff15a8a6259e59a297fcf74b0c6c8f60c1c4;hp=f3283547cc4560ba00e70c0dd1aa3da41d3438ea;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index f328354..4005dc8 100644
--- a/contrib/asdf/asdf.lisp
+++ b/contrib/asdf/asdf.lisp
@@ -1,4 +1,4 @@
-;;; This is asdf: Another System Definition Facility.  $Revision$
+;;; 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
@@ -95,10 +96,13 @@
            #:missing-component
            #:missing-dependency
            #:circular-dependency        ; errors
+           #:duplicate-names
 
            #:retry
            #:accept                     ; restarts
 
+           #:preference-file-for-system/operation
+           #:load-preferences
            )
   (:use :cl))
 
@@ -108,7 +112,7 @@
 
 (in-package #:asdf)
 
-(defvar *asdf-revision* (let* ((v "$Revision$")
+(defvar *asdf-revision* (let* ((v "1.102")
                                (colon (or (position #\: v) -1))
                                (dot (position #\. v)))
                           (and v colon dot
@@ -157,6 +161,9 @@ and NIL NAME and TYPE components"
 (define-condition circular-dependency (system-definition-error)
   ((components :initarg :components :reader circular-dependency-components)))
 
+(define-condition duplicate-names (system-definition-error)
+  ((name :initarg :name :reader duplicate-names-name)))
+
 (define-condition missing-component (system-definition-error)
   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    (version :initform nil :reader missing-version :initarg :version)
@@ -281,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
 
@@ -355,6 +363,14 @@ and NIL NAME and TYPE components"
           (if (and file (probe-file file))
               (return file)))))))
 
+(defun make-temporary-package ()
+  (flet ((try (counter)
+           (ignore-errors
+                   (make-package (format nil "ASDF~D" counter)
+                                 :use '(:cl :asdf)))))
+    (do* ((counter 0 (+ counter 1))
+          (package (try counter) (try counter)))
+         (package package))))
 
 (defun find-system (name &optional (error-p t))
   (let* ((name (coerce-name name))
@@ -363,15 +379,18 @@ and NIL NAME and TYPE components"
     (when (and on-disk
                (or (not in-memory)
                    (< (car in-memory) (file-write-date on-disk))))
-      (let ((*package* (make-package (gensym #.(package-name *package*))
-                                     :use '(:cl :asdf))))
-        (format *verbose-out*
+      (let ((package (make-temporary-package)))
+        (unwind-protect
+             (let ((*package* package))
+               (format
+                *verbose-out*
                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                 ;; ON-DISK), but CMUCL barfs on that.
                 on-disk
                 *package*)
-        (load on-disk)))
+               (load on-disk))
+          (delete-package package))))
     (let ((in-memory (gethash name *defined-systems*)))
       (if in-memory
           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
@@ -425,17 +444,20 @@ system."))
 (defmethod source-file-type ((c static-file) (s module)) nil)
 
 (defmethod component-relative-pathname ((component source-file))
-  (let* ((*default-pathname-defaults* (component-parent-pathname component))
-         (name-type
-          (make-pathname
-           :name (component-name component)
-           :type (source-file-type component
-                                   (component-system component)))))
-    (if (slot-value component 'relative-pathname)
+  (let ((relative-pathname (slot-value component 'relative-pathname)))
+    (if relative-pathname
         (merge-pathnames
-         (slot-value component 'relative-pathname)
-         name-type)
-        name-type)))
+         relative-pathname
+         (make-pathname
+          :type (source-file-type component (component-system component))))
+        (let* ((*default-pathname-defaults*
+                (component-parent-pathname component))
+               (name-type
+                (make-pathname
+                 :name (component-name component)
+                 :type (source-file-type component
+                                         (component-system component)))))
+          name-type))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; operations
@@ -565,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
@@ -698,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
@@ -707,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)
@@ -739,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)))
@@ -758,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)))
@@ -793,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"
@@ -874,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)
@@ -926,18 +1003,31 @@ Returns the new tree (which probably shares structure with the old one)"
               ;; remove-keys form.  important to keep them in sync
               components pathname default-component-class
               perform explain output-files operation-done-p
+              weakly-depends-on
               depends-on serial in-order-to
               ;; list ends
               &allow-other-keys) options
-    (check-component-input type name depends-on components in-order-to)
+    (check-component-input type name weakly-depends-on depends-on components in-order-to)
+
+    (when (and parent
+             (find-component parent name)
+             ;; ignore the same object when rereading the defsystem
+             (not
+              (typep (find-component parent name)
+                     (class-for-type parent type))))
+      (error 'duplicate-names :name name))
+
     (let* ((other-args (remove-keys
                         '(components pathname default-component-class
                           perform explain output-files operation-done-p
+                          weakly-depends-on
                           depends-on serial in-order-to)
                         rest))
            (ret
             (or (find-component parent name)
                 (make-instance (class-for-type parent type)))))
+      (when weakly-depends-on
+        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
       (when (boundp '*serial-depends-on*)
         (setf depends-on
               (concatenate 'list *serial-depends-on* depends-on)))
@@ -958,7 +1048,19 @@ Returns the new tree (which probably shares structure with the old one)"
                       for c = (parse-component-form ret c-form)
                       collect c
                       if serial
-                      do (push (component-name c) *serial-depends-on*)))))
+                      do (push (component-name c) *serial-depends-on*))))
+
+        ;; check for duplicate names
+        (let ((name-hash (make-hash-table :test #'equal)))
+          (loop for c in (module-components ret)
+                do
+                (if (gethash (component-name c)
+                             name-hash)
+                    (error 'duplicate-names
+                           :name (component-name c))
+                  (setf (gethash (component-name c)
+                                 name-hash)
+                        t)))))
 
       (setf (slot-value ret 'in-order-to)
             (union-of-dependencies
@@ -984,11 +1086,15 @@ Returns the new tree (which probably shares structure with the old one)"
                   (component-inline-methods ret))))
       ret)))
 
-(defun check-component-input (type name depends-on components in-order-to)
+(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
   "A partial test of the values of a component."
+  (when weakly-depends-on (warn "We got one! XXXXX"))
   (unless (listp depends-on)
     (sysdef-error-component ":depends-on must be a list."
                             type name depends-on))
+  (unless (listp weakly-depends-on)
+    (sysdef-error-component ":weakly-depends-on must be a list."
+                            type name weakly-depends-on))
   (unless (listp components)
     (sysdef-error-component ":components must be NIL or a list of components."
                             type name components))
@@ -1015,14 +1121,15 @@ 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
-      "/bin/sh"
+      #+win32 "sh" #-win32 "/bin/sh"
       (list  "-c" command)
+      #+win32 #+win32 :search t
       :input nil :output *verbose-out*))
 
     #+(or cmu scl)
@@ -1082,14 +1189,24 @@ output to *verbose-out*.  Returns the shell's exit code."
           (asdf:operate 'asdf:load-op name)
           t))))
 
-  (pushnew
-   '(merge-pathnames "systems/"
-     (truename (sb-ext:posix-getenv "SBCL_HOME")))
-   *central-registry*)
+  (defun contrib-sysdef-search (system)
+    (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
@@ -1097,6 +1214,8 @@ output to *verbose-out*.  Returns the shell's exit code."
      (user-homedir-pathname))
    *central-registry*)
 
-  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
+  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
+  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
 
 (provide 'asdf)
+