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
## 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.
lisp ?= sbcl
l ?= sbcl
ABCL ?= abcl
ALLEGRO ?= alisp
......@@ -117,30 +117,33 @@ mrproper: clean
rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap
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/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
@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-all-lisps:
@for lisp in ${lisps} ; do \
${MAKE} test-lisp test-upgrade lisp=$$lisp || exit 1 ; \
${MAKE} test-lisp test-upgrade l=$$lisp || exit 1 ; \
done
# test upgrade is a very long run... This does just the regression tests
test-all-noupgrade:
@for lisp in ${lisps} ; do \
${MAKE} test-lisp lisp=$$lisp || exit 1 ; \
${MAKE} test-lisp l=$$lisp || exit 1 ; \
done
test-all-upgrade:
@for lisp in ${lisps} ; do \
${MAKE} test-upgrade lisp=$$lisp || exit 1 ; \
${MAKE} test-upgrade l=$$lisp || exit 1 ; \
done
test-all: test-forward-references doc test-all-lisps
......
......@@ -17,7 +17,7 @@
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#: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)
......@@ -26,34 +26,35 @@
(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* required-files (operation component &key &allow-other-keys))
;;;; Convenience methods
(defmacro define-convenience-action-methods
(function (operation component &rest more-args) &key if-no-operation if-no-component)
(let ((rest (gensym "REST"))
(found (gensym "FOUND")))
`(progn
(defmethod ,function ((,operation symbol) ,component
,@(when more-args `(&rest ,rest))
,@(when (member '&key more-args) `(&key &allow-other-keys)))
(if ,operation
,(if more-args
`(apply ',function (make-operation ,operation) ,component ,rest)
`(,function (make-operation ,operation) ,component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component
,@(when more-args `(&rest ,rest))
,@(when (member '&key more-args) `(&key &allow-other-keys)))
(if (typep ,component 'component)
(error "No defined method for ~S on ~S" ',function ,component)
(let ((,found (find-component () ,component)))
(if ,found
,(if more-args
`(apply ',function ,operation ,found ,rest)
`(,function ,operation ,found))
,if-no-component)))))))
(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))
`(find-component () ,component))
,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args)
(if (typep ,component 'component)
(error "No defined method for ~S on ~S" ',function ,component)
(let ((,found (find-component () ,component)))
(if ,found
,(next-method operation found)
,if-no-component))))))))
;;;; self-description
......@@ -64,9 +65,7 @@ on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
(defmethod operation-description (operation component)
(format nil (compatfmt "~@<~A on ~A~@:>")
(class-of operation) component))
(define-convenience-action-methods operation-description (operation component))
(type-of operation) component))
(defgeneric* explain (operation component))
(defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c)))
......@@ -144,8 +143,8 @@ You can put together sentences using this phrase."))
;;;; Inputs, Outputs, and invisible dependencies
(defgeneric* output-files (operation component))
(defgeneric* input-files (operation component))
(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))
......@@ -162,7 +161,8 @@ You can put together sentences using this phrase."))
(values
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 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
(loop
:for pathname :in pathnames
......
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
: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 ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
......@@ -28,9 +28,6 @@
(declare (ignorable o))
(perform (make-instance 'load-source-op) c))
#+(and clisp (not asdf2.27))
(rename-package :asdf :asdf-utilities)
#+asdf2.27
(defsystem :asdf/defsystem
:licence "MIT"
......
......@@ -9,7 +9,9 @@
:asdf/run-program :asdf/lisp-build
:asdf/configuration)
(: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)
;;;; Backward compatibility with various pathname functions.
......@@ -34,3 +36,5 @@
unix-style-namestring))
(values relabs path filename)))
#+(or ecl mkcl)
(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* args))
......@@ -9,7 +9,7 @@
(:export
#:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
#: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
#:program-op
#:compiled-file #:precompiled-system #:prebuilt-system
......@@ -199,7 +199,7 @@
#+mkcl (equal type (compile-file-type :fasl-p nil))
#+(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)
(and (typep s 'system)
......@@ -221,13 +221,13 @@
(declare (ignorable o))
`((lib-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation 'load-op
:keep-operation 'load-op))))
:keep-operation 'compile-op))))
(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
(declare (ignorable o))
`((fasl-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation 'load-fasl-op
:keep-operation 'load-fasl-op))))
:keep-operation 'fasl-op))))
(defmethod component-depends-on ((o program-op) (c system))
(declare (ignorable o))
......@@ -247,7 +247,7 @@
(declare (ignorable o))
`((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
:goal-operation 'load-op
:keep-operation 'load-op))))
:keep-operation 'compile-op))))
(defmethod component-depends-on ((o fasl-op) (c system))
(declare (ignorable o))
......@@ -268,15 +268,15 @@
`((,op ,c))
(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)
(visit-dependencies
() o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(map-direct-dependencies
o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(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)
(ecase type
......@@ -427,6 +427,7 @@
(non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
(output-files (output-files o c))
(output-file (first output-files)))
(unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
(when input-files
(assert output-files)
(when non-fasl-files
......
......@@ -27,8 +27,9 @@
#:module-default-component-class
#:module-components ;; backward-compatibility. DO NOT USE.
;; Internals we'd like to share with the ASDF package.
#:name #:version #:description #:long-description
;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
#:name #:version #:description #:long-description #:author #:maintainer #:licence
#:defsystem-depends-on
#:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
#:relative-pathname #:absolute-pathname #:operation-times #:around-compile
#:%encoding #:properties #:parent))
......@@ -101,8 +102,7 @@ another pathname in a degenerate way."))
:accessor component-operation-times)
(around-compile :initarg :around-compile)
(%encoding :accessor %component-encoding :initform nil :initarg :encoding)
;; XXX we should provide some atomic interface for updating the
;; component properties
;; ASDF3: get rid of these "component properties" ?
(properties :accessor component-properties :initarg :properties
:initform nil)
;; For backward-compatibility, this slot is part of component rather than child-component
......@@ -190,7 +190,7 @@ another pathname in a degenerate way."))
;;;; component pathnames
(defgeneric* component-parent-pathname (component))
(defgeneric* (component-parent-pathname) (component))
(defmethod component-parent-pathname (component)
(component-pathname (component-parent component)))
......
......@@ -65,14 +65,14 @@
(return inputs)))
(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))
(required-files o s))
(direct-dependency-files o s))
(defmethod output-files ((o compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(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))
(let ((inputs (input-files o s))
......
......@@ -15,7 +15,7 @@
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#: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)
(define-condition invalid-configuration ()
......@@ -151,7 +151,7 @@ values of TAG include :source-registry and :output-translations."
:do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
(defun* resolve-relative-location-component (x &key ensure-directory wilden)
(defun* resolve-relative-location (x &key ensure-directory wilden)
(ensure-pathname
(etypecase x
(pathname x)
......@@ -159,12 +159,12 @@ values of TAG include :source-registry and :output-translations."
x :ensure-directory ensure-directory))
(cons
(if (null (cdr x))
(resolve-relative-location-component
(resolve-relative-location
(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)))
(merge-pathnames*
(resolve-relative-location-component
(resolve-relative-location
(cdr x) :ensure-directory ensure-directory :wilden wilden)
car))))
((eql :*/) *wild-directory*)
......@@ -201,7 +201,7 @@ directive.")
'(:home ".cache" "common-lisp" :implementation)))))
(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
(etypecase x
(pathname x)
......@@ -211,43 +211,43 @@ directive.")
#+mcl (unless p (error "POSIX pathname ~S does not exist" x))
(if ensure-directory (ensure-directory-pathname p) p)))
(cons
(return-from resolve-absolute-location-component
(return-from resolve-absolute-location
(if (null (cdr x))
(resolve-absolute-location-component
(resolve-absolute-location
(car x) :ensure-directory ensure-directory :wilden wilden)
(merge-pathnames*
(resolve-relative-location-component
(resolve-relative-location
(cdr x) :ensure-directory ensure-directory :wilden wilden)
(resolve-absolute-location-component
(resolve-absolute-location
(car x) :ensure-directory t :wilden nil)))))
((eql :root)
;; special magic! we return a relative pathname,
;; but what it means to the output-translations is
;; "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))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :here) (resolve-absolute-location-component
((eql :here) (resolve-absolute-location
*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)))
:wilden (and wilden (not (pathnamep x)))
: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.
(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
:with path = (resolve-absolute-location-component
:with path = (resolve-absolute-location
first :ensure-directory (and (or ensure-directory rest) t)
:wilden (and wilden (null rest)))
:for (element . morep) :on rest
:for dir = (and (or morep ensure-directory) t)
:for wild = (and wilden (not morep))
:do (setf path (merge-pathnames*
(resolve-relative-location-component
(resolve-relative-location
element :ensure-directory dir :wilden wild)
path))
:finally (return path))))
......
......@@ -33,8 +33,7 @@
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
(absolutize-pathnames
(list pathname (load-pathname) *default-pathname-defaults*
#-(or abcl gcl genera) (getcwd))
(list pathname (load-pathname) *default-pathname-defaults* (getcwd))
:resolve-symlinks *resolve-symlinks*))
......
......@@ -107,9 +107,10 @@
(equal (missing-requires c) name))))))))
(defun* resolve-dependency-spec (component dep-spec)
(if (atom dep-spec)
(resolve-dependency-name component dep-spec)
(resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))
(let ((component (find-component () component)))
(if (atom 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)
(error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
......
......@@ -158,8 +158,7 @@ Going forward, we recommend new users should be using the source-registry.
(let* ((file (probe-file*
(absolutize-pathnames
(list (make-pathname :name name :type "asd")
defaults *default-pathname-defaults*
#-(or abcl gcl genera) (getcwd))
defaults *default-pathname-defaults* (getcwd))
:resolve-symlinks truename)
:truename truename)))
(when file
......@@ -224,7 +223,7 @@ Going forward, we recommend new users should be using the source-registry.
(subseq *central-registry* (1+ position))))))))))
(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))
(declare (ignorable name))
......@@ -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)
(loop :for (provided . keys) :in *pre-loaded-systems*
: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 -*-
;;; 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:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -146,3 +146,4 @@
#:system-source-registry
#:user-source-registry-directory
#:system-source-registry-directory))
......@@ -115,10 +115,10 @@
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
`(,f ;; the fasl is the primary output, in first position
#+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
#+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)))))))
(defmethod component-depends-on ((o compile-op) (c component))
(declare (ignorable o))
......
......@@ -39,7 +39,8 @@ Valid values are :error, :warn, and :ignore.")
(defvar *compile-file-failure-behaviour*
(or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
"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.")
......@@ -71,17 +72,28 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;; Condition control
#+sbcl
(progn
(defun sb-grovel-unknown-constant-condition-p (c)
(and (typep c 'sb-int:simple-style-warning)
(string-enclosed-p
"Couldn't grovel for "
(simple-condition-format-control c)
" (unknown to the C compiler).")))
(deftype sb-grovel-unknown-constant-condition ()
'(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
(defvar *uninteresting-compiler-conditions*
(append
#+sbcl
'(sb-c::simple-compiler-note
`(sb-c::simple-compiler-note
"&OPTIONAL and &KEY found in the same lambda list: ~S"
sb-int:package-at-variance
sb-kernel:uninteresting-redefinition
sb-kernel:undefined-alien-style-warning
sb-ext:implicit-generic-function-warning
;; sb-ext:implicit-generic-function-warning ; controversial, but let's allow it by default.
sb-kernel:lexical-environment-too-complex
"Couldn't grovel for ~A (unknown to the C compiler)."
sb-grovel-unknown-constant-condition ; defined above.
;; BEWARE: the below four are controversial to include here.
sb-kernel:redefinition-with-defun
sb-kernel:redefinition-with-defgeneric
......@@ -347,10 +359,10 @@ possibly in a different process. Otherwise just run the BODY."
(funcall *output-translation-function*
(apply 'compile-file-pathname input-file keys)))))
(defun* compile-file* (input-file &rest keys
&key compile-check output-file warnings-file
#+(or ecl mkcl) object-file
&allow-other-keys)
(defun* (compile-file*) (input-file &rest keys
&key compile-check output-file warnings-file
#+(or ecl mkcl) object-file
&allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and
the file only actually created if the compilation was successful,
......@@ -370,7 +382,7 @@ On ECL or MKCL, it creates both the linkable object and loadable fasl files.
On implementations that erroneously do not recognize standard keyword arguments,
it will filter them appropriately."
(let* ((keywords (remove-plist-keys
`(:compile-check :warnings-file
`(:compile-check :warnings-file #+(or ecl mkcl) :object-file
#+gcl<2.7 ,@'(:external-format :print :verbose)) keys))
(output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
#+ecl
......@@ -383,6 +395,10 @@ it will filter them appropriately."
(or object-file
(compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file)))
#+ecl (when (and object-file (equal (compile-file-type) (pathname object-file)))
(format t "Whoa, funky upgrade API switching happening in ~S with ~S ~S~%"
'compile-file* output-file object-file)
(rotatef output-file object-file))
(multiple-value-bind (output-truename warnings-p failure-p)
(with-saved-deferred-warnings (warnings-file)
(or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
......
......@@ -19,6 +19,7 @@
(defgeneric* operate (operation component &key &allow-other-keys))
(define-convenience-action-methods
operate (operation component &key)
:operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
:if-no-component (error 'missing-component :requires component))
(defvar *systems-being-operated* nil
......@@ -67,15 +68,20 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is attempted at any later time, there may be trouble.
;; If we upgraded, restart the OPERATE from scratch,
;; for the function will have been redefined,
;; maybe from a new symbol for it may have been uninterned.
(if (upgrade-asdf)
(apply 'symbol-call :asdf 'operate operation component args)
(let ((plan (apply 'traverse operation system args)))
(perform-plan plan)
(values operation plan)))))
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless systems-being-operated
(let ((operation-name (reify-symbol (type-of operation)))
(component-path (component-find-path component)))
(when (upgrade-asdf)
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined, its symbol uninterned, its package deleted.
(return-from operate
(apply (find-symbol* 'operate :asdf)
(unreify-symbol operation-name)
component-path args)))))
(let ((plan (apply 'traverse operation system args)))
(perform-plan plan)
(values operation plan))))
(defun* oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args))
......
......@@ -50,7 +50,9 @@
spec)
(defmethod find-operation (context (spec symbol))
(apply 'make-operation spec (operation-original-initargs context)))
(defmethod operation-original-initargs ((context null)) context)
(defmethod operation-original-initargs ((context symbol))
(declare (ignorable context))
nil)
(defclass build-op (operation) ())
......@@ -269,7 +269,8 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(defun* getcwd ()
"Get the current working directory as per POSIX getcwd(3), as a pathname object"
(or ;; missing: abcl gcl genera
(or #+abcl (parse-native-namestring
(java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
#+allegro (excl::current-directory)
#+clisp (ext:default-directory)
#+clozure (ccl:current-directory)
......@@ -277,8 +278,9 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(nth-value 1 (unix:unix-current-directory)) :ensure-directory t)
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd)
#+gcl (parse-native-namestring
#+gcl (parse-native-namestring ;; this is a joke. Isn't there a better way?
(first (symbol-call :asdf/driver :run-program/ '("/bin/pwd") :output :lines)))
#+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
#+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
#+sbcl (parse-native-namestring (sb-unix:posix-getcwd/))
......
......@@ -253,14 +253,15 @@ or when loading the package is optional."
(when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
(ensure-package-unused p)
(delete-package package))))
(defun fresh-package-name (&optional (prefix :%TO-BE-DELETED)
(defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
separator
(index (random most-positive-fixnum)))
(loop :for i :from index
:for n = (format nil "~A-~D" prefix i)
:for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
:thereis (and (not (find-package n)) n)))
(defun rename-package-away (p)
(defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
(rename-package
p (fresh-package-name (format nil "__~A__" (package-name p)) 0)))
p (apply 'fresh-package-name :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
(defun package-names (package)
(cons (package-name package) (package-nicknames package)))
(defun packages-from-names (names)
......@@ -421,6 +422,10 @@ or when loading the package is optional."
(let* ((sp (symbol-package symbol))
(in (gethash name inherited))
(xp (and status (symbol-package existing))))
(when (null sp)
(fishy :import-uninterned name (package-name p) mix)
(import symbol p)
(setf sp (package-name p)))
(cond
((gethash name shadowed))
(in
......
......@@ -860,7 +860,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
(delete-file x)))
;;; Translate a pathname
(defun* translate-pathname* (path absolute-source destination &optional root source)
(defun* (translate-pathname*) (path absolute-source destination &optional root source)
(declare (ignore source))
(cond
((functionp destination)
......
......@@ -25,10 +25,25 @@
#:planned-action-count #:planned-output-action-count #:visited-actions
#:visiting-action-set #:visiting-action-list #:plan-actions-r
#:required-components #:filtered-sequential-plan
#:plan-system
#:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
#:traverse-actions #:traverse-sub-actions))
(in-package :asdf/plan)
;;;; Generic plan traversal class
(defclass plan-traversal ()
((system :initform nil :initarg :system :accessor plan-system)
(forced :initform nil :initarg :force :accessor plan-forced)
(forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
(total-action-count :initform 0 :accessor plan-total-action-count)
(planned-action-count :initform 0 :accessor plan-planned-action-count)
(planned-output-action-count :initform 0 :accessor plan-planned-output-action-count)
(visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions)
(visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set)