[armedbear-cvs] r13717 - in branches/1.0.x/abcl: doc/asdf src/org/armedbear/lisp

mevenson at common-lisp.net mevenson at common-lisp.net
Wed Jan 4 21:48:45 UTC 2012


Author: mevenson
Date: Wed Jan  4 13:48:45 2012
New Revision: 13717

Log:
Backport r13702:  update to asdf-2.019 with ABCL patch.

Modified:
   branches/1.0.x/abcl/doc/asdf/asdf.texinfo
   branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp

Modified: branches/1.0.x/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- branches/1.0.x/abcl/doc/asdf/asdf.texinfo	Wed Jan  4 13:41:22 2012	(r13716)
+++ branches/1.0.x/abcl/doc/asdf/asdf.texinfo	Wed Jan  4 13:48:45 2012	(r13717)
@@ -895,7 +895,8 @@
 @example
 system-definition := ( defsystem system-designator @var{system-option}* )
 
-system-option := :defsystem-depends-on system-list
+system-option := :defsystem-depends-on system-list 
+                 | :class class-name (see discussion below)
                  | module-option
                  | option
 
@@ -959,6 +960,25 @@
 the current package @code{my-system-asd} can be specified as
 @code{:my-component-type}, or @code{my-component-type}.
 
+ at subsection System class names
+
+A system class name will be looked up in the same way as a Component
+type (see above).  Typically, one will not need to specify a system
+class name, unless using a non-standard system class defined in some
+ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON},
+see below.  For such class names in the ASDF package, we recommend that
+the @code{:class} option be specified using a keyword symbol, such as
+
+ at example
+:class :MY-NEW-SYSTEM-SUBCLASS
+ at end example
+
+This practice will ensure that package name conflicts are avoided.
+Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into
+the current package @emph{before} it has been exported from the ASDF
+extension loaded by @code{:defsystem-depends-on}, causing a name
+conflict in the current package.
+
 @subsection Defsystem depends on
 
 The @code{:defsystem-depends-on} option to @code{defsystem} allows the
@@ -2830,16 +2850,29 @@
 @section Controlling file compilation
 
 When declaring a component (system, module, file),
-you can specify a keyword argument @code{:around-compile some-symbol}.
-If left unspecified, the value will be inherited from the parent component if any,
-or with a default of @code{nil} if no value is specified in any transitive parent.
-
-The argument must be a either fbound symbol or @code{nil}.
+you can specify a keyword argument @code{:around-compile function}.
+If left unspecified,
+the value will be inherited from the parent component if any,
+or with a default of @code{nil}
+if no value is specified in any transitive parent.
+
+The argument must be a either @code{nil}, a fbound symbol,
+a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)})
+a function object (e.g. using @code{#.#'} but that's discouraged
+because it prevents the introspection done by e.g. asdf-dependency-grovel),
+or a string that when read yields a symbol or a lambda-expression.
 @code{nil} means the normal compile-file function will be called.
-A symbol means the function fbound to it will be called with a single argument,
-a thunk that calls the compile-file function;
-the function you specify must then funcall that thunk
-inside whatever wrapping you want.
+A non-nil value designates a function of one argument
+that will be called with a thunk for calling
+the compile-file function with proper arguments.
+
+Note that by using a string, you may reference
+a function, symbol and/or package
+that will only be created later during the build, but
+isn't yet present at the time the defsystem form is evaluated.
+However, if your entire system is using such a hook, you may have to
+explicitly override the hook with @code{nil} for all the modules and files
+that are compiled before the hook is defined.
 
 Using this hook, you may achieve such effects as:
 locally renaming packages,
@@ -3649,6 +3682,8 @@
   "lis")
 @end lisp
 
+ at comment FIXME: Add a FAQ about how to use a new system class...
+
 
 @node  TODO list, Inspiration, FAQ, Top
 @comment  node-name,  next,  previous,  up

Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp	Wed Jan  4 13:41:22 2012	(r13716)
+++ branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp	Wed Jan  4 13:48:45 2012	(r13717)
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.017.22: Another System Definition Facility.
+;;; This is ASDF 2.019: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -56,7 +56,7 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;;; Implementation-dependent tweaks
-  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
+  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
         (remove "asdf" excl::*autoload-package-name-alist*
@@ -86,6 +86,8 @@
     (find-symbol (string s) p))
   ;; Strip out formatting that is not supported on Genera.
   ;; Has to be inside the eval-when to make Lispworks happy (!)
+  (defun strcat (&rest strings)
+    (apply 'concatenate 'string strings))
   (defmacro compatfmt (format)
     #-(or gcl genera) format
     #+(or gcl genera)
@@ -97,10 +99,8 @@
            ("~@:>" . "")
            ("~:>" . ""))) :do
       (loop :for found = (search unsupported format) :while found :do
-        (setf format
-              (concatenate 'simple-string
-                           (subseq format 0 found) replacement
-                           (subseq format (+ found (length unsupported)))))))
+        (setf format (strcat (subseq format 0 found) replacement
+                             (subseq format (+ found (length unsupported)))))))
     format)
   (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
          ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
@@ -110,7 +110,7 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.017.22")
+         (asdf-version "2.019")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -188,7 +188,7 @@
                      (push sym bothly-exported-symbols)
                      (push sym formerly-exported-symbols)))
                (loop :for sym :in export :do
-                 (unless (member sym bothly-exported-symbols :test 'string-equal)
+                 (unless (member sym bothly-exported-symbols :test 'equal)
                    (push sym newly-exported-symbols)))
                (loop :for user :in (package-used-by-list package)
                  :for shadowing = (package-shadowing-symbols user) :do
@@ -229,23 +229,19 @@
             #:compile-file* #:source-file-type)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
-            #:split #:make-collector
+            #:split #:make-collector #:do-dep #:do-one-dep
+            #:resolve-relative-location-component #:resolve-absolute-location-component
             #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
            :export
-           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
+           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
             #:system-definition-pathname #:with-system-definitions
-            #:search-for-system-definition #:find-component ; miscellaneous
-            #:compile-system #:load-system #:test-system #:clear-system
-            #:compile-op #:load-op #:load-source-op
-            #:test-op
-            #:operation               ; operations
-            #:feature                 ; sort-of operation
-            #:version                 ; metaphorically sort-of an operation
-            #:version-satisfies
+            #:search-for-system-definition #:find-component #:component-find-path
+            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
+            #:operation #:compile-op #:load-op #:load-source-op #:test-op
+            #:feature #:version #:version-satisfies
             #:upgrade-asdf
             #:implementation-identifier #:implementation-type
-
-            #:input-files #:output-files #:output-file #:perform ; operation methods
+            #:input-files #:output-files #:output-file #:perform
             #:operation-done-p #:explain
 
             #:component #:source-file
@@ -337,11 +333,19 @@
             #:process-source-registry
             #:system-registered-p
             #:asdf-message
+            #:user-output-translations-pathname
+            #:system-output-translations-pathname
+            #:user-output-translations-directory-pathname
+            #:system-output-translations-directory-pathname
+            #:user-source-registry
+            #:system-source-registry
+            #:user-source-registry-directory
+            #:system-source-registry-directory
 
             ;; Utilities
             #:absolute-pathname-p
             ;; #:aif #:it
-            ;; #:appendf
+            ;; #:appendf #:orf
             #:coerce-name
             #:directory-pathname-p
             ;; #:ends-with
@@ -349,8 +353,7 @@
             #:getenv
             ;; #:length=n-p
             ;; #:find-symbol*
-            #:merge-pathnames*
-            #:coerce-pathname
+            #:merge-pathnames* #:coerce-pathname #:subpathname
             #:pathname-directory-pathname
             #:read-file-forms
             ;; #:remove-keys
@@ -413,6 +416,7 @@
                 condition-arguments condition-form
                 condition-format condition-location
                 coerce-name)
+         (ftype (function (&optional t) (values)) initialize-source-registry)
          #-(or cormanlisp gcl-pre2.7)
          (ftype (function (t t) t) (setf module-components-by-name)))
 
@@ -421,8 +425,8 @@
 #+cormanlisp
 (progn
   (deftype logical-pathname () nil)
-  (defun* make-broadcast-stream () *error-output*)
-  (defun* file-namestring (p)
+  (defun make-broadcast-stream () *error-output*)
+  (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
 
@@ -522,6 +526,9 @@
               :do (pop reldir) (pop defrev)
               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
 
+(defun* ununspecific (x)
+  (if (eq x :unspecific) nil x))
+
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
 if the SPECIFIED pathname does not have an absolute directory,
@@ -540,9 +547,7 @@
          (name (or (pathname-name specified) (pathname-name defaults)))
          (type (or (pathname-type specified) (pathname-type defaults)))
          (version (or (pathname-version specified) (pathname-version defaults))))
-    (labels ((ununspecific (x)
-               (if (eq x :unspecific) nil x))
-             (unspecific-handler (p)
+    (labels ((unspecific-handler (p)
                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
       (multiple-value-bind (host device directory unspecific-handler)
           (ecase (first directory)
@@ -893,24 +898,21 @@
         (host (pathname-host pathname))
         (port (ext:pathname-port pathname))
         (directory (pathname-directory pathname)))
-    (flet ((not-unspecific (component)
-             (and (not (eq component :unspecific)) component)))
-      (cond ((or (not-unspecific port)
-                 (and (not-unspecific host) (plusp (length host)))
-                 (not-unspecific scheme))
-             (let ((prefix ""))
-               (when (not-unspecific port)
-                 (setf prefix (format nil ":~D" port)))
-               (when (and (not-unspecific host) (plusp (length host)))
-                 (setf prefix (concatenate 'string host prefix)))
-               (setf prefix (concatenate 'string ":" prefix))
-               (when (not-unspecific scheme)
-               (setf prefix (concatenate 'string scheme prefix)))
-               (assert (and directory (eq (first directory) :absolute)))
-               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
-                              :defaults pathname)))
-            (t
-             pathname)))))
+    (if (or (ununspecific port)
+            (and (ununspecific host) (plusp (length host)))
+            (ununspecific scheme))
+        (let ((prefix ""))
+          (when (ununspecific port)
+            (setf prefix (format nil ":~D" port)))
+          (when (and (ununspecific host) (plusp (length host)))
+            (setf prefix (strcat host prefix)))
+          (setf prefix (strcat ":" prefix))
+          (when (ununspecific scheme)
+            (setf prefix (strcat scheme prefix)))
+          (assert (and directory (eq (first directory) :absolute)))
+          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+                         :defaults pathname)))
+    pathname))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
@@ -1173,45 +1175,6 @@
    (properties :accessor component-properties :initarg :properties
                :initform nil)))
 
-;;; I believe that the following could probably be more efficiently done
-;;; by a primary method that invokes SHARED-INITIALIZE in a way that would
-;;; appropriately pass the slots to have their initforms re-applied, but I
-;;; do not know how to write such a method. [2011/09/02:rpg]
-(defmethod reinitialize-instance :after ((obj component) &rest initargs
-                                         &key (version nil version-suppliedp)
-                                              (description nil description-suppliedp)
-                                              (long-description nil
-                                                                long-description-suppliedp)
-                                              (load-dependencies nil
-                                                                 ld-suppliedp)
-                                              in-order-to
-                                              do-first
-                                              inline-methods
-                                              parent
-                                              properties)
-  "We reuse component objects from previously-existing systems, so we need to
-make sure we clear them thoroughly."
-  (declare (ignore initargs load-dependencies
-                   long-description description version))
-  ;; this is a cache and should be cleared
-  (slot-makunbound obj 'absolute-pathname)
-  ;; component operation times are no longer valid when the component changes
-  (clrhash (component-operation-times obj))
-  (unless version-suppliedp (slot-makunbound obj 'version))
-  (unless description-suppliedp
-    (slot-makunbound obj 'description))
-  (unless long-description-suppliedp
-    (slot-makunbound obj 'long-description))
-  ;; replicate the logic of the initforms...
-  (unless ld-suppliedp
-    (setf (component-load-dependencies obj) nil))
-  (setf (component-in-order-to obj) in-order-to
-        (component-do-first obj) do-first
-        (component-inline-methods obj) inline-methods
-        (slot-value obj 'parent) parent
-        (slot-value obj 'properties) properties))
-
-
 (defun* component-find-path (component)
   (reverse
    (loop :for c = component :then (component-parent c)
@@ -1284,21 +1247,6 @@
     :initarg :default-component-class
     :accessor module-default-component-class)))
 
-;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
-;;; [2011/09/02:rpg]
-(defmethod reinitialize-instance :after ((obj module) &rest initargs &key)
-  "Clear MODULE's slots so it can be reused."
-  (slot-makunbound obj 'components-by-name)
-  ;; this may be a more elegant approach than in the
-  ;; COMPONENT method [2011/09/02:rpg]
-  (loop :for (initarg slot-name default) :in
-        `((:components components nil)
-          (:if-component-dep-fails if-component-dep-fails :fail)
-          (:default-component-class default-component-class
-              ,*default-component-class*))
-        :unless (member initarg initargs)
-        :do (setf (slot-value obj slot-name) default)))
-
 (defun* component-parent-pathname (component)
   ;; No default anymore (in particular, no *default-pathname-defaults*).
   ;; If you force component to have a NULL pathname, you better arrange
@@ -1332,7 +1280,12 @@
               (acons property new-value (slot-value c 'properties)))))
   new-value)
 
-(defclass system (module)
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components slots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) #|(components) (components-by-names)|#))
+
+(defclass system (module proto-system)
   (;; description and long-description are now available for all component's,
    ;; but now also inherited from component, but we add the legacy accessor
    (description :accessor system-description :initarg :description)
@@ -1345,24 +1298,6 @@
                 :writer %set-system-source-file)
    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
 
-;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
-;;; [2011/09/02:rpg]
-(defmethod reinitialize-instance :after ((obj system) &rest initargs &key)
-  "Clear SYSTEM's slots so it can be reused."
-  ;; note that SYSTEM-SOURCE-FILE is very specially handled,
-  ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and
-  ;; not squash it.  SYSTEM COMPONENTS are handled very specially,
-  ;; because they are always, effectively, reused, since the system component
-  ;; is made early in DO-DEFSYSTEM, instead of being made later, in
-  ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]
-  (loop :for (initarg slot-name) :in
-        `((:author author)
-          (:maintainer maintainer)
-          (:licence licence)
-          (:defsystem-depends-on defsystem-depends-on))
-        :unless (member initarg initargs)
-        :do (slot-makunbound obj slot-name)))
-
 ;;;; -------------------------------------------------------------------------
 ;;;; version-satisfies
 
@@ -1450,11 +1385,10 @@
           (file-position s (+ start
                               network-volume-offset
                               #x14))))
-      (concatenate 'string
-        (read-null-terminated-string s)
-        (progn
-          (file-position s (+ start remaining-offset))
-          (read-null-terminated-string s))))))
+      (strcat (read-null-terminated-string s)
+              (progn
+                (file-position s (+ start remaining-offset))
+                (read-null-terminated-string s))))))
 
 (defun* parse-windows-shortcut (pathname)
   (with-open-file (s pathname :element-type '(unsigned-byte 8))
@@ -1541,15 +1475,25 @@
 ;;; for the sake of keeping things reasonably neat, we adopt a
 ;;; convention that functions in this list are prefixed SYSDEF-
 
-(defparameter *system-definition-search-functions*
-  '(sysdef-central-registry-search
-    sysdef-source-registry-search
-    sysdef-find-asdf))
+(defvar *system-definition-search-functions* '())
+
+(setf *system-definition-search-functions*
+      (append
+       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
+       (remove 'contrib-sysdef-search *system-definition-search-functions*)
+       ;; Tuck our defaults at the end of the list if they were absent.
+       ;; This is imperfect, in case they were removed on purpose,
+       ;; but then it will be the responsibility of whoever does that
+       ;; to upgrade asdf before he does such a thing rather than after.
+       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
+                  '(sysdef-central-registry-search
+                    sysdef-source-registry-search
+                    sysdef-find-asdf))))
 
 (defun* search-for-system-definition (system)
-  (let ((system-name (coerce-name system)))
-    (some #'(lambda (x) (funcall x system-name))
-          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
+  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
+        (cons 'find-system-if-being-defined
+              *system-definition-search-functions*)))
 
 (defvar *central-registry* nil
 "A list of 'system directory designators' ASDF uses to find systems.
@@ -1599,7 +1543,7 @@
         (let ((shortcut
                (make-pathname
                 :defaults defaults :version :newest :case :local
-                :name (concatenate 'string name ".asd")
+                :name (strcat name ".asd")
                 :type "lnk")))
           (when (probe-file* shortcut)
             (let ((target (parse-windows-shortcut shortcut)))
@@ -1673,6 +1617,7 @@
         0)))
 
 (defmethod find-system ((name null) &optional (error-p t))
+  (declare (ignorable name))
   (when error-p
     (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
 
@@ -1692,7 +1637,7 @@
       (let ((*systems-being-defined* (make-hash-table :test 'equal)))
         (funcall thunk))))
 
-(defmacro with-system-definitions (() &body body)
+(defmacro with-system-definitions ((&optional) &body body)
   `(call-with-system-definitions #'(lambda () , at body)))
 
 (defun* load-sysdef (name pathname)
@@ -1708,22 +1653,37 @@
              (let ((*package* package)
                    (*default-pathname-defaults*
                     (pathname-directory-pathname pathname)))
+               ;;; XXX Kludge for ABCL ticket #181 
+               #+abcl
+               (when (ext:pathname-jar-p pathname) 
+                 (setf *default-pathname-defaults* 
+                       (make-pathname :device nil :defaults *default-pathname-defaults*)))
                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
                              pathname package)
                (load pathname)))
         (delete-package package)))))
 
-(defmethod find-system ((name string) &optional (error-p t))
-  (with-system-definitions ()
-    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
-           (previous (cdr in-memory))
-           (previous (and (typep previous 'system) previous))
-           (previous-time (car in-memory))
+(defun* locate-system (name)
+  "Given a system NAME designator, try to locate where to load the system from.
+Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
+PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
+PREVIOUS when not null is a previously loaded SYSTEM object of same name.
+PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
+  (let* ((name (coerce-name name))
+         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+         (previous (cdr in-memory))
+         (previous (and (typep previous 'system) previous))
+         (previous-time (car in-memory))
            (found (search-for-system-definition name))
-           (found-system (and (typep found 'system) found))
-           (pathname (or (and (typep found '(or pathname string)) (pathname found))
-                         (and found-system (system-source-file found-system))
-                         (and previous (system-source-file previous)))))
+         (found-system (and (typep found 'system) found))
+         (pathname (or (and (typep found '(or pathname string)) (pathname found))
+                       (and found-system (system-source-file found-system))
+                       (and previous (system-source-file previous))))
+         (foundp (and (or found-system pathname previous) t)))
+    (check-type found (or null pathname system))
+    (when foundp
       (setf pathname (resolve-symlinks* pathname))
       (when (and pathname (not (absolute-pathname-p pathname)))
         (setf pathname (ensure-pathname-absolute pathname))
@@ -1733,23 +1693,37 @@
                                              (system-source-file previous) pathname)))
         (%set-system-source-file pathname previous)
         (setf previous-time nil))
-      (when (and found-system (not previous))
-        (register-system found-system))
-      (when (and pathname
-                 (or (not previous-time)
-                     ;; don't reload if it's already been loaded,
-                     ;; or its filestamp is in the future which means some clock is skewed
-                     ;; and trying to load might cause an infinite loop.
-                     (< previous-time (safe-file-write-date pathname) (get-universal-time))))
-        (load-sysdef name pathname))
-      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
-        (cond
-          (in-memory
-           (when pathname
-             (setf (car in-memory) (safe-file-write-date pathname)))
-           (cdr in-memory))
-          (error-p
-           (error 'missing-component :requires name)))))))
+      (values foundp found-system pathname previous previous-time))))
+
+(defmethod find-system ((name string) &optional (error-p t))
+  (with-system-definitions ()
+    (loop
+      (restart-case
+          (multiple-value-bind (foundp found-system pathname previous previous-time)
+              (locate-system name)
+            (declare (ignore foundp))
+            (when (and found-system (not previous))
+              (register-system found-system))
+            (when (and pathname
+                       (or (not previous-time)
+                           ;; don't reload if it's already been loaded,
+                           ;; or its filestamp is in the future which means some clock is skewed
+                           ;; and trying to load might cause an infinite loop.
+                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
+              (load-sysdef name pathname))
+            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
+              (return
+                (cond
+                  (in-memory
+                   (when pathname
+                     (setf (car in-memory) (safe-file-write-date pathname)))
+                   (cdr in-memory))
+                  (error-p
+                   (error 'missing-component :requires name))))))
+        (reinitialize-source-registry-and-retry ()
+          :report (lambda (s)
+                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
+          (initialize-source-registry))))))
 
 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
   (setf fallback (coerce-name fallback)
@@ -1871,6 +1845,17 @@
    :type (source-file-type component (component-system component))
    :defaults (component-parent-pathname component)))
 
+<<<<<<< .working
+=======
+(defun* subpathname (pathname subpath &key type)
+  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
+                                  (pathname-directory-pathname pathname))))
+
+(defun subpathname* (pathname subpath &key type)
+  (and pathname
+       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
+
+>>>>>>> .merge-right.r13702
 ;;;; -------------------------------------------------------------------------
 ;;;; Operations
 
@@ -1973,10 +1958,9 @@
   (cdr (assoc (type-of o) (component-in-order-to c))))
 
 (defmethod component-self-dependencies ((o operation) (c component))
-  (let ((all-deps (component-depends-on o c)))
-    (remove-if-not #'(lambda (x)
-                       (member (component-name c) (cdr x) :test #'string=))
-                   all-deps)))
+  (remove-if-not
+   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
+   (component-depends-on o c)))
 
 (defmethod input-files ((operation operation) (c component))
   (let ((parent (component-parent c))
@@ -2347,10 +2331,18 @@
     ((component-parent c)
      (around-compile-hook (component-parent c)))))
 
+(defun ensure-function (fun &key (package :asdf))
+  (etypecase fun
+    ((or symbol function) fun)
+    (cons (eval `(function ,fun)))
+    (string (eval `(function ,(with-standard-io-syntax
+                               (let ((*package* (find-package package)))
+                                 (read-from-string fun))))))))
+
 (defmethod call-with-around-compile-hook ((c component) thunk)
   (let ((hook (around-compile-hook c)))
     (if hook
-        (funcall hook thunk)
+        (funcall (ensure-function hook) thunk)
         (funcall thunk))))
 
 (defvar *compile-op-compile-file-function* 'compile-file*
@@ -2536,31 +2528,38 @@
 (defgeneric* operate (operation-class system &key &allow-other-keys))
 (defgeneric* perform-plan (plan &key))
 
+;;;; Separating this into a different function makes it more forward-compatible
+(defun* cleanup-upgraded-asdf (old-version)
+  (let ((new-version (asdf:asdf-version)))
+    (unless (equal old-version new-version)
+      (cond
+        ((version-satisfies new-version old-version)
+         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+                       old-version new-version))
+        ((version-satisfies old-version new-version)
+         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+               old-version new-version))
+        (t
+         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+                       old-version new-version)))
+      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
+        ;; Invalidate all systems but ASDF itself.
+        (setf *defined-systems* (make-defined-systems-table))
+        (register-system asdf)
+        ;; If we're in the middle of something, restart it.
+        (when *systems-being-defined*
+          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
+            (clrhash *systems-being-defined*)
+            (dolist (s l) (find-system s nil))))
+        t))))
+
 ;;;; Try to upgrade of ASDF. If a different version was used, return T.
 ;;;; We need do that before we operate on anything that depends on ASDF.
 (defun* upgrade-asdf ()
   (let ((version (asdf:asdf-version)))
     (handler-bind (((or style-warning warning) #'muffle-warning))
       (operate 'load-op :asdf :verbose nil))
-    (let ((new-version (asdf:asdf-version)))
-      (block nil
-        (cond
-          ((equal version new-version)
-           (return nil))
-          ((version-satisfies new-version version)
-           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
-                         version new-version))
-          ((version-satisfies version new-version)
-           (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
-                 version new-version))
-          (t
-           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
-                         version new-version)))
-        (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
-          ;; invalidate all systems but ASDF itself
-          (setf *defined-systems* (make-defined-systems-table))
-          (register-system asdf)
-          t)))))
+    (cleanup-upgraded-asdf version)))
 
 (defmethod perform-plan ((steps list) &key)
   (let ((*package* *package*)
@@ -2624,7 +2623,7 @@
 "))
   (setf (documentation 'oos 'function)
         (format nil
-                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
+                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
                 operate-docstring))
   (setf (documentation 'operate 'function)
         operate-docstring))
@@ -2636,6 +2635,9 @@
   (apply 'operate 'load-op system args)
   t)
 
+(defun* load-systems (&rest systems)
+  (map () 'load-system systems))
+
 (defun* compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
@@ -2694,7 +2696,7 @@
     (if first-op-tree
         (progn
           (aif (assoc op2 (cdr first-op-tree))
-               (if (find c (cdr it))
+               (if (find c (cdr it) :test #'equal)
                    nil
                    (setf (cdr it) (cons c (cdr it))))
                (setf (cdr first-op-tree)
@@ -2716,8 +2718,7 @@
 (defvar *serial-depends-on* nil)
 
 (defun* sysdef-error-component (msg type name value)
-  (sysdef-error (concatenate 'string msg
-                             (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
                 type name value))
 
 (defun* check-component-input (type name weakly-depends-on
@@ -2794,29 +2795,22 @@
         (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
               version name parent)))
 
-    (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))
+    (let* ((args (list* :name (coerce-name name)
+                        :pathname pathname
+                        :parent parent
+                        (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 (find-component parent name)))
       (when weakly-depends-on
         (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
       (when *serial-depends-on*
         (push *serial-depends-on* depends-on))
-      (if ret
-          (apply 'reinitialize-instance ret
-                 :name (coerce-name name)
-                 :pathname pathname
-                 :parent parent
-                 other-args)
-          (setf ret
-                (apply 'make-instance (class-for-type parent type)
-                       :name (coerce-name name)
-                       :pathname pathname
-                       :parent parent
-                       other-args)))
+      (if ret ; preserve identity
+          (apply 'reinitialize-instance ret args)
+          (setf ret (apply 'make-instance (class-for-type parent type) args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
         (setf (module-default-component-class ret)
@@ -2848,6 +2842,10 @@
       (%refresh-component-inline-methods ret rest)
       ret)))
 
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+  (change-class (change-class system 'proto-system) 'system)
+  (apply 'reinitialize-instance system keys))
+
 (defun* do-defsystem (name &rest options
                            &key (pathname nil pathname-arg-p) (class 'system)
                            defsystem-depends-on &allow-other-keys)
@@ -2860,14 +2858,14 @@
   (with-system-definitions ()
     (let* ((name (coerce-name name))
            (registered (system-registered-p name))
-           (system (cdr (or registered
-                            (register-system (make-instance 'system :name name)))))
+           (registered! (if registered
+                            (rplaca registered (get-universal-time))
+                            (register-system (make-instance 'system :name name))))
+           (system (reset-system (cdr registered!)
+                                :name name :source-file (load-pathname)))
            (component-options (remove-keys '(:class) options)))
-      (%set-system-source-file (load-pathname) system)
       (setf (gethash name *systems-being-defined*) system)
-      (when registered
-        (setf (car registered) (get-universal-time)))
-      (map () 'load-system defsystem-depends-on)
+      (apply 'load-systems defsystem-depends-on)
       ;; We change-class (when necessary) AFTER we load the defsystem-dep's
       ;; since the class might not be defined as part of those.
       (let ((class (class-for-type nil class)))
@@ -2952,7 +2950,7 @@
                 (ccl:run-program
                  (cond
                    ((os-unix-p) "/bin/sh")
-                   ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE!
+                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
                    (t (error "Unsupported OS")))
                  (if (os-unix-p) (list "-c" command) '())
                  :input nil :output *verbose-out* :wait t)))
@@ -2964,6 +2962,9 @@
       (list "-c" command)
       :input nil :output *verbose-out*))
 
+    #+cormanlisp
+    (win32:system command)
+
     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     (ext:system command)
 
@@ -3159,41 +3160,46 @@
     (and ts (values sp ts))))
 (defun* user-configuration-directories ()
   (let ((dirs
-         (flet ((try (x sub) (try-directory-subpath x sub)))
-           `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
-             ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
-                 :for dir :in (split-string dirs :separator ":")
-                 :collect (try dir "common-lisp/"))
-             ,@(when (os-windows-p)
-                 `(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
-                             (getenv "LOCALAPPDATA"))
-                         "common-lisp/config/")
-                    ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-                   ,(try (or #+lispworks (sys:get-folder-path :appdata)
-                             (getenv "APPDATA"))
-                         "common-lisp/config/")))
-             ,(try (user-homedir) ".config/common-lisp/")))))
-    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
+         `(,@(when (os-unix-p)
+               (cons
+                (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
+                (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
+                  :for dir :in (split-string dirs :separator ":")
+                  :collect (subpathname* dir "common-lisp/"))))
+           ,@(when (os-windows-p)
+               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
+                                    (getenv "LOCALAPPDATA"))
+                               "common-lisp/config/")
+                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
+                                    (getenv "APPDATA"))
+                                "common-lisp/config/")))
+           ,(subpathname (user-homedir) ".config/common-lisp/"))))
+    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
+                       :from-end t :test 'equal)))
 (defun* system-configuration-directories ()
   (cond
     ((os-unix-p) '(#p"/etc/common-lisp/"))
     ((os-windows-p)
      (aif
-      (flet ((try (x sub) (try-directory-subpath x sub)))
-        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-        (try (or #+lispworks (sys:get-folder-path :common-appdata)
-                 (getenv "ALLUSERSAPPDATA")
-                 (try (getenv "ALLUSERSPROFILE") "Application Data/"))
-             "common-lisp/config/"))
+      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
+                        (getenv "ALLUSERSAPPDATA")
+                        (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
+                    "common-lisp/config/")
       (list it)))))
 
-(defun* in-first-directory (dirs x)
-  (loop :for dir :in dirs
-    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
-(defun* in-user-configuration-directory (x)
-  (in-first-directory (user-configuration-directories) x))
-(defun* in-system-configuration-directory (x)
-  (in-first-directory (system-configuration-directories) x))
+(defun* in-first-directory (dirs x &key (direction :input))
+  (loop :with fun = (ecase direction
+                      ((nil :input :probe) 'probe-file*)
+                      ((:output :io) 'identity))
+    :for dir :in dirs
+    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+
+(defun* in-user-configuration-directory (x &key (direction :input))
+  (in-first-directory (user-configuration-directories) x :direction direction))
+(defun* in-system-configuration-directory (x &key (direction :input))
+  (in-first-directory (system-configuration-directories) x :direction direction))
 
 (defun* configuration-inheritance-directive-p (x)
   (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
@@ -3547,14 +3553,14 @@
 (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
 
-(defun* user-output-translations-pathname ()
-  (in-user-configuration-directory *output-translations-file*))
-(defun* system-output-translations-pathname ()
-  (in-system-configuration-directory *output-translations-file*))
-(defun* user-output-translations-directory-pathname ()
-  (in-user-configuration-directory *output-translations-directory*))
-(defun* system-output-translations-directory-pathname ()
-  (in-system-configuration-directory *output-translations-directory*))
+(defun* user-output-translations-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-file* :direction direction))
+(defun* system-output-translations-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-file* :direction direction))
+(defun* user-output-translations-directory-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-directory* :direction direction))
+(defun* system-output-translations-directory-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-directory* :direction direction))
 (defun* environment-output-translations ()
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
 
@@ -3677,8 +3683,8 @@
      (translate-pathname path absolute-source destination))))
 
 (defun* apply-output-translations (path)
+  #+cormanlisp (truenamize path) #-cormanlisp
   (etypecase path
-    #+cormanlisp (t (truenamize path))
     (logical-pathname
      path)
     ((or pathname string)
@@ -3719,7 +3725,7 @@
 
 (defun* tmpize-pathname (x)
   (make-pathname
-   :name (format nil "ASDF-TMP-~A" (pathname-name x))
+   :name (strcat "ASDF-TMP-" (pathname-name x))
    :defaults x))
 
 (defun* delete-file-if-exists (x)
@@ -3852,6 +3858,7 @@
       (loop :for f :in entries
         :for p = (or (and (typep f 'logical-pathname) f)
                      (let* ((u (ignore-errors (funcall merger f))))
+                       ;; The first u avoids a cumbersome (truename u) error
                        (and u (equal (ignore-errors (truename u)) f) u)))
         :when p :collect p)
       entries))
@@ -3865,8 +3872,9 @@
     (filter-logical-directory-results
      directory entries
      #'(lambda (f)
-         (make-pathname :defaults directory :version (pathname-version f)
-                        :name (pathname-name f) :type (pathname-type f))))))
+         (make-pathname :defaults directory
+                        :name (pathname-name f) :type (ununspecific (pathname-type f))
+                        :version (ununspecific (pathname-version f)))))))
 
 (defun* directory-asd-files (directory)
   (directory-files directory *wild-asd*))
@@ -3875,9 +3883,9 @@
   (let* ((directory (ensure-directory-pathname directory))
          #-(or abcl cormanlisp genera xcl)
          (wild (merge-pathnames*
-                #-(or abcl allegro cmu lispworks scl xcl)
+                #-(or abcl allegro cmu lispworks sbcl scl xcl)
                 *wild-directory*
-                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
                 directory))
          (dirs
           #-(or abcl cormanlisp genera xcl)
@@ -3887,16 +3895,16 @@
           #+(or abcl xcl) (system:list-directory directory)
           #+cormanlisp (cl::directory-subdirs directory)
           #+genera (fs:directory-list directory))
-         #+(or abcl allegro cmu genera lispworks scl xcl)
+         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
          (dirs (loop :for x :in dirs
                  :for d = #+(or abcl xcl) (extensions:probe-directory x)
                           #+allegro (excl:probe-directory x)
-                          #+(or cmu scl) (directory-pathname-p x)
+                          #+(or cmu sbcl scl) (directory-pathname-p x)
                           #+genera (getf (cdr x) :directory)
                           #+lispworks (lw:file-directory-p x)
                  :when d :collect #+(or abcl allegro xcl) d
                                   #+genera (ensure-directory-pathname (first x))
-                                  #+(or cmu lispworks scl) x)))
+                                  #+(or cmu lispworks sbcl scl) x)))
     (filter-logical-directory-results
      directory dirs
      (let ((prefix (normalize-pathname-directory-component
@@ -4019,14 +4027,13 @@
     :inherit-configuration
     #+cmu (:tree #p"modules:")))
 (defun* default-source-registry ()
-  (flet ((try (x sub) (try-directory-subpath x sub)))
-    `(:source-registry
-      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
-      (:directory ,(default-directory))
+  `(:source-registry
+    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+    (:directory ,(default-directory))
       ,@(loop :for dir :in
           `(,@(when (os-unix-p)
                 `(,(or (getenv "XDG_DATA_HOME")
-                       (try (user-homedir) ".local/share/"))
+                       (subpathname (user-homedir) ".local/share/"))
                   ,@(split-string (or (getenv "XDG_DATA_DIRS")
                                       "/usr/local/share:/usr/share")
                                   :separator ":")))
@@ -4037,18 +4044,18 @@
                        (getenv "APPDATA"))
                   ,(or #+lispworks (sys:get-folder-path :common-appdata)
                        (getenv "ALLUSERSAPPDATA")
-                       (try (getenv "ALLUSERSPROFILE") "Application Data/")))))
-          :collect `(:directory ,(try dir "common-lisp/systems/"))
-          :collect `(:tree ,(try dir "common-lisp/source/")))
-      :inherit-configuration)))
-(defun* user-source-registry ()
-  (in-user-configuration-directory *source-registry-file*))
-(defun* system-source-registry ()
-  (in-system-configuration-directory *source-registry-file*))
-(defun* user-source-registry-directory ()
-  (in-user-configuration-directory *source-registry-directory*))
-(defun* system-source-registry-directory ()
-  (in-system-configuration-directory *source-registry-directory*))
+                       (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
+          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+      :inherit-configuration))
+(defun* user-source-registry (&key (direction :input))
+  (in-user-configuration-directory *source-registry-file* :direction direction))
+(defun* system-source-registry (&key (direction :input))
+  (in-system-configuration-directory *source-registry-file* :direction direction))
+(defun* user-source-registry-directory (&key (direction :input))
+  (in-user-configuration-directory *source-registry-directory* :direction direction))
+(defun* system-source-registry-directory (&key (direction :input))
+  (in-system-configuration-directory *source-registry-directory* :direction direction))
 (defun* environment-source-registry ()
   (getenv "CL_SOURCE_REGISTRY"))
 
@@ -4126,8 +4133,7 @@
                       (collect (list directory :recurse recurse :exclude exclude)))))
      :test 'equal :from-end t)))
 
-;; Will read the configuration and initialize all internal variables,
-;; and return the new configuration.
+;; Will read the configuration and initialize all internal variables.
 (defun* compute-source-registry (&optional parameter (registry *source-registry*))
   (dolist (entry (flatten-source-registry parameter))
     (destructuring-bind (directory &key recurse exclude) entry




More information about the armedbear-cvs mailing list