[armedbear-cvs] r13702 - in trunk/abcl: doc/asdf src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Sun Dec 18 15:25:20 UTC 2011
Author: mevenson
Date: Sun Dec 18 07:25:19 2011
New Revision: 13702
Log:
asdf-2.019 with patch to get around ticket #181.
Modified:
trunk/abcl/doc/asdf/asdf.texinfo
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- trunk/abcl/doc/asdf/asdf.texinfo Mon Dec 5 03:10:17 2011 (r13701)
+++ trunk/abcl/doc/asdf/asdf.texinfo Sun Dec 18 07:25:19 2011 (r13702)
@@ -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: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Mon Dec 5 03:10:17 2011 (r13701)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Dec 18 07:25:19 2011 (r13702)
@@ -1,5 +1,5 @@
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.018: 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)
@@ -94,10 +96,8 @@
'(("~3i~_" . ""))
#+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :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
@@ -107,7 +107,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.018")
+ (asdf-version "2.019")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
@@ -185,7 +185,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
@@ -226,23 +226,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
@@ -334,11 +330,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
@@ -346,9 +350,7 @@
#:getenv
;; #:length=n-p
;; #:find-symbol*
- #:merge-pathnames*
- #:coerce-pathname
- #:subpathname
+ #:merge-pathnames* #:coerce-pathname #:subpathname
#:pathname-directory-pathname
#:read-file-forms
;; #:remove-keys
@@ -411,6 +413,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)))
@@ -419,8 +422,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))))
@@ -520,6 +523,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,
@@ -538,9 +544,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)
@@ -891,24 +895,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.
@@ -1171,45 +1172,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)
@@ -1282,21 +1244,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
@@ -1330,7 +1277,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)
@@ -1343,24 +1295,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
@@ -1448,11 +1382,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))
@@ -1539,15 +1472,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.
@@ -1597,7 +1540,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)))
@@ -1671,6 +1614,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~@:>"))))
@@ -1690,7 +1634,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)
@@ -1706,8 +1650,7 @@
(let ((*package* package)
(*default-pathname-defaults*
(pathname-directory-pathname pathname)))
- ;;; XXX Under ABCL, if the PATHNAME is a JAR-PATHNAME the
- ;;; MERGE-PATHNAMES are perhaps a bit wonky.
+ ;;; XXX Kludge for ABCL ticket #181
#+abcl
(when (ext:pathname-jar-p pathname)
(setf *default-pathname-defaults*
@@ -1717,17 +1660,27 @@
(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))
@@ -1737,23 +1690,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)
@@ -1879,12 +1846,9 @@
(and pathname (merge-pathnames* (coerce-pathname subpath :type type)
(pathname-directory-pathname pathname))))
-(defun* try-subpathname (pathname subpath &key type)
- (let* ((sp (and pathname (probe-file* pathname)
- (subpathname pathname subpath :type type)))
- (ts (and sp (probe-file* sp))))
- (and ts (values sp ts))))
-
+(defun subpathname* (pathname subpath &key type)
+ (and pathname
+ (subpathname (ensure-directory-pathname pathname) subpath :type type)))
;;;; -------------------------------------------------------------------------
;;;; Operations
@@ -1988,10 +1952,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))
@@ -2363,10 +2326,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*
@@ -2552,31 +2523,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*)
@@ -2640,7 +2618,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))
@@ -2652,6 +2630,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
@@ -2708,7 +2689,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)
@@ -2730,8 +2711,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
@@ -2808,29 +2788,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)
@@ -2862,6 +2835,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 (class 'system)
defsystem-depends-on &allow-other-keys)
@@ -2874,14 +2851,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)))
@@ -2966,7 +2943,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)))
@@ -2978,6 +2955,9 @@
(list "-c" command)
:input nil :output *verbose-out*))
+ #+cormanlisp
+ (win32:system command)
+
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(ext:system command)
@@ -3168,20 +3148,23 @@
(defun* user-configuration-directories ()
(let ((dirs
- `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/")
- ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
- :for dir :in (split-string dirs :separator ":")
- :collect (try-subpathname dir "common-lisp/"))
+ `(,@(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)
- `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA"))
- "common-lisp/config/")
+ `(,(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
- ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
- "common-lisp/config/")))
- ,(try-subpathname (user-homedir) ".config/common-lisp/"))))
- (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
+ ,(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
@@ -3189,19 +3172,23 @@
((os-windows-p)
(aif
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
- (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv "ALLUSERSAPPDATA")
- (subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))
- "common-lisp/config/")
+ (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)))
@@ -3555,14 +3542,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"))
@@ -3685,8 +3672,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)
@@ -3727,7 +3714,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)
@@ -3858,6 +3845,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))
@@ -3871,8 +3859,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*))
@@ -3881,9 +3870,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)
@@ -3893,16 +3882,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
@@ -4027,12 +4016,12 @@
#+scl (:tree #p"file://modules/")))
(defun* default-source-registry ()
`(:source-registry
- #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/"))
+ #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
(:directory ,(default-directory))
,@(loop :for dir :in
`(,@(when (os-unix-p)
`(,(or (getenv "XDG_DATA_HOME")
- (try-subpathname (user-homedir) ".local/share/"))
+ (subpathname (user-homedir) ".local/share/"))
,@(split-string (or (getenv "XDG_DATA_DIRS")
"/usr/local/share:/usr/share")
:separator ":")))
@@ -4043,18 +4032,18 @@
(getenv "APPDATA"))
,(or #+lispworks (sys:get-folder-path :common-appdata)
(getenv "ALLUSERSAPPDATA")
- (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/")))))
- :collect `(:directory ,(try-subpathname dir "common-lisp/systems/"))
- :collect `(:tree ,(try-subpathname dir "common-lisp/source/")))
+ (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 ()
- (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*))
+(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"))
@@ -4132,8 +4121,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