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
** Extract minimal test case
* Bug found by fe[nl]ix: infinite loop if the definitions in an asd file
......
......@@ -19,74 +19,77 @@
#:action-path #:find-action #:stamp #:done-p))
(in-package :asdf/action)
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
(with-upgradability ()
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
(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))
(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: dropping original-initags
(defun action-path (action)
(destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
(defun find-action (path)
(destructuring-bind (o . c) path (cons (make-operation o) (find-component () c))))
;;;; Reified representation for storage or debugging. Note: dropping original-initargs
(with-upgradability ()
(defun action-path (action)
(destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
(defun find-action (path)
(destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
;;;; Convenience methods
(defmacro define-convenience-action-methods
(function (operation component &optional keyp)
&key if-no-operation if-no-component operation-initargs)
(let* ((rest (gensym "REST"))
(found (gensym "FOUND"))
(more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
(flet ((next-method (o c)
(if keyp
`(apply ',function ,o ,c ,rest)
`(,function ,o ,c))))
`(progn
(defmethod ,function ((,operation symbol) ,component ,@more-args)
(if ,operation
,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
`(apply 'make-operation ,operation :original-initargs ,rest ,rest)
`(make-operation ,operation))
`(or (find-component () ,component) ,if-no-component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args)
(if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component))
(let ((,found (find-component () ,component)))
(if ,found
,(next-method operation found)
,if-no-component))))))))
(with-upgradability ()
(defmacro define-convenience-action-methods
(function (operation component &optional keyp)
&key if-no-operation if-no-component operation-initargs)
(let* ((rest (gensym "REST"))
(found (gensym "FOUND"))
(more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
(flet ((next-method (o c)
(if keyp
`(apply ',function ,o ,c ,rest)
`(,function ,o ,c))))
`(progn
(defmethod ,function ((,operation symbol) ,component ,@more-args)
(if ,operation
,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
`(apply 'make-operation ,operation :original-initargs ,rest ,rest)
`(make-operation ,operation))
`(or (find-component () ,component) ,if-no-component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args)
(if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component))
(let ((,found (find-component () ,component)))
(if ,found
,(next-method operation found)
,if-no-component)))))))))
;;;; self-description
(defgeneric* action-description (operation component)
(:documentation "returns a phrase that describes performing this operation
(with-upgradability ()
(defgeneric action-description (operation component)
(:documentation "returns a phrase that describes performing this operation
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
(defmethod action-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(type-of operation) component))
(defgeneric* (explain) (operation component))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
(define-convenience-action-methods explain (operation component))
(defmethod action-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(type-of operation) component))
(defgeneric* (explain) (operation component))
(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)
(assert (null colon-p)) (assert (null at-sign-p))
(destructuring-bind (operation . component) action
(princ (action-description operation component) stream)))
(defun format-action (stream action &optional colon-p at-sign-p)
(assert (null colon-p)) (assert (null at-sign-p))
(destructuring-bind (operation . component) action
(princ (action-description operation component) stream))))
;;;; Dependencies
(defgeneric* component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
(:documentation
"Returns a list of dependencies needed by the component to perform
(with-upgradability ()
(defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
(:documentation
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
(<operation> <component>*), where <operation> is a class
......@@ -100,120 +103,122 @@ You can put together sentences using this phrase."))
Methods specialized on subclasses of existing component types
should usually append the results of CALL-NEXT-METHOD to the
list."))
(defgeneric* component-self-dependencies (operation component))
(define-convenience-action-methods component-depends-on (operation component))
(define-convenience-action-methods component-self-dependencies (operation component))
(defgeneric component-self-dependencies (operation component))
(define-convenience-action-methods component-depends-on (operation component))
(define-convenience-action-methods component-self-dependencies (operation component))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
(defmethod component-self-dependencies ((o operation) (c component))
;; NB: result in the same format as component-depends-on
(loop* :for (o-spec . c-spec) :in (component-depends-on o c)
:unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
(defmethod component-self-dependencies ((o operation) (c component))
;; NB: result in the same format as component-depends-on
(loop* :for (o-spec . c-spec) :in (component-depends-on o c)
:unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
:when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep)))
:collect (list o-spec c)))
:collect (list o-spec c))))
;;;; upward-operation, downward-operation
;; These together handle actions that propagate along the component hierarchy.
;; Downward operations like load-op or compile-op propagate down the hierarchy:
;; operation on a parent depends-on operation on its children.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass downward-operation (operation)
((downward-operation
:initform nil :initarg :downward-operation :reader downward-operation)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
((upward-operation
:initform nil :initarg :downward-operation :reader upward-operation)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-let (p (component-parent c))
`((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass sibling-operation (operation)
((sibling-operation
:initform nil :initarg :sibling-operation :reader sibling-operation)))
(defmethod component-depends-on ((o sibling-operation) (c component))
`((,(or (sibling-operation o) o)
,@(loop :for dep :in (component-sibling-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method)))
(with-upgradability ()
(defclass downward-operation (operation)
((downward-operation
:initform nil :initarg :downward-operation :reader downward-operation)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
((upward-operation
:initform nil :initarg :downward-operation :reader upward-operation)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-let (p (component-parent c))
`((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass sibling-operation (operation)
((sibling-operation
:initform nil :initarg :sibling-operation :reader sibling-operation)))
(defmethod component-depends-on ((o sibling-operation) (c component))
`((,(or (sibling-operation o) o)
,@(loop :for dep :in (component-sibling-dependencies c)
:collect (resolve-dependency-spec c dep)))
,@(call-next-method))))
;;;; Inputs, Outputs, and invisible dependencies
(defgeneric* (output-files) (operation component))
(defgeneric* (input-files) (operation component))
(defgeneric* (operation-done-p) (operation component)
(:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
(define-convenience-action-methods output-files (operation component))
(define-convenience-action-methods input-files (operation component))
(define-convenience-action-methods operation-done-p (operation component))
(defmethod operation-done-p ((o operation) (c component))
(declare (ignorable o c))
t)
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to. Memoize the result."
operation component ;; hush genera, not convinced by declare ignorable(!)
(do-asdf-cache `(output-files ,operation ,component)
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames
(loop
:for pathname :in pathnames
:collect (ensure-absolute-pathname pathname directory))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t)))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
nil)
(defun* output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(let ((files (output-files operation component)))
(assert (length=n-p files 1))
(first files)))
(defmethod input-files :around (operation component)
"memoize input files."
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
(defmethod input-files ((o operation) (c parent-component))
(declare (ignorable o c))
nil)
(defmethod input-files ((o operation) (c component))
(or (loop* :for (dep-o) :in (component-self-dependencies o c)
:append (or (output-files dep-o c) (input-files dep-o c)))
;; no non-trivial previous operations needed?
;; I guess we work with the original source file, then
(if-let ((pathname (component-pathname c)))
(and (file-pathname-p pathname) (list pathname)))))
(with-upgradability ()
(defgeneric* (output-files) (operation component))
(defgeneric* (input-files) (operation component))
(defgeneric* (operation-done-p) (operation component)
(:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
(define-convenience-action-methods output-files (operation component))
(define-convenience-action-methods input-files (operation component))
(define-convenience-action-methods operation-done-p (operation component))
(defmethod operation-done-p ((o operation) (c component))
(declare (ignorable o c))
t)
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to. Memoize the result."
operation component ;; hush genera, not convinced by declare ignorable(!)
(do-asdf-cache `(output-files ,operation ,component)
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames
(loop
:for pathname :in pathnames
:collect (ensure-absolute-pathname pathname directory))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t)))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
nil)
(defun output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(let ((files (output-files operation component)))
(assert (length=n-p files 1))
(first files)))
(defmethod input-files :around (operation component)
"memoize input files."
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
(defmethod input-files ((o operation) (c parent-component))
(declare (ignorable o c))
nil)
(defmethod input-files ((o operation) (c component))
(or (loop* :for (dep-o) :in (component-self-dependencies o c)
:append (or (output-files dep-o c) (input-files dep-o c)))
;; no non-trivial previous operations needed?
;; I guess we work with the original source file, then
(if-let ((pathname (component-pathname c)))
(and (file-pathname-p pathname) (list pathname))))))
;;;; Done performing
(with-upgradability ()
(defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
(define-convenience-action-methods component-operation-time (operation component))
(defgeneric* component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
(define-convenience-action-methods component-operation-time (operation component))
(defgeneric* mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp)
(defgeneric* compute-action-stamp (plan operation component &key just-done)
(:documentation "Has this action been successfully done already,
(defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp)
(defgeneric compute-action-stamp (plan operation component &key just-done)
(:documentation "Has this action been successfully done already,
and at what known timestamp has it been done at or will it be done at?
Takes two keywords JUST-DONE and PLAN:
JUST-DONE is a boolean that is true if the action was just successfully performed,
......@@ -227,70 +232,71 @@ Returns two values:
* a boolean DONE-P that indicates whether the action has actually been done,
and both its output-files and its in-image side-effects are up to date."))
(defclass action-status ()
((stamp
:initarg :stamp :reader action-stamp
:documentation "STAMP associated with the ACTION if it has been completed already
(defclass action-status ()
((stamp
:initarg :stamp :reader action-stamp
:documentation "STAMP associated with the ACTION if it has been completed already
in some previous image, or T if it needs to be done.")
(done-p
:initarg :done-p :reader action-done-p
:documentation "a boolean, true iff the action was already done (before any planned action)."))
(:documentation "Status of an action"))
(done-p
:initarg :done-p :reader action-done-p
:documentation "a boolean, true iff the action was already done (before any planned action)."))
(:documentation "Status of an action"))
(defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t)
(with-slots (stamp done-p) status
(format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
(defmethod print-object ((status action-status) stream)
(print-unreadable-object (status stream :type t)
(with-slots (stamp done-p) status
(format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
(defmethod component-operation-time ((o operation) (c component))
(gethash (type-of o) (component-operation-times c)))
(defmethod component-operation-time ((o operation) (c component))
(gethash (type-of o) (component-operation-times c)))
(defmethod mark-operation-done ((o operation) (c component))
(setf (gethash (type-of o) (component-operation-times c))
(compute-action-stamp nil o c :just-done t)))
(defmethod mark-operation-done ((o operation) (c component))
(setf (gethash (type-of o) (component-operation-times c))
(compute-action-stamp nil o c :just-done t))))
;;;; Perform
(defgeneric* (perform-with-restarts) (operation component))
(defgeneric* (perform) (operation component))
(define-convenience-action-methods perform (operation component))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
(defmethod perform :after ((o operation) (c component))
(mark-operation-done o c))
(defmethod perform ((o operation) (c parent-component))
(declare (ignorable o c))
nil)
(defmethod perform ((o operation) (c source-file))
(sysdef-error
(compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
(class-of o) (class-of c)))
(defmethod perform-with-restarts (operation component)
;; TOO verbose, especially as the default. Add your own :before method
;; to perform-with-restart or perform if you want that:
#|(explain operation component)|#
(perform operation component))
(defmethod perform-with-restarts :around (operation component)
(loop
(restart-case
(return (call-next-method))
(retry ()
:report
(lambda (s)
(format s (compatfmt "~@<Retry ~A.~@:>")
(action-description operation component))))
(accept ()
:report
(lambda (s)
(format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
(action-description operation component)))
(mark-operation-done operation component)
(return)))))
(with-upgradability ()
(defgeneric* (perform-with-restarts) (operation component))
(defgeneric* (perform) (operation component))
(define-convenience-action-methods perform (operation component))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
(defmethod perform :after ((o operation) (c component))
(mark-operation-done o c))
(defmethod perform ((o operation) (c parent-component))
(declare (ignorable o c))
nil)
(defmethod perform ((o operation) (c source-file))
(sysdef-error
(compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
(class-of o) (class-of c)))
(defmethod perform-with-restarts (operation component)
;; TOO verbose, especially as the default. Add your own :before method
;; to perform-with-restart or perform if you want that:
#|(explain operation component)|#
(perform operation component))
(defmethod perform-with-restarts :around (operation component)
(loop
(restart-case
(return (call-next-method))
(retry ()
:report
(lambda (s)
(format s (compatfmt "~@<Retry ~A.~@:>")
(action-description operation component))))
(accept ()
:report
(lambda (s)
(format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
(action-description operation component)))
(mark-operation-done operation component)
(return))))))
;;; Generic build operation
(defmethod component-depends-on ((o build-op) (c component))
`((,(or (component-build-operation c) 'load-op) ,c)))
(with-upgradability ()
(defmethod component-depends-on ((o build-op) (c component))
`((,(or (component-build-operation c) 'load-op) ,c))))
......@@ -29,9 +29,9 @@
:description "The defsystem part of ASDF"
:long-name "Another System Definition Facility"
: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.
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/"
:bug-tracker "https://launchpad.net/asdf/"
:mailto "asdf-devel@common-lisp.net"
......@@ -74,25 +74,13 @@
:licence "MIT"
:description "Another System Definition Facility"
: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 ()
#+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
;; If you want to link it or do something forbidden to builtin systems,
;; specify separate dependencies on asdf-driver and asdf-defsystem.
#+asdf3 :builtin-system-p #+asdf3 t
:components
((:module "build"
: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))))
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf3 (prepare-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 @@
;;;; Backward compatibility with various pathname functions.
(defun* coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;; Will be removed after 2014-01-16.
;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(with-upgradability ()
(defun coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;; Will be removed after 2014-01-16.
;;(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
&key force-directory force-relative)
;; Will be removed after 2014-01-16.
;; (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)
(split-unix-namestring-directory-components
unix-style-namestring :ensure-directory force-directory)
(declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
unix-style-namestring))
(values relabs path filename)))
(defun component-name-to-pathname-components (unix-style-namestring
&key force-directory force-relative)
;; Will be removed after 2014-01-16.
;; (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)
(split-unix-namestring-directory-components
unix-style-namestring :ensure-directory force-directory)
(declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
unix-style-namestring))
(values relabs path filename)))
#+(or ecl mkcl)
(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* args))
#+(or ecl mkcl)
(defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
......@@ -20,134 +20,137 @@
#:system-definition-pathname))
(in-package :asdf/backward-interface)
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(with-upgradability ()
(define-condition operation-error (error) ;; Bad, backward-compatible name
;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
(type-of c) (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(defun* component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric* operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation))
#-gcl2.6 (defgeneric* (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric* (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
(declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
(declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
(declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
(defun* system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete,
;; but that won't happen until all clients have been updated.
;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
"Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
(defun component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
(defgeneric operation-on-warnings (operation))
(defgeneric operation-on-failure (operation))
#-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
(declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
(declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
(declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
(declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
(defun system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete,
;; but that won't happen until all clients have been updated.
;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
"Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
It used to expose ASDF internals with subtle differences with respect to
user expectations, that have been refactored away since.
We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;)
(system-source-file x))
(system-source-file x)))
;;;; ASDF-Binary-Locations compatibility
(defun* enable-asdf-binary-locations-compatibility
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
(subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(include-per-user-information nil)
(map-all-source-files (or #+(or clisp ecl mkcl) t nil))
(source-to-target-mappings nil)
(file-types `(,(compile-file-type)
"build-report"
#+ecl (compile-file-type :type :object)
#+mkcl (compile-file-type :fasl-p nil)
#+clisp "lib" #+sbcl "cfasl"
#+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
#+(or clisp ecl mkcl)
(when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((patterns (if map-all-source-files (list *wild-file*)
(loop :for type :in file-types
:collect (make-pathname :type type :defaults *wild-file*))))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir-pathname))))
:implementation ,*wild-inferiors*)
`(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
`(:output-translations
,@source-to-target-mappings
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
#+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
,@(loop :for pattern :in patterns
:collect `((:root ,*wild-inferiors* ,pattern)
(,@destination-directory ,pattern)))