Commit cd3992ff authored by Robert Goldman's avatar Robert Goldman

Merge branch 'fixes' into 'master'

Fixes

Various fixes.

See merge request !43
parents b63ee5fa bd65bcea
......@@ -144,8 +144,7 @@ by installing the source code, and running:
(asdf:load-system :uiop) ;; loading uiop is simple
(map () 'load ;; loading asdf/defsystem is tricky
(mapcar 'asdf:component-pathname
(asdf::required-components :asdf/defsystem :keep-component 'asdf:cl-source-file)))
(asdf:input-files :concatenate-source-op "asdf/defsystem"))
Note that the above can be adapted in a general recipe to get all the files in a system, in order.
To also have the files in systems it transitively depends on, add the `:other-systems t` keyword
......
......@@ -359,12 +359,13 @@ using the JUST-DONE flag."))
(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:
* PLAN is a plan object modelling future effects of actions,
or NIL to denote what actually happened.
* OPERATION and COMPONENT denote the action.
Takes keyword JUST-DONE:
* JUST-DONE is a boolean that is true if the action was just successfully performed,
at which point we want compute the actual stamp and warn if files are missing;
otherwise we are making plans, anticipating the effects of the action.
* PLAN is a plan object modelling future effects of actions,
or NIL to denote what actually happened.
Returns two values:
* a STAMP saying when it was done or will be done,
or T if the action involves files that need to be recomputed.
......
......@@ -88,9 +88,19 @@ itself."))
(defmethod component-depends-on ((o gather-operation) (s system))
(let* ((mono (operation-monolithic-p o))
(deps
(required-components
s :other-systems mono :component-type (if mono 'system '(not system))
:goal-operation 'load-op :keep-operation 'load-op)))
;; Required-components only looks at the dependencies of an action, excluding the action
;; itself, so it may be safely used by an action recursing on its dependencies (which
;; may or may not be an overdesigned API, since in practice we never use it that way).
;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
;; cleaner, we will miss the load-op on the requested system itself, which doesn't
;; matter for a regular system, but matters, a lot, for a package-inferred-system.
;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
;; for our needs of gathering all the files we want to include in a bundle.
;; Note that we use basic-compile-op rather than compile-op so it will still work on
;; systems when *load-system-operation* is load-bundle-op.
(required-components
s :other-systems mono :component-type (if mono 'system '(not system))
:goal-operation 'load-op :keep-operation 'basic-compile-op)))
`((,(or (gather-operation o) (if mono 'lib-op 'compile-op)) ,@deps)
,@(call-next-method))))
......@@ -120,6 +130,9 @@ On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp file
themselves. In any case, this operation will produce what you need to further build
a static runtime for your system, or a dynamic library to load in an existing runtime."))
;; What works: On ECL (and CLASP?), we link the .a output of lib-op into a .so;
;; on MKCL, we link the many .o files from the system directly into the .so;
;; on other implementations, we combine (usually concatenate) the .fasl files into one.
(defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
#+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-operation)
((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
......@@ -476,9 +489,11 @@ or of opaque libraries shipped along the source code."))
(version (component-version s))
(dependencies
(if (operation-monolithic-p o)
;; We want only dependencies, and we use basic-load-op rather than load-op so that
;; this will keep working on systems when *load-system-operation* is load-bundle-op
(remove-if-not 'builtin-system-p
(required-components s :component-type 'system
:keep-operation 'load-op))
:keep-operation 'basic-load-op))
(while-collecting (x) ;; resolve the sideway-dependencies of s
(map-direct-dependencies
t 'load-op s
......@@ -488,7 +503,8 @@ or of opaque libraries shipped along the source code."))
(depends-on (mapcar 'coerce-name dependencies)))
(when (pathname-equal asd (system-source-file s))
(cerror "overwrite the asd file"
"~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
"~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
which is probably not what you want; you probably need to tweak your output translations."
(cons o s) asd))
(with-open-file (s asd :direction :output :if-exists :supersede
:if-does-not-exist :create)
......
......@@ -62,9 +62,9 @@ into a single file"))
:with other-encodings = '()
:with around-compile = (around-compile-hook s)
:with other-around-compile = '()
:for c :in (required-components
s :goal-operation 'load-op
:keep-operation 'load-op
:for c :in (required-components ;; see note about similar call to required-components
s :goal-operation 'load-op ;; in bundle.lisp
:keep-operation 'basic-compile-op
:other-systems (operation-monolithic-p operation))
:append
(when (typep c 'cl-source-file)
......
......@@ -200,8 +200,8 @@ contact maintainers if you need a stable API to do more than that.")
but not even registered as defined"
:format-arguments (list name))))))
(defun register-immutable-system (system-name &rest keys)
"Register SYSTEM-NAME as preloaded and immutable.
(defun register-immutable-system (system-name &rest keys)
"Register SYSTEM-NAME as preloaded and immutable.
It will automatically be considered as passed to FORCE-NOT in a plan."
(let ((system-name (coerce-name system-name)))
(apply 'register-preloaded-system system-name keys)
......
......@@ -24,6 +24,7 @@
;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
#-mkcl ; mkcl 1.1.9 can't fmakunbound a setf function.
(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
(with-upgradability ()
......@@ -54,7 +55,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(pathname-directory (car x)))))
(if (listp directory) (length directory) 0))))))))
new-value)
(defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
(defun (setf output-translations) (new-value) (set-output-translations new-value))
(defun output-translations-initialized-p ()
"Have the output-translations been initialized yet?"
......
(defpackage :test-asdf/dll-user (:use)) ;; dummy, for package-inferred-system dependencies.
(in-package :test-package)
(in-package :asdf-test)
#+(and mkcl os-windows)
(ffi:clines "extern __declspec(dllimport) int sample_function(void);")
......
......@@ -3,9 +3,12 @@
(handler-case (asdf:find-system "duplicate-components")
(asdf:duplicate-names (x) (declare (ignore x)) t)
(asdf:load-system-definition-error (x)
(if (and (asdf/find-system::error-condition x)
(or (and (asdf/find-system::error-condition x)
(typep (asdf/find-system::error-condition x) 'asdf:duplicate-names))
t
(error "LOAD-SYSTEM-DEFINITION-ERROR not as expected (no contained DUPLICATE-NAMES error).")))
(progn
(DBG :err (asdf/find-system::error-condition x))
(error "LOAD-SYSTEM-DEFINITION-ERROR not as expected ~%~
(no contained DUPLICATE-NAMES error)."))))
(:no-error (x)
(error "FIND-SYSTEM of duplicate-components returned ~S instead of raising DUPLICATE-NAMES error." x)))
(error "FIND-SYSTEM of duplicate-components returned ~S ~%~
instead of raising DUPLICATE-NAMES error." x)))
(defpackage :test-asdf/monodll-1 (:use)) ;; dummy, for package-inferred-system dependencies.
#+ecl
(ffi:clines "
extern int always_7();
int always_7()
{
return 7;
}
")
#+clasp (leave-test "Not supported by CLASP yet" 0)
#+mkcl
(ffi:clines "
extern MKCL_DLLEXPORT int always_7(void);
int always_7(void)
{
(ffi:clines
"extern " #+mkcl "MKCL_DLLEXPORT " "int always_7() {
return 7;
}
")
(defpackage :test-asdf/monodll-user (:use)) ;; dummy, for package-inferred-system dependencies.
(in-package :test-package)
(in-package :asdf-test)
(ffi:def-function "always_42" () :returning :int)
(defpackage :test-asdf/monodll (:use :test-asdf/monodll-1)) ;; dummy, for package-inferred-system dependencies.
#+ecl
(ffi:clines "
extern int always_42();
int always_42()
{
return 6*always_7();
}
")
#+clasp (leave-test "Not supported by CLASP yet" 0)
#+mkcl
(ffi:clines "
extern MKCL_DLLEXPORT int always_42(void);
int always_42(void)
{
(ffi:clines
"extern int always_7();"
"extern " #+mkcl "MKCL_DLLEXPORT " "int always_42() {
return 6*always_7();
}
")
......@@ -308,7 +308,7 @@ if ! type "$command" > /dev/null ; then
exit 43
fi
ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)"
ASDFDIR="$(cd $(dirname $0)/.. ; command pwd)"
: ${bcmd:=$command $flags} ${icmd:=$command $flags} # batch and interactive
if [ -z "${DEBUG_ASDF_TEST}" ] ; then
bcmd="$bcmd $nodebug"
......
......@@ -52,7 +52,6 @@
#+(or ecl mkcl)
(progn
(DBG "On ECL and MKCL, test dll-op and monolithic-dll-op")
#+ecl (trace c::builder)
(DBG "Test the pre-compiled system feature")
(require 'sockets)
(progn
......@@ -68,8 +67,7 @@
(let* (#+(and mkcl os-windows) (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/dll-user)))
(DBG "Test that the DLL works")
(assert-equal (test-package::sample-function) 42)
(assert-equal (sample-function) 42)
(DBG "Create a DLL via monolithic-dll-op")
(nest
#+(and mkcl os-windows)
......@@ -82,6 +80,6 @@
(si:load-foreign-module dll)
(let* (#+(and mkcl os-windows) (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/monodll-user)))
(assert-equal (test-package::always-42) 42))
(assert-equal (always-42) 42))
;;; TODO: test prebuilt-system.
......@@ -108,7 +108,7 @@
(DBG "Checking that the bootstrap script and asdf.asd are in synch")
(defun system-lisp-files (system)
(loop :for f :in (input-files 'concatenate-source-op system)
:collect (enough-pathname f *asdf-directory*)))
:collect (unix-namestring (enough-pathname f *asdf-directory*))))
(DBG "Testing that the Makefile and ASDF agree on the order of UIOP files")
(loop
......
......@@ -19,22 +19,23 @@
(clear-caches-and-search)
(assert (not (asdf:find-system "test-asdf/force1" nil)))
(DBG "Correctly failed to find system.")
(defvar *attempts* 0)
(assert
(let (tried-once)
(with-asdf-cache (:override t)
(handler-bind
((asdf:missing-component
#'(lambda (c)
(DBG "Caught MISSING-COMPONENT condition.")
(if (not tried-once)
(let ((missing (asdf::missing-requires c)))
(assert (equal missing "test-asdf/force1"))
(setf tried-once t)
(setf asdf:*central-registry* *old-registry*)
(invoke-restart 'asdf:retry))
;; avoid infinite looping
(error c)))))
(asdf:find-system "test-asdf/force1" t)))))
(with-asdf-cache (:override t)
(handler-bind
((asdf:missing-component
#'(lambda (c)
(DBG "Caught MISSING-COMPONENT condition (A)." *attempts*)
(if (zerop *attempts*)
(let ((missing (asdf::missing-requires c)))
(incf *attempts*)
(assert (equal missing "test-asdf/force1"))
(setf asdf:*central-registry* *old-registry*)
(invoke-restart 'asdf:retry))
;; avoid infinite looping
(leave-test 10 "Infinite loop while catching MISSING-COMPONENT")))))
(asdf:find-system "test-asdf/force1" t))))
(assert-equal *attempts* 1)
(DBG "Refinding test successful.")
......@@ -48,36 +49,37 @@
;; (trace find-component)
;; (trace asdf::component-find-path)
;; (trace operate)
(let (tried-once)
(with-asdf-cache (:override t)
(flet ((handle-missing (c)
(if (not tried-once)
(let ((missing (asdf::missing-requires c)))
(assert (equal missing "test-asdf/force1"))
(setf tried-once t)
(DBG "Trying to reset the central registry and retry.")
(setf asdf:*central-registry* *old-registry*)
(unless (find-restart 'asdf:clear-configuration-and-retry)
(error "Expected CLEAR-CONFIGURATION-AND-RETRY restart not found."))
(DBG "Before invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*)
(invoke-restart 'asdf:clear-configuration-and-retry)
(DBG "After invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*))
;; avoid infinite looping
(error c))))
(handler-bind
((asdf:missing-dependency-of-version
#'(lambda (c)
;; Nothing Quicklisp can do to recover from this, so
;; just resignal
(error c)))
(asdf:missing-dependency
#'(lambda (c)
(DBG "Catching MISSING-DEPENDENCY condition:" tried-once)
(handle-missing c)))
(asdf:missing-component
#'(lambda (c)
(DBG "Catching MISSING-COMPONENT condition:" tried-once)
(handle-missing c))))
(asdf:load-system "test-missing-dependency")))))
(setf *attempts* 0)
(with-asdf-cache (:override t)
(flet ((handle-missing (c)
(if (zerop *attempts*)
(let ((missing (asdf::missing-requires c)))
(incf *attempts*)
(assert (equal missing "test-asdf/force1"))
(DBG "Trying to reset the central registry and retry.")
(setf asdf:*central-registry* *old-registry*)
(unless (find-restart 'asdf:clear-configuration-and-retry)
(error "Expected CLEAR-CONFIGURATION-AND-RETRY restart not found."))
(DBG "Before invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*)
(invoke-restart 'asdf:clear-configuration-and-retry)
(DBG "After invoking restart, CENTRAL-REGISTRY is:"
asdf:*central-registry*))
;; avoid infinite looping
(leave-test 11 "Infinite loop while catching MISSING-COMPONENT"))))
(handler-bind
((asdf:missing-dependency-of-version
#'(lambda (c)
;; Nothing Quicklisp can do to recover from this, so
;; just resignal
(error c)))
(asdf:missing-dependency
#'(lambda (c)
(DBG "Catching MISSING-DEPENDENCY condition (B):" *attempts*)
(handle-missing c)))
(asdf:missing-component
#'(lambda (c)
(DBG "Catching MISSING-COMPONENT condition (C):" *attempts*)
(handle-missing c))))
(asdf:load-system "test-missing-dependency"))))
(assert-equal *attempts* 1)
......@@ -6,51 +6,51 @@
(defparameter foo :test-asdf-location-change)
(with-expected-failure (#+ecl (not (asdf:version-satisfies (lisp-implementation-version) "16"))
#-ecl nil)
(DBG "load foo. Should load from xach-foo-1/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-1/")))
(defparameter foo1 (find-system foo))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file foo1))
(assert-equal (mapcar 'component-name (component-children foo1)) '("a"))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-1/a.lisp")
(component-pathname (find-component foo1 "a")))
(assert-equal nil (find-component foo1 "b"))
(load-system foo)
(defparameter loaded (find-symbol* :loaded :first-version))
(assert-equal (symbol-value loaded) t)
#+ecl (unless (version-satisfies (lisp-implementation-version) "16")
(leave-test "ECL only supports this test starting with 16.0.0" 0))
(DBG "load foo again. Should not do anything -- already loaded")
(setf (symbol-value loaded) :test-that-we-dont-reload)
(load-system foo)
(assert-equal (symbol-value loaded) :test-that-we-dont-reload)
(assert (not (find-package :second-version)))
(DBG "load foo. Should load from xach-foo-1/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-1/")))
(defparameter foo1 (find-system foo))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file foo1))
(assert-equal (mapcar 'component-name (component-children foo1)) '("a"))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-1/a.lisp")
(component-pathname (find-component foo1 "a")))
(assert-equal nil (find-component foo1 "b"))
(load-system foo)
(defparameter loaded (find-symbol* :loaded :first-version))
(assert-equal (symbol-value loaded) t)
(DBG "Now, change registry so foo is found from xach-foo-2/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-2/")))
(defparameter foo2 (find-system foo))
(assert (eq foo1 foo2)) ;; the object should be the same
(assert-equal (mapcar 'component-name (component-children foo2)) '("a" "b"))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/test-asdf-location-change.asd")
(system-source-file foo2))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/a.lisp")
(component-pathname (find-component foo2 "a")))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/b.lisp")
(component-pathname (find-component foo2 "b")))
(DBG "load foo yet again. It should see the pathname has changed and load it anew")
;;; ECL bug: this fails if we use load-bundle-op instead of load-op as *load-system-operation*
;;; in bundle.lisp. The test-asdf-location-change.fasb is linked and loaded, but that fails to
;;; create the :second-version package; loading the same .fasb in another ecl works fine, and
;;; defines (second-version:wtf). WTF? You can test this bug by uncommenting the
;;; (setf asdf::*load-system-operation* 'load-bundle-op) line at the beginning of this file.
;;; NB: works on MKCL.
(load-system foo)
(assert (symbol-value (find-symbol* :loaded :second-version)))
(assert-equal 42 (symbol-call :second-version :wtf))
)
(DBG "load foo again. Should not do anything -- already loaded")
(setf (symbol-value loaded) :test-that-we-dont-reload)
(load-system foo)
(assert-equal (symbol-value loaded) :test-that-we-dont-reload)
(assert (not (find-package :second-version)))
(DBG "Now, change registry so foo is found from xach-foo-2/")
(setf *central-registry* (list (subpathname *test-directory* "xach-foo-2/")))
(defparameter foo2 (find-system foo))
(assert (eq foo1 foo2)) ;; the object should be the same
(assert-equal (mapcar 'component-name (component-children foo2)) '("a" "b"))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/test-asdf-location-change.asd")
(system-source-file foo2))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/a.lisp")
(component-pathname (find-component foo2 "a")))
(assert-pathname-equal
(subpathname *test-directory* "xach-foo-2/b.lisp")
(component-pathname (find-component foo2 "b")))
(DBG "load foo yet again. It should see the pathname has changed and load it anew")
;;; ECL bug: this fails if we use load-bundle-op instead of load-op as *load-system-operation*
;;; in bundle.lisp. The test-asdf-location-change.fasb is linked and loaded, but that fails to
;;; create the :second-version package; loading the same .fasb in another ecl works fine, and
;;; defines (second-version:wtf). WTF? You can test this bug by uncommenting the
;;; (setf asdf::*load-system-operation* 'load-bundle-op) line at the beginning of this file.
;;; NB: works on MKCL.
(load-system foo)
(assert (symbol-value (find-symbol* :loaded :second-version)))
(assert-equal 42 (symbol-call :second-version :wtf))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment