Commit 8ec5317d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.126: debugging ecl, upgrade, etc.

Don't key upgrade attempt on source-registry, since things can also change
in the central-registry, etc.
Also rename required-files to direct-dependency-files
Improve the new convenience function pattern to work with operation initargs.
Implement getcwd on all platforms.
Actually catch sb-grovel messages.

Tests: make u l=ecl instead of make test-upgrade lisp=ecl
Tests: put the setup around the script, not inside;
Tests: start using globals, much easier for debugging
parent 328a6357
...@@ -18,7 +18,7 @@ endif ...@@ -18,7 +18,7 @@ endif
## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen. ## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests. ## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
lisp ?= sbcl l ?= sbcl
ABCL ?= abcl ABCL ?= abcl
ALLEGRO ?= alisp ALLEGRO ?= alisp
...@@ -117,30 +117,33 @@ mrproper: clean ...@@ -117,30 +117,33 @@ mrproper: clean
rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap
test-upgrade: build/asdf.lisp test-upgrade: build/asdf.lisp
./test/run-tests.sh -u ${lisp} ./test/run-tests.sh -u ${l}
u: test-upgrade
test-clean-load: build/asdf.lisp test-clean-load: build/asdf.lisp
./test/run-tests.sh -c ${lisp} ./test/run-tests.sh -c ${l}
# test-glob has been replaced by t, and lisp by l, easier to type
test-lisp: build/asdf.lisp test-lisp: build/asdf.lisp
@cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob} @cd test; ${MAKE} clean;./run-tests.sh ${l} ${t}
t: test-lisp
test: test-lisp test-clean-load doc test: test-lisp test-clean-load doc
test-all-lisps: test-all-lisps:
@for lisp in ${lisps} ; do \ @for lisp in ${lisps} ; do \
${MAKE} test-lisp test-upgrade lisp=$$lisp || exit 1 ; \ ${MAKE} test-lisp test-upgrade l=$$lisp || exit 1 ; \
done done
# test upgrade is a very long run... This does just the regression tests # test upgrade is a very long run... This does just the regression tests
test-all-noupgrade: test-all-noupgrade:
@for lisp in ${lisps} ; do \ @for lisp in ${lisps} ; do \
${MAKE} test-lisp lisp=$$lisp || exit 1 ; \ ${MAKE} test-lisp l=$$lisp || exit 1 ; \
done done
test-all-upgrade: test-all-upgrade:
@for lisp in ${lisps} ; do \ @for lisp in ${lisps} ; do \
${MAKE} test-upgrade lisp=$$lisp || exit 1 ; \ ${MAKE} test-upgrade l=$$lisp || exit 1 ; \
done done
test-all: test-forward-references doc test-all-lisps test-all: test-forward-references doc test-all-lisps
......
...@@ -17,7 +17,7 @@ ...@@ -17,7 +17,7 @@
#:action-status #:action-stamp #:action-done-p #:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp #:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:feature #:perform #:perform-with-restarts #:retry #:accept #:feature
#:traverse-actions #:traverse-sub-actions #:required-components #:required-files ;; in plan #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
)) ))
(in-package :asdf/action) (in-package :asdf/action)
...@@ -26,34 +26,35 @@ ...@@ -26,34 +26,35 @@
(defgeneric* traverse-actions (actions &key &allow-other-keys)) (defgeneric* traverse-actions (actions &key &allow-other-keys))
(defgeneric* traverse-sub-actions (operation component &key &allow-other-keys)) (defgeneric* traverse-sub-actions (operation component &key &allow-other-keys))
(defgeneric* required-components (component &key &allow-other-keys)) (defgeneric* required-components (component &key &allow-other-keys))
(defgeneric* required-files (operation component &key &allow-other-keys))
;;;; Convenience methods ;;;; Convenience methods
(defmacro define-convenience-action-methods (defmacro define-convenience-action-methods
(function (operation component &rest more-args) &key if-no-operation if-no-component) (function (operation component &optional keyp)
(let ((rest (gensym "REST")) &key if-no-operation if-no-component operation-initargs)
(found (gensym "FOUND"))) (let* ((rest (gensym "REST"))
`(progn (found (gensym "FOUND"))
(defmethod ,function ((,operation symbol) ,component (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
,@(when more-args `(&rest ,rest)) (flet ((next-method (o c)
,@(when (member '&key more-args) `(&key &allow-other-keys))) (if keyp
(if ,operation `(apply ',function ,o ,c ,rest)
,(if more-args `(,function ,o ,c))))
`(apply ',function (make-operation ,operation) ,component ,rest) `(progn
`(,function (make-operation ,operation) ,component)) (defmethod ,function ((,operation symbol) ,component ,@more-args)
,if-no-operation)) (if ,operation
(defmethod ,function ((,operation operation) ,component ,(next-method
,@(when more-args `(&rest ,rest)) (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
,@(when (member '&key more-args) `(&key &allow-other-keys))) `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
(if (typep ,component 'component) `(make-operation ,operation))
(error "No defined method for ~S on ~S" ',function ,component) `(find-component () ,component))
(let ((,found (find-component () ,component))) ,if-no-operation))
(if ,found (defmethod ,function ((,operation operation) ,component ,@more-args)
,(if more-args (if (typep ,component 'component)
`(apply ',function ,operation ,found ,rest) (error "No defined method for ~S on ~S" ',function ,component)
`(,function ,operation ,found)) (let ((,found (find-component () ,component)))
,if-no-component))))))) (if ,found
,(next-method operation found)
,if-no-component))))))))
;;;; self-description ;;;; self-description
...@@ -64,9 +65,7 @@ on this component, e.g. \"loading /a/b/c\". ...@@ -64,9 +65,7 @@ on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase.")) You can put together sentences using this phrase."))
(defmethod operation-description (operation component) (defmethod operation-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>") (format nil (compatfmt "~@<~A on ~A~@:>")
(class-of operation) component)) (type-of operation) component))
(define-convenience-action-methods operation-description (operation component))
(defgeneric* explain (operation component)) (defgeneric* explain (operation component))
(defmethod explain ((o operation) (c component)) (defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c))) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
...@@ -144,8 +143,8 @@ You can put together sentences using this phrase.")) ...@@ -144,8 +143,8 @@ You can put together sentences using this phrase."))
;;;; Inputs, Outputs, and invisible dependencies ;;;; Inputs, Outputs, and invisible dependencies
(defgeneric* output-files (operation component)) (defgeneric* (output-files) (operation component))
(defgeneric* input-files (operation component)) (defgeneric* (input-files) (operation component))
(defgeneric* operation-done-p (operation component) (defgeneric* operation-done-p (operation component)
(:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) (: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 output-files (operation component))
...@@ -162,7 +161,8 @@ You can put together sentences using this phrase.")) ...@@ -162,7 +161,8 @@ You can put together sentences using this phrase."))
(values (values
(multiple-value-bind (pathnames fixedp) (call-next-method) (multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames ;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname (component-pathname component))) (let* ((directory (pathname-directory-pathname
(component-pathname (find-component () component))))
(absolute-pathnames (absolute-pathnames
(loop (loop
:for pathname :in pathnames :for pathname :in pathnames
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
: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.26.125" ;; to be automatically updated by bin/bump-revision :version "2.26.126" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
...@@ -28,9 +28,6 @@ ...@@ -28,9 +28,6 @@
(declare (ignorable o)) (declare (ignorable o))
(perform (make-instance 'load-source-op) c)) (perform (make-instance 'load-source-op) c))
#+(and clisp (not asdf2.27))
(rename-package :asdf :asdf-utilities)
#+asdf2.27 #+asdf2.27
(defsystem :asdf/defsystem (defsystem :asdf/defsystem
:licence "MIT" :licence "MIT"
......
...@@ -9,7 +9,9 @@ ...@@ -9,7 +9,9 @@
:asdf/run-program :asdf/lisp-build :asdf/run-program :asdf/lisp-build
:asdf/configuration) :asdf/configuration)
(:export (:export
#:coerce-pathname #:component-name-to-pathname-components)) #:coerce-pathname #:component-name-to-pathname-components
#+(or ecl mkcl) #:compile-file-keeping-object
))
(in-package :asdf/backward-driver) (in-package :asdf/backward-driver)
;;;; Backward compatibility with various pathname functions. ;;;; Backward compatibility with various pathname functions.
...@@ -34,3 +36,5 @@ ...@@ -34,3 +36,5 @@
unix-style-namestring)) unix-style-namestring))
(values relabs path filename))) (values relabs path filename)))
#+(or ecl mkcl)
(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* args))
...@@ -9,7 +9,7 @@ ...@@ -9,7 +9,7 @@
(:export (:export
#:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op #:required-files #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
#:program-op #:program-op
#:compiled-file #:precompiled-system #:prebuilt-system #:compiled-file #:precompiled-system #:prebuilt-system
...@@ -199,7 +199,7 @@ ...@@ -199,7 +199,7 @@
#+mkcl (equal type (compile-file-type :fasl-p nil)) #+mkcl (equal type (compile-file-type :fasl-p nil))
#+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
(defgeneric* trivial-system-p (component)) (defgeneric* (trivial-system-p) (component))
(defun* user-system-p (s) (defun* user-system-p (s)
(and (typep s 'system) (and (typep s 'system)
...@@ -221,13 +221,13 @@ ...@@ -221,13 +221,13 @@
(declare (ignorable o)) (declare (ignorable o))
`((lib-op ,@(required-components c :other-systems t :component-type 'system `((lib-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation 'load-op :goal-operation 'load-op
:keep-operation 'load-op)))) :keep-operation 'compile-op))))
(defmethod component-depends-on ((o monolithic-fasl-op) (c system)) (defmethod component-depends-on ((o monolithic-fasl-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
`((fasl-op ,@(required-components c :other-systems t :component-type 'system `((fasl-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation 'load-fasl-op :goal-operation 'load-fasl-op
:keep-operation 'load-fasl-op)))) :keep-operation 'fasl-op))))
(defmethod component-depends-on ((o program-op) (c system)) (defmethod component-depends-on ((o program-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
...@@ -247,7 +247,7 @@ ...@@ -247,7 +247,7 @@
(declare (ignorable o)) (declare (ignorable o))
`((compile-op ,@(required-components c :other-systems nil :component-type '(not system) `((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
:goal-operation 'load-op :goal-operation 'load-op
:keep-operation 'load-op)))) :keep-operation 'compile-op))))
(defmethod component-depends-on ((o fasl-op) (c system)) (defmethod component-depends-on ((o fasl-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
...@@ -268,15 +268,15 @@ ...@@ -268,15 +268,15 @@
`((,op ,c)) `((,op ,c))
(call-next-method))) (call-next-method)))
(defmethod required-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) (defun* direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
(while-collecting (collect) (while-collecting (collect)
(visit-dependencies (map-direct-dependencies
() o c #'(lambda (sub-o sub-c) o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f)))))) :when (funcall test f) :do (collect f))))))
(defmethod input-files ((o bundle-op) (c system)) (defmethod input-files ((o bundle-op) (c system))
(required-files o c :test 'bundlable-file-p :key 'output-files)) (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
(defun* select-bundle-operation (type &optional monolithic) (defun* select-bundle-operation (type &optional monolithic)
(ecase type (ecase type
...@@ -427,6 +427,7 @@ ...@@ -427,6 +427,7 @@
(non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
(output-files (output-files o c)) (output-files (output-files o c))
(output-file (first output-files))) (output-file (first output-files)))
(unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
(when input-files (when input-files
(assert output-files) (assert output-files)
(when non-fasl-files (when non-fasl-files
......
...@@ -27,8 +27,9 @@ ...@@ -27,8 +27,9 @@
#:module-default-component-class #:module-default-component-class
#:module-components ;; backward-compatibility. DO NOT USE. #:module-components ;; backward-compatibility. DO NOT USE.
;; Internals we'd like to share with the ASDF package. ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
#:name #:version #:description #:long-description #:name #:version #:description #:long-description #:author #:maintainer #:licence
#:defsystem-depends-on
#:sibling-dependencies #:if-feature #:in-order-to #:inline-methods #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
#:relative-pathname #:absolute-pathname #:operation-times #:around-compile #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
#:%encoding #:properties #:parent)) #:%encoding #:properties #:parent))
...@@ -101,8 +102,7 @@ another pathname in a degenerate way.")) ...@@ -101,8 +102,7 @@ another pathname in a degenerate way."))
:accessor component-operation-times) :accessor component-operation-times)
(around-compile :initarg :around-compile) (around-compile :initarg :around-compile)
(%encoding :accessor %component-encoding :initform nil :initarg :encoding) (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
;; XXX we should provide some atomic interface for updating the ;; ASDF3: get rid of these "component properties" ?
;; component properties
(properties :accessor component-properties :initarg :properties (properties :accessor component-properties :initarg :properties
:initform nil) :initform nil)
;; For backward-compatibility, this slot is part of component rather than child-component ;; For backward-compatibility, this slot is part of component rather than child-component
...@@ -190,7 +190,7 @@ another pathname in a degenerate way.")) ...@@ -190,7 +190,7 @@ another pathname in a degenerate way."))
;;;; component pathnames ;;;; component pathnames
(defgeneric* component-parent-pathname (component)) (defgeneric* (component-parent-pathname) (component))
(defmethod component-parent-pathname (component) (defmethod component-parent-pathname (component)
(component-pathname (component-parent component))) (component-pathname (component-parent component)))
......
...@@ -65,14 +65,14 @@ ...@@ -65,14 +65,14 @@
(return inputs))) (return inputs)))
(defmethod input-files ((o load-concatenated-source-op) (s system)) (defmethod input-files ((o load-concatenated-source-op) (s system))
(required-files o s)) (direct-dependency-files o s))
(defmethod input-files ((o compile-concatenated-source-op) (s system)) (defmethod input-files ((o compile-concatenated-source-op) (s system))
(required-files o s)) (direct-dependency-files o s))
(defmethod output-files ((o compile-concatenated-source-op) (s system)) (defmethod output-files ((o compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s)))) (let ((input (first (input-files o s))))
(list (compile-file-pathname input)))) (list (compile-file-pathname input))))
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(required-files o s)) (direct-dependency-files o s))
(defmethod perform ((o concatenate-source-op) (s system)) (defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s)) (let ((inputs (input-files o s))
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory* #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location-component #:resolve-absolute-location-component)) #:resolve-relative-location #:resolve-absolute-location))
(in-package :asdf/configuration) (in-package :asdf/configuration)
(define-condition invalid-configuration () (define-condition invalid-configuration ()
...@@ -151,7 +151,7 @@ values of TAG include :source-registry and :output-translations." ...@@ -151,7 +151,7 @@ values of TAG include :source-registry and :output-translations."
:do (report-invalid-form invalid-form-reporter :form form :location file))) :do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration))) :inherit-configuration)))
(defun* resolve-relative-location-component (x &key ensure-directory wilden) (defun* resolve-relative-location (x &key ensure-directory wilden)
(ensure-pathname (ensure-pathname
(etypecase x (etypecase x
(pathname x) (pathname x)
...@@ -159,12 +159,12 @@ values of TAG include :source-registry and :output-translations." ...@@ -159,12 +159,12 @@ values of TAG include :source-registry and :output-translations."
x :ensure-directory ensure-directory)) x :ensure-directory ensure-directory))
(cons (cons
(if (null (cdr x)) (if (null (cdr x))
(resolve-relative-location-component (resolve-relative-location
(car x) :ensure-directory ensure-directory :wilden wilden) (car x) :ensure-directory ensure-directory :wilden wilden)
(let* ((car (resolve-relative-location-component (let* ((car (resolve-relative-location
(car x) :ensure-directory t :wilden nil))) (car x) :ensure-directory t :wilden nil)))
(merge-pathnames* (merge-pathnames*
(resolve-relative-location-component (resolve-relative-location
(cdr x) :ensure-directory ensure-directory :wilden wilden) (cdr x) :ensure-directory ensure-directory :wilden wilden)
car)))) car))))
((eql :*/) *wild-directory*) ((eql :*/) *wild-directory*)
...@@ -201,7 +201,7 @@ directive.") ...@@ -201,7 +201,7 @@ directive.")
'(:home ".cache" "common-lisp" :implementation))))) '(:home ".cache" "common-lisp" :implementation)))))
(register-image-restore-hook 'compute-user-cache) (register-image-restore-hook 'compute-user-cache)
(defun* resolve-absolute-location-component (x &key ensure-directory wilden) (defun* resolve-absolute-location (x &key ensure-directory wilden)
(ensure-pathname (ensure-pathname
(etypecase x (etypecase x
(pathname x) (pathname x)
...@@ -211,43 +211,43 @@ directive.") ...@@ -211,43 +211,43 @@ directive.")
#+mcl (unless p (error "POSIX pathname ~S does not exist" x)) #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
(if ensure-directory (ensure-directory-pathname p) p))) (if ensure-directory (ensure-directory-pathname p) p)))
(cons (cons
(return-from resolve-absolute-location-component (return-from resolve-absolute-location
(if (null (cdr x)) (if (null (cdr x))
(resolve-absolute-location-component (resolve-absolute-location
(car x) :ensure-directory ensure-directory :wilden wilden) (car x) :ensure-directory ensure-directory :wilden wilden)
(merge-pathnames* (merge-pathnames*
(resolve-relative-location-component (resolve-relative-location
(cdr x) :ensure-directory ensure-directory :wilden wilden) (cdr x) :ensure-directory ensure-directory :wilden wilden)
(resolve-absolute-location-component (resolve-absolute-location
(car x) :ensure-directory t :wilden nil))))) (car x) :ensure-directory t :wilden nil)))))
((eql :root) ((eql :root)
;; special magic! we return a relative pathname, ;; special magic! we return a relative pathname,
;; but what it means to the output-translations is ;; but what it means to the output-translations is
;; "relative to the root of the source pathname's host and device". ;; "relative to the root of the source pathname's host and device".
(return-from resolve-absolute-location-component (return-from resolve-absolute-location
(let ((p (make-pathname* :directory '(:relative)))) (let ((p (make-pathname* :directory '(:relative))))
(if wilden (wilden p) p)))) (if wilden (wilden p) p))))
((eql :home) (user-homedir)) ((eql :home) (user-homedir))
((eql :here) (resolve-absolute-location-component ((eql :here) (resolve-absolute-location
*here-directory* :ensure-directory t :wilden nil)) *here-directory* :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location-component ((eql :user-cache) (resolve-absolute-location
*user-cache* :ensure-directory t :wilden nil))) *user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x))) :wilden (and wilden (not (pathnamep x)))
:want-absolute t)) :want-absolute t))
(defun* resolve-location (x &key ensure-directory wilden directory) (defun* (resolve-location) (x &key ensure-directory wilden directory)
(when directory (setf ensure-directory t)) ;; :directory backward compatibility, until 2014-01-16. (when directory (setf ensure-directory t)) ;; :directory backward compatibility, until 2014-01-16.
(if (atom x) (if (atom x)
(resolve-absolute-location-component x :ensure-directory ensure-directory :wilden wilden) (resolve-absolute-location x :ensure-directory ensure-directory :wilden wilden)
(loop :with (first . rest) = x (loop :with (first . rest) = x
:with path = (resolve-absolute-location-component :with path = (resolve-absolute-location
first :ensure-directory (and (or ensure-directory rest) t) first :ensure-directory (and (or ensure-directory rest) t)
:wilden (and wilden (null rest))) :wilden (and wilden (null rest)))
:for (element . morep) :on rest :for (element . morep) :on rest
:for dir = (and (or morep ensure-directory) t) :for dir = (and (or morep ensure-directory) t)
:for wild = (and wilden (not morep)) :for wild = (and wilden (not morep))
:do (setf path (merge-pathnames* :do (setf path (merge-pathnames*
(resolve-relative-location-component (resolve-relative-location
element :ensure-directory dir :wilden wild) element :ensure-directory dir :wilden wild)
path)) path))
:finally (return path)))) :finally (return path))))
......
...@@ -33,8 +33,7 @@ ...@@ -33,8 +33,7 @@
;; If no absolute pathname was found, we return NIL. ;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname)) (check-type pathname (or null string pathname))
(absolutize-pathnames (absolutize-pathnames
(list pathname (load-pathname) *default-pathname-defaults* (list pathname (load-pathname) *default-pathname-defaults* (getcwd))
#-(or abcl gcl genera) (getcwd))
:resolve-symlinks *resolve-symlinks*)) :resolve-symlinks *resolve-symlinks*))
......
...@@ -107,9 +107,10 @@ ...@@ -107,9 +107,10 @@
(equal (missing-requires c) name)))))))) (equal (missing-requires c) name))))))))
(defun* resolve-dependency-spec (component dep-spec) (defun* resolve-dependency-spec (component dep-spec)
(if (atom dep-spec) (let ((component (find-component () component)))
(resolve-dependency-name component dep-spec) (if (atom dep-spec)
(resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))) (resolve-dependency-name component dep-spec)
(resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
(defmethod resolve-dependency-combination (component combinator arguments) (defmethod resolve-dependency-combination (component combinator arguments)
(error (compatfmt "~@<Bad dependency ~S for ~S~@:>") (error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
......
...@@ -158,8 +158,7 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -158,8 +158,7 @@ Going forward, we recommend new users should be using the source-registry.
(let* ((file (probe-file* (let* ((file (probe-file*
(absolutize-pathnames (absolutize-pathnames
(list (make-pathname :name name :type "asd") (list (make-pathname :name name :type "asd")
defaults *default-pathname-defaults* defaults *default-pathname-defaults* (getcwd))
#-(or abcl gcl genera) (getcwd))
:resolve-symlinks truename) :resolve-symlinks truename)
:truename truename))) :truename truename)))
(when file (when file
...@@ -224,7 +223,7 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -224,7 +223,7 @@ Going forward, we recommend new users should be using the source-registry.
(subseq *central-registry* (1+ position)))))))))) (subseq *central-registry* (1+ position))))))))))
(defun* make-temporary-package () (defun* make-temporary-package ()
(make-package (fresh-package-name :asdf 0) :use '(:cl :asdf/interface))) (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf/interface)))
(defmethod find-system ((name null) &optional (error-p t)) (defmethod find-system ((name null) &optional (error-p t))
(declare (ignorable name)) (declare (ignorable name))
...@@ -346,3 +345,20 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -346,3 +345,20 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(defun* sysdef-find-pre-loaded-systems (requested) (defun* sysdef-find-pre-loaded-systems (requested)
(loop :for (provided . keys) :in *pre-loaded-systems* (loop :for (provided . keys) :in *pre-loaded-systems*
:thereis (apply 'find-system-fallback requested provided keys))) :thereis (apply 'find-system-fallback requested provided keys)))
;;;; Beware of builtin systems
(defmethod builtin-system-p ((s system))
(or
;; For most purposes, asdf itself specially counts as builtin.
;; if you want to link it or do something forbidden to builtins,
;; specify separate dependencies on asdf-driver and asdf-defsystem.
(equal "asdf" (coerce-name s))
;; Other builtin systems are those under the implementation directory
(let* ((system (find-system s nil))
(sysdir (and system (component-pathname system)))
(truesysdir (truename* sysdir))
(impdir (lisp-implementation-directory))
(trueimpdir (truename* impdir)))
(and sysdir impdir
(or (subpathp sysdir impdir)
(subpathp truesysdir trueimpdir))))))
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.125: Another System Definition Facility. ;;; This is ASDF 2.26.126: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -146,3 +146,4 @@ ...@@ -146,3 +146,4 @@
#:system-source-registry #:system-source-registry
#:user-source-registry-directory #:user-source-registry-directory
#:system-source-registry-directory)) #:system-source-registry-directory))
...@@ -115,10 +115,10 @@ ...@@ -115,10 +115,10 @@
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
`(,f ;; the fasl is the primary output, in first position `(,f ;; the fasl is the primary output, in first position
#+ecl ,@(unless (use-ecl-byte-compiler-p) #+ecl ,@(unless (use-ecl-byte-compiler-p)
(compile-file-pathname i :type :object)) `(,(compile-file-pathname i :type :object)))
#+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file #+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file
#+sbcl ,@(let ((s (component-system c))) #+sbcl ,@(let ((s (component-system c)))
(unless (or (builtin-system-p s) (equal (component-name s) "asdf")) (unless (builtin-system-p s) ; includes ASDF itself
`(,(make-pathname :type "sbcl-warnings" :defaults f))))))) `(,(make-pathname :type "sbcl-warnings" :defaults f)))))))
(defmethod component-depends-on ((o compile-op) (c component)) (defmethod component-depends-on ((o compile-op) (c component))
(declare (ignorable o)) (declare (ignorable o))
......
...@@ -39,7 +39,8 @@ Valid values are :error, :warn, and :ignore.") ...@@ -39,7 +39,8 @@ Valid values are :error, :warn, and :ignore.")
(defvar *compile-file-failure-behaviour* (defvar *compile-file-failure-behaviour*
(or #+(or mkcl sbcl) :error #+clisp :ignore :warn) (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
"How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
when compiling a file? Valid values are :error, :warn, and :ignore. when compiling a file, which includes any non-style-warning warning.
Valid values are :error, :warn, and :ignore.
Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")