Commit 1fdb7b8d authored by Robert Goldman's avatar Robert Goldman

Merge branch 'cleanups' into 'master'

Cleanups

This branch contains a few cleanups as I proofread the entire code.

Those currently in the pipe regard asdf upgrade, since the first file in asdf is upgrade.lisp.

See merge request !23
parents b0eb3f7a c7d05a55
......@@ -8,14 +8,13 @@
:asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
(:export
#:action #:define-convenience-action-methods
#:explain #:action-description
#:action-description
#:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
#:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept
#:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
#:action-path #:find-action #:stamp #:done-p
#:operation-definition-warning #:operation-definition-error ;; condition
))
......@@ -34,13 +33,6 @@ and a class-name or class designates the canonical instance of the designated cl
'(or operation null symbol class)))
;;; TODO: These should be moved to asdf/plan and be made simple defuns.
(with-upgradability ()
(defgeneric traverse-actions (actions &key &allow-other-keys))
(defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
(defgeneric required-components (component &key &allow-other-keys)))
;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
(with-upgradability ()
(defun action-path (action)
......@@ -115,14 +107,6 @@ You can put together sentences using this phrase."))
(format nil (compatfmt "~@<~A on ~A~@:>")
(type-of operation) component))
;; This is for compatibility with ASDF 1, and is deprecated.
;; TODO: move it to backward-interface
(defgeneric* (explain) (operation component)
(:documentation "Display a message describing an action"))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
(define-convenience-action-methods explain (operation component))
(defun format-action (stream action &optional colon-p at-sign-p)
"FORMAT helper to display an action's action-description.
Use it in FORMAT control strings as ~/asdf-action:format-action/"
......
......@@ -16,7 +16,8 @@
#:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
#:component-property
#:run-shell-command
#:system-definition-pathname))
#:system-definition-pathname
#:explain))
(in-package :asdf/backward-interface)
(with-upgradability ()
......@@ -52,9 +53,7 @@
;; More generally, if you have to do something when the operation was forced,
;; you should also do it when not, and vice-versa, because it really shouldn't matter.
;; Thus, the backward-compatible thing to do is to always return T.
;;
;; TODO: change this function to a defun that always returns T.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defmethod operation-forced ((o operation)) t)
;; These old interfaces from ASDF1 have never been very meaningful
......@@ -182,10 +181,12 @@ Please use UIOP:RUN-PROGRAM instead."
((integer 0 255) exit-code)
(t 255))))))
(with-upgradability ()
(defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
;;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
(with-upgradability ()
(defgeneric component-property (component property))
(defgeneric (setf component-property) (new-value component property))
......@@ -200,3 +201,15 @@ Please use UIOP:RUN-PROGRAM instead."
(setf (slot-value c 'properties)
(acons property new-value (slot-value c 'properties)))))
new-value))
;;; This method survives from ASDF 1, but really it is superseded by action-description.
(with-upgradability ()
(defgeneric* (explain) (operation component)
(:documentation "Display a message describing an action.
DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
(define-convenience-action-methods explain (operation component)))
......@@ -71,9 +71,8 @@ itself."))
(defclass link-op (bundle-op) ()
(:documentation "Abstract operation for linking files together"))
(defclass gather-op (bundle-op)
;; TODO: rename the slot and reader gather-op to gather-operation
((gather-op :initform nil :allocation :class :reader gather-op)
(defclass gather-operation (bundle-op)
((gather-operation :initform nil :allocation :class :reader gather-operation)
(gather-type :initform :no-output-file :allocation :class :reader gather-type))
(:documentation "Abstract operation for gathering many input files from a system"))
......@@ -86,7 +85,7 @@ itself."))
;; and all system-level dependencies as required components.
;; Non-monolithic operations typically use compile-op as the dependent operation,
;; and all transitive sub-components as required components (excluding other systems).
(defmethod component-depends-on ((o gather-op) (s system))
(defmethod component-depends-on ((o gather-operation) (s system))
(let* ((mono (operation-monolithic-p o))
(deps
(required-components
......@@ -95,7 +94,7 @@ itself."))
:keep-operation 'compile-op)))
;; NB: the explicit make-operation on ECL and MKCL
;; ensures that we drop the original-initargs and its magic flags when recursing.
`((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps)
`((,(or (gather-operation o) (if mono 'lib-op 'compile-op)) ,@deps)
,@(call-next-method))))
;; Create a single fasl for the entire library
......@@ -112,7 +111,7 @@ itself."))
:allocation :class))
(:documentation "Operation class for loading the bundles of a system's dependencies"))
(defclass lib-op (link-op gather-op non-propagating-operation)
(defclass lib-op (link-op gather-operation non-propagating-operation)
((gather-type :initform :object :allocation :class)
(bundle-type :initform :lib :allocation :class))
(:documentation "Compile the system and produce a linkable static library (.a/.lib)
......@@ -125,7 +124,7 @@ themselves. In any case, this operation will produce what you need to further bu
a static runtime for your system, or a dynamic library to load in an existing runtime."))
(defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
#+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
#+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-operation)
((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
:allocation :class))
(:documentation "This operator is an alternative to COMPILE-OP. Build a system
......@@ -145,7 +144,7 @@ faster and more resource efficient."))
;; we'd have to have the monolithic-op not inherit from the main op,
;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
(defclass dll-op (link-op gather-op non-propagating-operation)
(defclass dll-op (link-op gather-operation non-propagating-operation)
((gather-type :initform :object :allocation :class)
(bundle-type :initform :dll :allocation :class))
(:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
......@@ -170,11 +169,13 @@ for all the linkable object files associated with the system. Compare with LIB-O
(defclass monolithic-compile-bundle-op
(monolithic-bundle-op basic-compile-bundle-op
#+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
((gather-op :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
:allocation :class)
(gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library
:allocation :class))
#+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
((gather-operation
:initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
:allocation :class)
(gather-type
:initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library
:allocation :class))
(:documentation "Create a single fasl for the system and its dependencies."))
(defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
......@@ -192,7 +193,7 @@ for all the linkable object files associated with the system or its dependencies
for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
(defclass image-op (monolithic-bundle-op selfward-operation
#+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
#+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
((bundle-type :initform :image)
#+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
(selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
......@@ -333,7 +334,7 @@ or of opaque libraries shipped along the source code."))
(defun pathname-type-equal-function (type)
#'(lambda (p) (equalp (pathname-type p) type)))
(defmethod input-files ((o gather-op) (c system))
(defmethod input-files ((o gather-operation) (c system))
(unless (eq (bundle-type o) :no-output-file)
(direct-dependency-files
o c :key 'output-files
......@@ -454,7 +455,7 @@ or of opaque libraries shipped along the source code."))
(defmethod perform ((o dll-op) (c prebuilt-system))
nil)
(defmethod component-depends-on ((o gather-op) (c prebuilt-system))
(defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
nil)
(defmethod output-files ((o lib-op) (c prebuilt-system))
......
......@@ -49,7 +49,7 @@
(:documentation "Top-level system containing the COMPONENT"))
(defgeneric component-pathname (component)
(:documentation "Pathname of the COMPONENT if any, or NIL."))
(defgeneric (component-relative-pathname) (component)
(defgeneric* (component-relative-pathname) (component)
;; in ASDF4, rename that to component-specified-pathname ?
(:documentation "Specified pathname of the COMPONENT,
intended to be merged with the pathname of that component's parent if any, using merged-pathnames*.
......@@ -78,7 +78,7 @@ or NIL for top-level components (a.k.a. systems)"))
;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
;; TODO: find users, have them stop using that, remove it for ASDF4.
(defgeneric (source-file-type) (component system)
(defgeneric* (source-file-type) (component system)
(:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
(define-condition system-definition-error (error) ()
......
......@@ -6,7 +6,7 @@
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/operation
:asdf/system :asdf/find-system
:asdf/action :asdf/lisp-action :asdf/bundle)
:asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
(:export
#:concatenate-source-op
#:load-concatenated-source-op
......@@ -24,7 +24,7 @@
(with-upgradability ()
;; Base classes for both regular and monolithic concatenate-source operations
(defclass basic-concatenate-source-op (bundle-op)
((bundle-type :initform "lisp")))
((bundle-type :initform "lisp" :allocation :class)))
(defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
(defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
(defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
......
......@@ -129,8 +129,7 @@ in the context of COMPONENT"))
(equal (missing-requires c) name))))
(unless (component-parent component)
(let ((name (coerce-name name)))
(unset-asdf-cache-entry `(find-system ,name))
(unset-asdf-cache-entry `(locate-system ,name))))))))
(unset-asdf-cache-entry `(find-system ,name))))))))
;; Resolve dependency specification DEP-SPEC in the context of COMPONENT.
;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON
......
......@@ -123,6 +123,14 @@ or NIL if not found."
(cons (ignore-errors (get-file-stamp (system-source-file system)))
system)))))
(defun map-systems (fn)
"Apply FN to each defined system.
FN should be a function of one argument. It will be
called with an object of type asdf:system."
(loop :for registered :being :the :hash-values :of *defined-systems*
:do (funcall fn (cdr registered))))
;;; Preloaded systems: in the image even if you can't find source files backing them.
......@@ -154,13 +162,6 @@ then define and register said preloaded system."
(if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name)))
(register-system system)))
(defun ensure-all-preloaded-systems-registered ()
"Make sure all registered preloaded systems are defined.
This function is run whenever ASDF is upgraded."
(loop :for name :being :the :hash-keys :of *preloaded-systems*
:do (ensure-preloaded-system-registered name)))
(register-hook-function '*post-upgrade-restart-hook* 'ensure-all-preloaded-systems-registered)
(defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys)
"Register a system as being preloaded. If the system has not been loaded from the filesystem
yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be
......@@ -230,17 +231,7 @@ Returns T if system was or is now undefined, NIL if a new preloaded system was r
"Clear all currently registered defined systems.
Preloaded systems (including immutable ones) will be reset, other systems will be de-registered."
(loop :for name :being :the :hash-keys :of *defined-systems*
:unless (equal name "asdf") :do (clear-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
(defun map-systems (fn)
"Apply FN to each defined system.
FN should be a function of one argument. It will be
called with an object of type asdf:system."
(loop :for registered :being :the :hash-values :of *defined-systems*
:do (funcall fn (cdr registered))))
:unless (member name '("asdf" "uiop") :test 'equal) :do (clear-system name)))
;;; Searching for system definitions
......@@ -452,9 +443,7 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(ensure-gethash
(list (namestring pathname) version) *old-asdf-systems*
#'(lambda ()
(let ((old-pathname
(if-let (pair (system-registered-p "asdf"))
(system-source-file (cdr pair)))))
(let ((old-pathname (system-source-file (registered-system "asdf"))))
(warn "~@<~
You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
......@@ -502,8 +491,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(found-system (and (typep found 'system) found))
(pathname (ensure-pathname
(or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system))
(and previous (system-source-file previous)))
(system-source-file found-system)
(system-source-file previous))
:want-absolute t :resolve-symlinks *resolve-symlinks*))
(foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system))
......@@ -526,7 +515,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t)))
(let ((previous-pathname (and previous (system-source-file previous)))
(let ((previous-pathname (system-source-file previous))
(system (or previous found-system)))
(when (and found-system (not previous))
(register-system found-system))
......
......@@ -8,7 +8,6 @@
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
(:export
#:operate #:oos
#:*systems-being-operated*
#:build-op #:make
#:load-system #:load-systems #:load-systems*
#:compile-system #:test-system #:require-system
......@@ -50,10 +49,8 @@ But do NOT depend on it, for this is deprecated behavior."))
:operation-initargs t ;; backward-compatibility with ASDF1. Deprecated.
:if-no-component (error 'missing-component :requires component))
;; TODO: actually, the use as a hash-set is write-only, so it can be reduced to a boolean,
;; and then possibly replaced by checking for say *asdf-cache*.
(defvar *systems-being-operated* nil
"A hash-set of names of systems being operated on, or NIL")
(defvar *in-operate* nil
"Are we in operate?")
;; This method ensures that an ASDF upgrade is attempted as the very first thing,
;; with suitable state preservation in case in case it actually happens,
......@@ -62,36 +59,36 @@ But do NOT depend on it, for this is deprecated behavior."))
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(nest
(with-asdf-cache ())
(let ((in-operate *in-operate*)
(*in-operate* t)
(operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(etypecase operation
(operation (let ((name (type-of operation))
(initargs (operation-original-initargs operation)))
#'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
((or symbol string) (constantly operation))))
(etypecase operation
(operation (let ((name (type-of operation))
(initargs (operation-original-initargs operation)))
#'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
((or symbol string) (constantly operation))))
(component-path (typecase component ;; to remake the component after ASDF upgrade
(component (component-find-path component))
(t component))))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless systems-being-operated
(when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined, its symbol uninterned, its package deleted.
(return-from operate
(apply 'operate (funcall operation-remaker) component-path keys))))
(t component)))))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(progn
(unless in-operate
(when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined, its symbol uninterned, its package deleted.
(return-from operate
(apply 'operate (funcall operation-remaker) component-path keys)))))
;; Setup proper bindings around any operate call.
(with-asdf-cache ()
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(call-next-method)))))
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(call-next-method))))
(defmethod operate :before ((operation operation) (component component)
&key version &allow-other-keys)
(let ((system (component-system component)))
(setf (gethash (coerce-name system) *systems-being-operated*) system))
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version)))
......@@ -178,7 +175,7 @@ to load it in current image."
"Has the given COMPONENT been successfully loaded in the current image (yet)?
Note that this returns true even if the component is not up to date."
(if-let ((component (find-component component () :registered t)))
(action-already-done-p nil (make-instance 'load-op) component)))
(action-already-done-p nil (make-operation 'load-op) component)))
(defun already-loaded-systems ()
"return a list of the names of the systems that have been successfully loaded so far"
......@@ -262,12 +259,20 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(with-upgradability ()
(defun restart-upgraded-asdf ()
;; If we're in the middle of something, restart it.
(when *asdf-cache*
(let ((l (loop :for k :being :the hash-keys :of *asdf-cache*
:when (eq (first k) 'find-system) :collect (second k))))
(clrhash *asdf-cache*)
(dolist (s l) (find-system s nil)))))
(register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)
(let ((systems-being-defined
(when *asdf-cache*
(prog1
(loop :for k :being :the hash-keys :of *asdf-cache*
:when (eq (first k) 'find-system) :collect (second k))
(clrhash *asdf-cache*)))))
;; Regardless, clear defined systems, since they might be invalid
;; after an incompatible ASDF upgrade.
(clear-defined-systems)
;; The configuration also may have to be upgraded.
(upgrade-configuration)
;; If we were in the middle of an operation, be sure to restore the system being defined.
(dolist (s systems-being-defined) (find-system s nil))))
(register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf)
;; The following function's symbol is from asdf/find-system.
;; It is defined here to resolve what would otherwise be forward package references.
......
......@@ -49,7 +49,9 @@ and the order is by decreasing length of namestring of the source pathname.")
(etypecase (car x)
((eql t) -1)
(pathname
(let ((directory (pathname-directory (car x))))
(let ((directory
(normalize-pathname-directory-component
(pathname-directory (car x)))))
(if (listp directory) (length directory) 0))))))))
new-value)
(defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
......
......@@ -189,7 +189,7 @@
system names contained using COERCE-NAME. Return the result."
(mapcar 'parse-dependency-def dd-list))
(defun (parse-component-form) (parent options &key previous-serial-component)
(defun* (parse-component-form) (parent options &key previous-serial-component)
(destructuring-bind
(type name &rest rest &key
(builtin-system-p () bspp)
......
......@@ -200,7 +200,7 @@ to be meaningful, or could it just as well have been done in another Lisp image?
;;;; Visiting dependencies of an action and computing action stamps
(with-upgradability ()
(defun (map-direct-dependencies) (plan operation component fun)
(defun* (map-direct-dependencies) (plan operation component fun)
"Call FUN on all the valid dependencies of the given action in the given plan"
(loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
:for dep-o = (find-operation operation dep-o-spec)
......@@ -210,7 +210,7 @@ to be meaningful, or could it just as well have been done in another Lisp image?
:when (and dep-c (action-valid-p plan dep-o dep-c))
:do (funcall fun dep-o dep-c))))
(defun (reduce-direct-dependencies) (plan operation component combinator seed)
(defun* (reduce-direct-dependencies) (plan operation component combinator seed)
"Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
for each dependency action on the dependency's operation and component and an accumulator
initialized with SEED."
......@@ -220,7 +220,7 @@ initialized with SEED."
(setf seed (funcall combinator dep-o dep-c seed))))
seed)
(defun (direct-dependencies) (plan operation component)
(defun* (direct-dependencies) (plan operation component)
"Compute a list of the direct dependencies of the action within the plan"
(reduce-direct-dependencies plan operation component #'acons nil))
......@@ -514,12 +514,13 @@ initialized with SEED."
(typep c (plan-component-type plan))
(call-next-method)))
(defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
(defun* (traverse-actions) (actions &rest keys &key plan-class &allow-other-keys)
"Given a list of actions, build a plan with these actions as roots."
(let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
(loop* :for (o . c) :in actions :do (traverse-action plan o c t))
plan))
(defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
(define-convenience-action-methods traverse-sub-actions (operation component &key))
(defmethod traverse-sub-actions ((operation operation) (component component)
&rest keys &key &allow-other-keys)
......@@ -532,7 +533,7 @@ initialized with SEED."
:when (and (typep o keep-operation) (typep c keep-component))
:collect (cons o c))))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
"Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
return a list of the components involved in building the desired action."
(remove-duplicates
......
......@@ -108,14 +108,15 @@ based on supplied KEYS."
(defmethod system-source-file ((system-name string))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
(system-source-file (find-system system-name)))
(when system-name
(system-source-file (find-system system-name))))
(defun system-source-directory (system-designator)
"Return a pathname object corresponding to the directory
in which the system specification (.asd file) is located."
(pathname-directory-pathname (system-source-file system-designator)))
(defun (system-relative-pathname) (system name &key type)
(defun* (system-relative-pathname) (system name &key type)
"Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
return the absolute pathname of a corresponding file under that system's source code pathname."
(subpathname (system-source-directory system) name :type type))
......
......@@ -361,11 +361,16 @@ upgrade_tags () {
# We return the above designated versions in order of decreasing relevance,
# which pretty much means REQUIRE and most recent first.
echo REQUIRE
echo 3.1.4 3.1.3 3.1.2
echo 3.0.3 3.0.2 3.0.1
# echo 2.32 2.27
# echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000
# echo 1.369 1.97 1.85
echo 3.1.7 # 2016-03-23, latest release (as of 2016-09)
echo 3.1.5 # 2015-07-21, what SBCL sports (as of 1.3.9, 2016-08-30)
echo 3.0.3 # 2013-10-22, last in ASDF 3.0 series
echo 2.26 # 2012-10-30, last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!)
#echo 3.1.7 3.1.6 3.1.5 3.1.4 3.1.3 3.1.2
#echo 3.0.3 3.0.2 3.0.1
#echo 2.32 2.27
#echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000
#echo 1.369 1.97 1.85
}
upgrade_methods () {
if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then
......@@ -390,7 +395,7 @@ extract_tagged_asdf () {
case $tag in
1.*|2.0*|2.2[0-6]|2.26.61)
git show ${tag}:asdf.lisp > $file ;;
2.2[7-9]*|2.[3-9]*|3.*)
2.2[7-9]*|2.[3-9][0-9]*|3.*)
mkdir -p build/old/build
git archive ${tag} | (cd build/old/ ; tar xf -)
make -C build/old
......
......@@ -621,18 +621,24 @@ is bound, write a message and exit on an error. If
(format t "Being a bit verbose~%")
(when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
(when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
(when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
(format t "Comparing directories~%")
(let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
(assert-pathname-equal-helper ;; not always EQUAL (!)
'*test-directory* *test-directory*
'(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
(funcall
;; Old versions of ASDF don't always use with-asdf-cache in locate system, but need it.
;; So we do it for them for the sake of testing upgrade from these old versions.
;; Yet older versions of ASDF don't even have this cache, so then we don't.
(or (asym :call-with-asdf-cache) 'funcall)
(lambda ()
(when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
(format t "Comparing directories~%")
(let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
(assert-pathname-equal-helper ;; not always EQUAL (!)
'*test-directory* *test-directory*
'(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x)
(unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~
ASDF finds the ASDs in~% ~S~%Using the latter.~%"
(pathname-components *test-directory*)
(pathname-components x)))
(setf *test-directory* x)))
(pathname-components *test-directory*)
(pathname-components x)))
(setf *test-directory* x)))))
t)
(defun frob-packages ()
......
......@@ -156,13 +156,11 @@
(clrhash asdf::*asdf-cache*)
(touch-file (lisppath "file1.lisp") :timestamp base :offset l1)
(touch-file (faslpath "file1.lisp") :timestamp base :offset f1)
(dolist (l (asdf:output-files (make-instance 'asdf:compile-op)
(asdf:find-component :test-stamp-propagation '("file1"))))
(dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file1")))
(touch-file l :timestamp base :offset f1))
(touch-file (lisppath "file2.lisp") :timestamp base :offset l2)
(touch-file (faslpath "file2.lisp") :timestamp base :offset f2)
(dolist (l (asdf:output-files (make-instance 'asdf:compile-op)
(asdf:find-component :test-stamp-propagation '("file2"))))
(dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file2")))
(touch-file l :timestamp base :offset f2)))
(defun test-defsystem (&optional (defsystem *default-defsystem*))
......
......@@ -2,7 +2,7 @@
(load-system 'test-mutual-redefinition-1)
(defun current-system-source-file (x)
(system-source-file (cdr (gethash x asdf/find-system:*defined-systems*))))
(system-source-file (asdf::registered-system x)))
(with-asdf-cache ()
(DBG "loading test-mutual-redefinition-1")
......
......@@ -47,16 +47,16 @@
(defclass my-incoherent-operation (downward-operation non-propagating-operation)
())
(dolist (class *good-classes*) (assert (make-instance class)))
(dolist (class *good-classes*) (assert (make-operation class)))
(signals operation-definition-warning
(make-instance 'my-unupdated-operation))
(make-operation 'my-unupdated-operation))
(with-expected-failure (#+gcl "GCL has trouble with CLOS?")
(signals operation-definition-error
(make-instance 'my-incoherent-operation)))
(make-operation 'my-incoherent-operation)))
(assert (make-instance 'my-good-operation))
(assert (make-operation 'my-good-operation))
;; This test exercises the backward-compatibility mechanism of operation,
......
#| -*- Lisp -*-
case "$LISP" in
# CCL is our default because it is the single free software implementation that has
# decent portable support on all of Windows, Linux (x64, x86, ARM), MacOS X
""|ccl) exec ${CCL:-ccl} --no-init --load "$0" -- "$@" ;;
# SBCL is our default on Unix, because while CCL has better support on Windows and MacOS,
# SBCL still runs decently on MacOS and CCL has a background thread that eats input
# (and still puts the tty in raw mode if using single-threaded-ccl) which defeats
# the purpose of `make load`. See: https://bugs.launchpad.net/asdf/+bug/1624909
allegro) ${ALLEGRO:-alisp} -qq -e "(setf *load-verbose* nil)" -L "$0" -- "$@" ;;
sbcl) exec ${SBCL:-sbcl} --noinform --no-userinit --no-sysinit --script "$0" "$@" ;;
ccl) exec ${CCL:-ccl} --no-init --load "$0" -- "$@" ;;
""|sbcl) exec ${SBCL:-sbcl} --noinform --no-userinit --no-sysinit --script "$0" "$@" ;;
# Let cl-launch choose its preferred Lisp
cl-launch) cl-launch -Q -sp asdf-tools -r entry-point -- "$@" ;;
......
@echo off
::: By default. We use CCL.
::: By default. We use CCL, because SBCL doesn't have a good enough run-program on Windows.
if "%LISP%" == "" goto ccl
if "%LISP%" == "allegro" goto allegro
if "%LISP%" == "ccl" goto ccl
......
......@@ -228,8 +228,9 @@ and which systems to test loading with ASDF_TEST_SYSTEMS or s=
(output (if (eq output *stdout*) :interactive output)))
(log! log "~A" (print-process-spec command nil))
(multiple-value-bind (out err code)
(run `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command
,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-(
(run `(,@(when interactive '(rlwrap))
,@command
,@(when log `((>> ,log) (>& 2 1)))) ;; unhappily, | tee -a log eats error codes :-(
:input interactive :output output :error-output (or interactive :output) :on-error nil)
(declare (ignore out err))
(let ((okp (eql code 0)))
......
......@@ -6,13 +6,19 @@
;; We return a list of entries in reverse chronological order,
;; which should also be more or less the order of decreasing relevance.
'("REQUIRE" ;; a magic tag meaning whatever your implementation provides, if anything
"3.1.7" ;; (2016-03-23) more bug fixes, latest release (as of 2016-09-17)
"3.1.5" ;; (2015-07-21) more bug fixes
"3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series
"2.26")) ;; (2012-10-30), last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!)
;; The 3.1 series provides the asdf3.1 feature, meaning users can rely on
(defparameter *obsolete-upgrade-test-tags*
'(;; The 3.1 series provides the asdf3.1 feature, meaning users can rely on
;; all the stabilization work done in 3.0 so far, plus extra developments
;; in UIOP, package-inferred-system, and more robustification.
;;(included above) "3.1.7" ;; (2016-03-23) more bug fixes, latest release (as of 2016-09-17)
"3.1.6" ;; (2015-10-17) more bug fixes
"3.1.5" ;; (2015-07-21) more bug fixes
"3.1.4" ;; (2014-10-09) more bug fixes, source-registry cache
;;(included above) "3.1.5" ;; (2015-07-21) more bug fixes, what SBCL sports (as of 1.3.9, 2016-08-30)
"3.1.4" ;; (2014-10-09) more bug fixes, source-registry cache, in LispWorks 7
"3.1.3" ;; (2014-07-24) a bug fix release for 3.1.2
"3.1.2" ;; (2014-05-06) the first ASDF 3.1 release
......@@ -20,19 +26,18 @@
;; with Robert Goldman taking over maintainership at 3.0.2.
;; 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly
;; not compatible with ASDF2 anymore, so we immediately released 3.0.1
"3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series
;;(included above) "3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series
"3.0.2" ;; (2013-07-02) the first ASDF 3 in SBCL
"3.0.1")) ;; (2013-05-16) the first stable ASDF 3 release
"3.0.1" ;; (2013-05-16) the first stable ASDF 3 release
(defparameter *obsolete-upgrade-test-tags*
'(;; 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases
;; 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases
"2.32" ;; (2013-03-05) the first really stable ASDF 3 pre-release
"2.27" ;; (2013-02-01) the first ASDF 3 pre-release
;; The ASDF 2 series
;; Note that 2.26.x is where the refactoring that begat ASDF 3 took place.
;; 2.26.61 is the last single-file, single-package ASDF.
"2.26" ;; (2012-10-30) the last stable ASDF 2 release, long used by Quicklisp, SBCL, etc.
;;(included above) "2.26" ;; (2012-10-30), last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!), long used by SBCL, etc.