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)))