X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=contrib%2Fasdf%2Fasdf.lisp;h=336ad49f9f422e25477a42351246063d2df6485f;hb=e9a993b24fefb6ca1f4a8c40a5063053a01090af;hp=a987d9ff501fa3812beb827d406296f2bc4ac4d1;hpb=18b2c49c37c61160d8594c0ec00028bff55e41f6;p=sbcl.git

diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp
index a987d9f..336ad49 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.92
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome: please mail to
 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -95,7 +95,8 @@
 	   #:missing-component
 	   #:missing-dependency
 	   #:circular-dependency	; errors
-
+	   #:duplicate-names
+	   
 	   #:retry
 	   #:accept                     ; restarts
 	   
@@ -108,7 +109,7 @@
 
 (in-package #:asdf)
 
-(defvar *asdf-revision* (let* ((v "$Revision$")
+(defvar *asdf-revision* (let* ((v "1.92")
 			       (colon (or (position #\: v) -1))
 			       (dot (position #\. v)))
 			  (and v colon dot 
@@ -157,6 +158,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)
@@ -926,21 +930,34 @@ 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)))
+	      (concatenate 'list *serial-depends-on* depends-on)))      
       (apply #'reinitialize-instance
 	     ret
 	     :name (coerce-name name)
@@ -958,7 +975,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 +1013,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))
@@ -1082,10 +1115,17 @@ 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* ((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)))
   
   (pushnew
    '(merge-pathnames "site-systems/"
@@ -1097,6 +1137,7 @@ 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)