Commit d78df051 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Robert P. Goldman

2.28.1: various upgrade issues

1- To make life easier on Xach, stop requiring asdf.lisp to be loaded as source
before it's compiled. Instead, wrap each and every single form in an eval-when,
most of the time via the with-upgradability macro that also transforms
defun into defun* and defgeneric into defgeneric*.
Causes massive reindentation :-(

2- Have a proper :version for fallback systems.
Will make systems that check the version happier.

3- protect a condition with #+sb-eval. Fixes lp#1116408.

4- Protect warnings-file methods with dynamic when *warnings-file-type*
rather than static #+.
parent 6f3a8730
* implement deferred warnings support on abcl, allegro, clisp, cmucl, lispworks, scl)
* fix upgrade on clisp * fix upgrade on clisp
** Extract minimal test case ** Extract minimal test case
* Bug found by fe[nl]ix: infinite loop if the definitions in an asd file * Bug found by fe[nl]ix: infinite loop if the definitions in an asd file
......
This diff is collapsed.
...@@ -29,9 +29,9 @@ ...@@ -29,9 +29,9 @@
:description "The defsystem part of ASDF" :description "The defsystem part of ASDF"
:long-name "Another System Definition Facility" :long-name "Another System Definition Facility"
:description "The portable defsystem for Common Lisp" :description "The portable defsystem for Common Lisp"
:long-description "ASDF/DEFSYSTEM is the standard DEFSYSTEM facility for Common Lisp, :long-description "ASDF/DEFSYSTEM is the de facto standard DEFSYSTEM facility for Common Lisp,
a successor to Dan Barlow's ASDF and Francois-Rene Rideau's ASDF2. a successor to Dan Barlow's ASDF and Francois-Rene Rideau's ASDF2.
For bootstrap purposes, it comes bundled with ASDF/DRIVER in a single file asdf.lisp." For bootstrap purposes, it comes bundled with ASDF/DRIVER in a single file, asdf.lisp."
:homepage "http://common-lisp.net/projects/asdf/" :homepage "http://common-lisp.net/projects/asdf/"
:bug-tracker "https://launchpad.net/asdf/" :bug-tracker "https://launchpad.net/asdf/"
:mailto "asdf-devel@common-lisp.net" :mailto "asdf-devel@common-lisp.net"
...@@ -74,25 +74,13 @@ ...@@ -74,25 +74,13 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.28" ;; to be automatically updated by make bump-version :version "2.28.1" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system. ;; For most purposes, asdf itself specially counts as a builtin system.
;; If you want to link it or do something forbidden to builtin systems, ;; If you want to link it or do something forbidden to builtin systems,
;; specify separate dependencies on asdf-driver and asdf-defsystem. ;; specify separate dependencies on asdf-driver and asdf-defsystem.
#+asdf3 :builtin-system-p #+asdf3 t #+asdf3 :builtin-system-p #+asdf3 t
:components :components ((:module "build" :components ((:file "asdf"))))
((:module "build" :in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op :asdf/defsystem))))
:components
(#-gcl2.6
(:file "asdf"
#+asdf3 :in-order-to #+asdf3 ((compile-op (load-source-op "asdf")))))))
:in-order-to (#+asdf3 (prepare-source-op (monolithic-concatenate-source-op :asdf/defsystem))))
;; Using :do-first instead of :in-order-to works above from ASDF 2.017 to 2.26,
;; but only this (or an equivalent defmethod component-do-first) works for ASDF1
#-asdf3
(setf (slot-value
(find-component (find-component (find-system "asdf") "build") "asdf")
'asdf::do-first)
'((compile-op (load-source-op "asdf"))))
...@@ -15,25 +15,26 @@ ...@@ -15,25 +15,26 @@
;;;; Backward compatibility with various pathname functions. ;;;; Backward compatibility with various pathname functions.
(defun* coerce-pathname (name &key type defaults) (with-upgradability ()
;; For backward-compatibility only, for people using internals (defun coerce-pathname (name &key type defaults)
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb ;; For backward-compatibility only, for people using internals
;; Will be removed after 2014-01-16. ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") ;; Will be removed after 2014-01-16.
(parse-unix-namestring name :type type :defaults defaults)) ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(defun* component-name-to-pathname-components (unix-style-namestring (defun component-name-to-pathname-components (unix-style-namestring
&key force-directory force-relative) &key force-directory force-relative)
;; Will be removed after 2014-01-16. ;; Will be removed after 2014-01-16.
;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
(multiple-value-bind (relabs path filename file-only) (multiple-value-bind (relabs path filename file-only)
(split-unix-namestring-directory-components (split-unix-namestring-directory-components
unix-style-namestring :ensure-directory force-directory) unix-style-namestring :ensure-directory force-directory)
(declare (ignore file-only)) (declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative))) (when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
unix-style-namestring)) unix-style-namestring))
(values relabs path filename))) (values relabs path filename)))
#+(or ecl mkcl) #+(or ecl mkcl)
(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* args)) (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
...@@ -20,134 +20,137 @@ ...@@ -20,134 +20,137 @@
#:system-definition-pathname)) #:system-definition-pathname))
(in-package :asdf/backward-interface) (in-package :asdf/backward-interface)
(define-condition operation-error (error) ;; Bad, backward-compatible name (with-upgradability ()
;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel (define-condition operation-error (error) ;; Bad, backward-compatible name
((component :reader error-component :initarg :component) ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
(operation :reader error-operation :initarg :operation)) ((component :reader error-component :initarg :component)
(:report (lambda (c s) (operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c))))) (type-of c) (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ()) (define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ()) (define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ()) (define-condition compile-warned (compile-error) ())
(defun* component-load-dependencies (component) (defun component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software. ;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component)) (component-sibling-dependencies component))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader. (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric* operation-on-warnings (operation)) (defgeneric operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation)) (defgeneric operation-on-failure (operation))
#-gcl2.6 (defgeneric* (setf operation-on-warnings) (x operation)) #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric* (setf operation-on-failure) (x operation)) #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation)) (defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*) (declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation)) (defmethod operation-on-failure ((o operation))
(declare (ignorable o)) *compile-file-failure-behaviour*) (declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation)) (defmethod (setf operation-on-warnings) (x (o operation))
(declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation)) (defmethod (setf operation-on-failure) (x (o operation))
(declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
(defun* system-definition-pathname (x) (defun system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete, ;; As of 2.014.8, we mean to make this function obsolete,
;; but that won't happen until all clients have been updated. ;; but that won't happen until all clients have been updated.
;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
"Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
It used to expose ASDF internals with subtle differences with respect to It used to expose ASDF internals with subtle differences with respect to
user expectations, that have been refactored away since. user expectations, that have been refactored away since.
We recommend you use ASDF:SYSTEM-SOURCE-FILE instead We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting, for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;) if that's whay you mean." ;;)
(system-source-file x)) (system-source-file x)))
;;;; ASDF-Binary-Locations compatibility ;;;; ASDF-Binary-Locations compatibility
;; This remains supported for legacy user, but not recommended for new users.
(defun* enable-asdf-binary-locations-compatibility (with-upgradability ()
(&key (defun enable-asdf-binary-locations-compatibility
(centralize-lisp-binaries nil) (&key
(default-toplevel-directory (centralize-lisp-binaries nil)
(subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (default-toplevel-directory
(include-per-user-information nil) (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(map-all-source-files (or #+(or clisp ecl mkcl) t nil)) (include-per-user-information nil)
(source-to-target-mappings nil) (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
(file-types `(,(compile-file-type) (source-to-target-mappings nil)
"build-report" (file-types `(,(compile-file-type)
#+ecl (compile-file-type :type :object) "build-report"
#+mkcl (compile-file-type :fasl-p nil) #+ecl (compile-file-type :type :object)
#+clisp "lib" #+sbcl "cfasl" #+mkcl (compile-file-type :fasl-p nil)
#+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) #+clisp "lib" #+sbcl "cfasl"
#+(or clisp ecl mkcl) #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
(when (null map-all-source-files) #+(or clisp ecl mkcl)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) (when (null map-all-source-files)
(let* ((patterns (if map-all-source-files (list *wild-file*) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(loop :for type :in file-types (let* ((patterns (if map-all-source-files (list *wild-file*)
:collect (make-pathname :type type :defaults *wild-file*)))) (loop :for type :in file-types
(destination-directory :collect (make-pathname :type type :defaults *wild-file*))))
(if centralize-lisp-binaries (destination-directory
`(,default-toplevel-directory (if centralize-lisp-binaries
,@(when include-per-user-information `(,default-toplevel-directory
(cdr (pathname-directory (user-homedir-pathname)))) ,@(when include-per-user-information
:implementation ,*wild-inferiors*) (cdr (pathname-directory (user-homedir-pathname))))
`(:root ,*wild-inferiors* :implementation)))) :implementation ,*wild-inferiors*)
(initialize-output-translations `(:root ,*wild-inferiors* :implementation))))
`(:output-translations (initialize-output-translations
,@source-to-target-mappings `(:output-translations
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) ,@source-to-target-mappings
#+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
,@(loop :for pattern :in patterns #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
:collect `((:root ,*wild-inferiors* ,pattern) ,@(loop :for pattern :in patterns
(,@destination-directory ,pattern))) :collect `((:root ,*wild-inferiors* ,pattern)
(t t) (,@destination-directory ,pattern)))
:ignore-inherited-configuration)))) (t t)
:ignore-inherited-configuration))))
(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
(declare (ignorable operation-class system args)) (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
(when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) (declare (ignorable operation-class system args))
(error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
(error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
In case you insist on preserving your previous A-B-L configuration, but In case you insist on preserving your previous A-B-L configuration, but
do not know how to achieve the same effect with A-O-T, you may use function do not know how to achieve the same effect with A-O-T, you may use function
ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
call that function where you would otherwise have loaded and configured A-B-L."))) call that function where you would otherwise have loaded and configured A-B-L."))))
;;;; run-shell-command ;;; run-shell-command
;; ;; WARNING! The function below is not just deprecated but also dysfunctional.
;; WARNING! The function below is dysfunctional and deprecated.
;; Please use asdf/run-program:run-program instead. ;; Please use asdf/run-program:run-program instead.
;; (with-upgradability ()
(defun* run-shell-command (control-string &rest args) (defun run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code. output to *VERBOSE-OUT*. Returns the shell's exit code.
PLEASE DO NOT USE. PLEASE DO NOT USE.
Deprecated function, for backward-compatibility only. Deprecated function, for backward-compatibility only.
Please use ASDF-DRIVER:RUN-PROGRAM instead." Please use ASDF-DRIVER:RUN-PROGRAM instead."
(let ((command (apply 'format nil control-string args))) (let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command) (asdf-message "; $ ~A~%" command)
(run-program command :force-shell t :ignore-error-status t :output *verbose-out*))) (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
(defvar *asdf-verbose* nil) ;; backward-compatibility with ASDF2 only. Unused. (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.
(defgeneric* component-property (component property)) (with-upgradability ()
#-gcl2.6 (defgeneric* (setf component-property) (new-value component property)) (defgeneric component-property (component property))
(defgeneric (setf component-property) (new-value component property))
(defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal))) (defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal)))
(defmethod (setf component-property) (new-value (c component) property)
(let ((a (assoc property (slot-value c 'properties) :test #'equal))) (defmethod (setf component-property) (new-value (c component) property)
(if a (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
(setf (cdr a) new-value) (if a
(setf (slot-value c 'properties) (setf (cdr a) new-value)
(acons property new-value (slot-value c 'properties))))) (setf (slot-value c 'properties)
new-value) (acons property new-value (slot-value c 'properties)))))
new-value))
...@@ -15,74 +15,76 @@ ...@@ -15,74 +15,76 @@
(in-package :asdf/backward-internals) (in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods" ;;;; Backward compatibility with "inline methods"
(with-upgradability ()
(defparameter +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(defparameter +asdf-methods+ (defun %remove-component-inline-methods (component)
'(perform-with-restarts perform explain output-files operation-done-p)) (dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
#'(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
;; clear methods, then add the new ones
(component-inline-methods component) nil)
(defun* %remove-component-inline-methods (component) (defun %define-component-inline-methods (ret rest)
(dolist (name +asdf-methods+) (dolist (name +asdf-methods+)
(map () (let ((keyword (intern (symbol-name name) :keyword)))
;; this is inefficient as most of the stored (loop :for data = rest :then (cddr data)
;; methods will not be for this particular gf :for key = (first data)
;; But this is hardly performance-critical :for value = (second data)
#'(lambda (m) :while data
(remove-method (symbol-function name) m)) :when (eq key keyword) :do
(component-inline-methods component))) (destructuring-bind (op qual (o c) &body body) value
;; clear methods, then add the new ones (pushnew
(component-inline-methods component) nil) (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
,@body))
(component-inline-methods ret)))))))
(defun* %define-component-inline-methods (ret rest) (defun %refresh-component-inline-methods (component rest)
(dolist (name +asdf-methods+) (%remove-component-inline-methods component)
(let ((keyword (intern (symbol-name name) :keyword))) (%define-component-inline-methods component rest)))
(loop :for data = rest :then (cddr data)
:for key = (first data)
:for value = (second data)
:while data
:when (eq key keyword) :do
(destructuring-bind (op qual (o c) &body body) value
(pushnew
(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
,@body))
(component-inline-methods ret)))))))
(defun* %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
;; and the companion asdf:feature pseudo-dependency. ;; and the companion asdf:feature pseudo-dependency.
;; This won't recurse into dependencies to accumulate feature conditions. ;; This won't recurse into dependencies to accumulate feature conditions.
;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. ;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
(defun* %resolve-if-component-dep-fails (if-component-dep-fails component) (with-upgradability ()
(asdf-message "The system definition for ~S uses deprecated ~ (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
(asdf-message "The system definition for ~S uses deprecated ~
ASDF option :IF-COMPONENT-DEP-DAILS. ~ ASDF option :IF-COMPONENT-DEP-DAILS. ~
Starting with ASDF 3, please use :IF-FEATURE instead" Starting with ASDF 3, please use :IF-FEATURE instead"
(coerce-name (component-system component))) (coerce-name (component-system component)))
;; This only supports the pattern of use of the "feature" seen in the wild ;; This only supports the pattern of use of the "feature" seen in the wild
(check-type component parent-component) (check-type component parent-component)
(check-type if-component-dep-fails (member :fail :ignore :try-next)) (check-type if-component-dep-fails (member :fail :ignore :try-next))
(unless (eq if-component-dep-fails :fail) (unless (eq if-component-dep-fails :fail)
(loop :with o = (make-operation 'compile-op) (loop :with o = (make-operation 'compile-op)
:for c :in (component-children component) :do :for c :in (component-children component) :do
(loop* :for (feature? feature) :in (component-depends-on o c) (loop* :for (feature? feature) :in (component-depends-on o c)
:when (eq feature? 'feature) :do :when (eq feature? 'feature) :do
(setf (component-if-feature c) feature))))) (setf (component-if-feature c) feature))))))
(when-upgrading (:when (fboundp 'make-sub-operation)) (when-upgrading (:when (fboundp 'make-sub-operation))
(defun* make-sub-operation (c o dep-c dep-o) (defun make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
;;;; load-sysdef ;;;; load-sysdef
(defun* load-sysdef (name pathname) (with-upgradability ()
(load-asd pathname :name name)) (defun load-sysdef (name pathname)
(load-asd pathname :name name))
(defun* make-temporary-package () (defun make-temporary-package ()
;; For loading a .asd file, we dont't make a temporary package anymore, ;; For loading a .asd file, we dont't make a temporary package anymore,
;; but use ASDF-USER. I'd like to have this function do this, ;; but use ASDF-USER. I'd like to have this function do this,
;; but since whoever uses it is likely to delete-package the result afterwards, ;; but since whoever uses it is likely to delete-package the result afterwards,
;; this would be a bad idea, so preserve the old behavior. ;; this would be a bad idea, so preserve the old behavior.
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))) (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
This diff is collapsed.
...@@ -13,39 +13,42 @@ ...@@ -13,39 +13,42 @@
;; * fewer accesses to the filesystem ;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files ;; * the ability to test with fake timestamps, without touching files
(defvar *asdf-cache* nil) (with-upgradability ()
(defvar *asdf-cache* nil)
(defun set-asdf-cache-entry (key value-list)
(apply 'values (defun set-asdf-cache-entry (key value-list)
(if *asdf-cache* (apply 'values
(setf (gethash key *asdf-cache*) value-list) (if *asdf-cache*
value-list))) (setf (gethash key *asdf-cache*) value-list)
value-list)))
(defun consult-asdf-cache (key thunk)
(if *asdf-cache* (defun consult-asdf-cache (key thunk)
(multiple-value-bind (results foundp) (gethash key *asdf-cache*) (if *asdf-cache*
(if foundp (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(apply 'values results) (if foundp
(set-asdf-cache-entry key (multiple-value-list (funcall thunk))))) (apply 'values results)
(funcall thunk))) (set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
(funcall thunk)))
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body))) (defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
(defun call-with-asdf-cache (thunk &key override)
(if (and *asdf-cache* (not override)) (defun call-with-asdf-cache (thunk &key override)
(funcall thunk) (if (and *asdf-cache* (not override))
(let ((*asdf-cache* (make-hash-table :test 'equal))) (funcall thunk)
(funcall thunk)))) (let ((*asdf-cache* (make-hash-table :test 'equal)))
(funcall thunk))))
(defmacro with-asdf-cache ((&key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override)) (defmacro with-asdf-cache ((&key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
(defun compute-file-stamp (file)
(safe-file-write-date file)) (defun compute-file-stamp (file)
(safe-file-write-date file))
(defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(set-asdf-cache-entry `(get-file-stamp ,file) (list stamp))) (defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
(set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
(defun get-file-stamp (file)
(do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))) (defun get-file-stamp (file)
(do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))))
...@@ -47,7 +47,7 @@ ...@@ -47,7 +47,7 @@
(setf *print-readably* nil)) (setf *print-readably* nil))
#+cormanlisp #+cormanlisp
(progn (eval-when (:load-toplevel :compile-toplevel :execute)
(deftype logical-pathname () nil) (deftype logical-pathname () nil)
(defun make-broadcast-stream () *error-output*) (defun make-broadcast-stream () *error-output*)
(defun translate-logical-pathname (x) x) (defun translate-logical-pathname (x) x)
...@@ -81,8 +81,8 @@ ...@@ -81,8 +81,8 @@
(export 'type-of :asdf/common-lisp) (export 'type-of :asdf/common-lisp)
(export 'system:*load-pathname* :asdf/common-lisp)) (export 'system:*load-pathname* :asdf/common-lisp))
#+gcl2.6 #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
(progn ;; Doesn't support either logical-pathnames or output-translations. (eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *gcl2.6* t) (defvar *gcl2.6* t)
(deftype logical-pathname () nil) (deftype logical-pathname () nil)
(defun type-of (x) (class-name (class-of x))) (defun type-of (x) (class-name (class-of x)))
...@@ -108,13 +108,14 @@ ...@@ -108,13 +108,14 @@
(namestring (make-pathname :name nil :type nil :version nil :defaults path)))))) (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
#+genera #+genera
(unless (fboundp 'ensure-directories-exist) (eval-when (:load-toplevel :compile-toplevel :execute)
(defun ensure-directories-exist (path) (unless (fboundp 'ensure-directories-exist)
(fs:create-directories-recursively (pathname path)))) (defun ensure-directories-exist (path)
(fs:create-directories-recursively (pathname path)))))