diff --git a/Makefile b/Makefile index 15afc71095c058abeb48dce4c67bfb5e44d58faf..34c9d4c4c36f6534295c7bae613991df0a607948 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/action.lisp b/action.lisp index 0c8e6b0c258a2eadee5f6104623aa4a17b026a8e..0a713673e27284f9f10b7bf061be46953bb90296 100644 --- a/action.lisp +++ b/action.lisp @@ -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 diff --git a/asdf.asd b/asdf.asd index 0ab8794f04830d5ca9367bf8a39780dc1299ee1b..35971664286c4a9794894e33fa4f09a1697888d5 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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" diff --git a/backward-driver.lisp b/backward-driver.lisp index 1f15aab678d7efda17887bf56bb84c3dd163a25b..2a81121aad952de3f5b0dae7d459bde95390b315 100644 --- a/backward-driver.lisp +++ b/backward-driver.lisp @@ -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)) diff --git a/bundle.lisp b/bundle.lisp index d70ecda3dc89836205c76eefe9de8bdcd4a08c9d..b0af6ba587dff89cef05a8bbaf31935869a9414f 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -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 diff --git a/component.lisp b/component.lisp index ae051e2fa526aecae0a35b9865d87a0f287ff66d..fcecc0ac1ffbb72750d9c42ba1c7bc318316229e 100644 --- a/component.lisp +++ b/component.lisp @@ -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))) diff --git a/concatenate-source.lisp b/concatenate-source.lisp index e64e62e765b219d69fdb41db384553b458723792..c70bf25ad7f34c891c6259457cb02bb0e0b0880d 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -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)) diff --git a/configuration.lisp b/configuration.lisp index c42e49305e936f6189a9d5254b399545c05744c0..010ab089c12cbb246096b10af2a9a99ce4c8666a 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -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)))) diff --git a/defsystem.lisp b/defsystem.lisp index a8adade0cf01f16acdbba0bc2bd53b084f78822c..4064947b7e19e381c38d586bf942a15c1646ce7a 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -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*)) diff --git a/find-component.lisp b/find-component.lisp index 085f7a79d6dedf0d43871266beea26e9f00adee8..7ea2411a04d4dded99822fa013c5792ec9fb8246 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -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~@:>") diff --git a/find-system.lisp b/find-system.lisp index 5d3e7a3c001da498b221d7f4169c18d1632930d9..016c6e385f6abbe224a421da6280c43333657c8e 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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)))))) diff --git a/header.lisp b/header.lisp index 02586794224c6ccf6e01bb2df53c29ad2faab73e..05bc6b652351e94a6b993f2f3578776358020fe5 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- 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>. diff --git a/interface.lisp b/interface.lisp index d379a8a048f96336ee1c1941d83d67e7b1e6d93f..4a5d50a1b32611491e8504dbdb196eb5aa7044e7 100644 --- a/interface.lisp +++ b/interface.lisp @@ -146,3 +146,4 @@ #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory)) + diff --git a/lisp-action.lisp b/lisp-action.lisp index cfc65a865022e783b459d8f44cec0169af0efa0f..30d7e6168e0b976b81f4a6f2f6879d474a3d963b 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -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)) diff --git a/lisp-build.lisp b/lisp-build.lisp index 68bc01b4ecf4afe49bbfd7773230955a65f8b845..93e23a4270a929bce7819dea37c4821391baad16 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -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) diff --git a/operate.lisp b/operate.lisp index bc7efb8614099ec463e48155a77ec64e919867da..50f0c1bb8a1fa93b0c3926e5d1aafc02a99fb08d 100644 --- a/operate.lisp +++ b/operate.lisp @@ -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)) diff --git a/operation.lisp b/operation.lisp index fafd1abb2dd24a9f33c094a81a85f887e4afd222..6331f780e4e5bf2ac16bd4e6bbc8465905e84b17 100644 --- a/operation.lisp +++ b/operation.lisp @@ -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) ()) diff --git a/os.lisp b/os.lisp index 8551fac4a38a60ed6caaead49714544450479c83..20dd04f2eca6c7be23950c1381e5e63e968e5f68 100644 --- a/os.lisp +++ b/os.lisp @@ -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/)) diff --git a/package.lisp b/package.lisp index d07eb9bac38891a6e6393e0be1310b59747ea757..3874cd468dacec4682f0e4a77d0aa4ec53665312 100644 --- a/package.lisp +++ b/package.lisp @@ -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 diff --git a/pathname.lisp b/pathname.lisp index 7fa73390d38ab46cce72898213f637223b47a28e..c138bbbb9825a0ae439767676c490b0273518f1a 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -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) diff --git a/plan.lisp b/plan.lisp index 62f67e05f34b951da2a1a09eb191c0d87b35461c..73eb951f1bff4af4d2ba6ff5083dabbe3cacebde 100644 --- a/plan.lisp +++ b/plan.lisp @@ -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) + (visiting-action-list :initform () :accessor plan-visiting-action-list))) + + ;;;; Planned action status (defgeneric* plan-action-status (plan operation component) @@ -53,6 +68,10 @@ the action of OPERATION on COMPONENT in the PLAN")) (with-slots (stamp done-p planned-p) status (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p)))) +(defmethod action-planned-p (action-status) + (declare (ignorable action-status)) ; default method for non planned-action-status objects + t) + ;; TODO: eliminate NODE-FOR, use CONS. ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. ;; However, see also component-operation-time and mark-operation-done @@ -96,14 +115,26 @@ the action of OPERATION on COMPONENT in the PLAN")) t)))) (defmethod action-forced-p (plan operation component) - (and (action-override-p plan operation component 'plan-forced) - (not (builtin-system-p (component-system component))))) + (and + ;; Did the user ask us to re-perform the action? + (action-override-p plan operation component 'plan-forced) + ;; You really can't force a builtin system and :all doesn't apply to it, + ;; except it it's the specifically the system currently being built. + (not (let ((system (component-system component))) + (and (builtin-system-p system) + (not (eq system (plan-system plan)))))))) + (defmethod action-forced-not-p (plan operation component) - (and (action-override-p plan operation component 'plan-forced-not) - (not (action-forced-p plan operation component)))) + (and + ;; Did the user ask us to not re-perform the action? + (action-override-p plan operation component 'plan-forced-not) + ;; Force takes precedence over force-not + (not (action-forced-p plan operation component)))) + (defmethod action-forced-p ((plan null) operation component) (declare (ignorable plan operation component)) nil) + (defmethod action-forced-not-p ((plan null) operation component) (declare (ignorable plan operation component)) nil) @@ -223,16 +254,6 @@ the action of OPERATION on COMPONENT in the PLAN")) (defgeneric call-while-visiting-action (plan operation component function) (:documentation "Detect circular dependencies")) -(defclass plan-traversal () - ((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) - (visiting-action-list :initform () :accessor plan-visiting-action-list))) - (defmethod initialize-instance :after ((plan plan-traversal) &key (force () fp) (force-not () fnp) system &allow-other-keys) @@ -336,7 +357,7 @@ the action of OPERATION on COMPONENT in the PLAN")) ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p -(defgeneric* traverse (operation component &key &allow-other-keys) +(defgeneric* (traverse) (operation component &key &allow-other-keys) (:documentation "Generate and return a plan for performing OPERATION on COMPONENT. @@ -378,9 +399,9 @@ processed in order by OPERATE.")) (defmethod initialize-instance :after ((plan filtered-sequential-plan) &key (force () fp) (force-not () fnp) - system other-systems) + other-systems) (declare (ignore force force-not)) - (with-slots (forced forced-not action-filter) plan + (with-slots (forced forced-not action-filter system) plan (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system))) (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system))) (setf action-filter (ensure-function action-filter)))) diff --git a/source-registry.lisp b/source-registry.lisp index 09e8b9268f4c183feab8c92ffde7e0f0ada918bf..3e4dfd0b1a254af34c4363678c98eeda33832d48 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -287,9 +287,6 @@ system names to pathnames of .asd files") (defvar *source-registry-parameter* nil) (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) - ;; In case we haven't upgraded ASDF yet, and it appears in the registry, - ;; clear the upgrade attempt flag: - (setf *asdf-upgrade-already-attempted* (not *upgraded-p*)) ;; Record the parameter used to configure the registry (setf *source-registry-parameter* parameter) ;; Clear the previous registry database: diff --git a/system.lisp b/system.lisp index ffe3cafe78c0f2bcde6f66d2015a646e3beade5e..aa0e0d63d42205db6387a6071cd7fe8d0c7494e7 100644 --- a/system.lisp +++ b/system.lisp @@ -9,16 +9,17 @@ (:export #:system #:proto-system #:system-source-file #:system-source-directory #:system-relative-pathname - #:reset-system #:builtin-system-p + #:reset-system #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license - #:find-system ;; forward-reference, defined in find-system - #:system-defsystem-depends-on)) + #:system-defsystem-depends-on + #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) (defgeneric* find-system (system &optional error-p)) (defgeneric* system-source-file (system) (:documentation "Return the source file in which system is defined.")) +(defgeneric* builtin-system-p (system)) ;;;; The system class @@ -76,14 +77,3 @@ in which the system specification (.asd file) is located." (system-source-directory system)) -;;;; Beware of builtin systems -(defgeneric* builtin-system-p (system)) -(defmethod builtin-system-p ((s system)) - (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))))) diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index e0d71ff81705f306e6cb08427d99865e8155b850..8d06d5e93620269dd9dcc8ba6a0ee2db9664fb2d 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (in-package :asdf-test) (load-asdf) @@ -313,7 +313,7 @@ (setf (logical-pathname-translations "ASDFTEST") nil)) (remhash "test-system" asdf::*defined-systems*))) -(with-test () +(progn (asdf:initialize-source-registry) (format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*)) (asdf:initialize-output-translations) diff --git a/test/run-shell-command-test.script b/test/run-shell-command-test.script index df0e0b902cb4ef4625665c75c0719130f76c4027..2c7ffa25f27b0fe02696590f11565f783b110132 100644 --- a/test/run-shell-command-test.script +++ b/test/run-shell-command-test.script @@ -1,12 +1,12 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) ;;; TODO: write tests for run-program/ instead -- and/or ;;; import those from the original xcvb-driver-test ;;; test asdf run-shell-command function -(with-test () +(progn (when (asdf::os-unix-p) (setf asdf::*verbose-out* nil) (assert-equal 1 (asdf:run-shell-command "false")) diff --git a/test/run-tests.sh b/test/run-tests.sh index 3463d2abfe00a7547308bfe8fcf70804e7c4a635..cef03a6b01078e09d2e7e0e4f3d491d4871ef7de 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -47,23 +47,38 @@ if [ x"$1" = "xhelp" ]; then fi lisp=${1:-sbcl} ; shift -if [ -z "$*" ]; then - scripts="*.script" -else - scripts="$*" -fi -sok=1 - -DO () { ( set -x ; "$@" ); } +ECHO () { printf '%s\n' "$*" ;} +ECHOn () { printf '%s' "$*" ;} +DBG () { ECHO "$*" >& 2 ;} +simple_term_p () { + case "$1" in *[!a-zA-Z0-9-+_,.:=%/]*) return 1 ;; *) return 0 ;; esac +} +kwote0 () { ECHOn "$1" | sed -e "s/\([\\\\\"\$\`]\)/\\\\\\1/g" ;} +kwote1 () { if simple_term_p "$1" ; then ECHOn "$1" + else ECHOn "\"$(kwote0 "$1")\"" ; fi ;} +kwote () { ( set +x + k="" ; for i ; do ECHOn "$k" ; kwote1 "$i" ; k=" " ; done ; echo +) } +DO () { kwote "$@" ; "$@" ; } do_tests() { - command="$1" eval="$2" + if [ -z "$*" ]; then + scripts="*.script" + else + scripts="$*" + fi env | grep -i asdf rm -f ~/.cache/common-lisp/"`pwd`"/* || true - ( cd .. && DO $command $eval '(or #.(load "test/script-support.lisp") #.(asdf-test::compile-asdf-script))' ) + ( cd .. && DO $cmd $debugp $eval '(or #.(load "test/script-support.lisp") #.(asdf-test::compile-asdf-script))' ) if [ $? -ne 0 ] ; then echo "Compilation FAILED" >&2 + echo "you can retry compilation with:" >&2 + echo ./test/run-tests.sh $lisp >&2 + echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 + echo "$cmd" >&2 + echo "then copy/paste:" >&2 + echo '(load "test/script-support.lisp") (asdf-test::compile-asdf-script)' >&2 else echo "Compiled OK" >&2 test_count=0 @@ -75,14 +90,19 @@ do_tests() { echo "Testing: $i" >&2 test_count=`expr "$test_count" + 1` rm -f ~/.cache/common-lisp/"`pwd`"/* || true - if DO $command $eval "(load \"$i\")" ; then + if DO $cmd $debugp $eval "(load \"script-support.lisp\")" $eval "(asdf-test::with-test () (load \"$i\"))" ; then echo "Using $command, $i passed" >&2 test_pass=`expr "$test_pass" + 1` else echo "Using $command, $i failed" >&2 test_fail=`expr "$test_fail" + 1` failed_list="$failed_list $i" - sok=0 + echo "you can retry compilation with:" >&2 + echo ./test/run-tests.sh $lisp $i >&2 + echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 + echo "(cd test ; $cmd )" >&2 + echo "then copy/paste:" >&2 + echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(asdf-test::with-test () (load \"$i\")))" >&2 fi echo >&2 echo >&2 @@ -200,10 +220,10 @@ ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)" export CL_SOURCE_REGISTRY="${ASDFDIR}" export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)" - cmd="$command $flags" +debugp= if [ -z "${DEBUG_ASDF_TEST}" ] ; then - cmd="$cmd $nodebug" + debugp="$nodebug" fi @@ -282,13 +302,13 @@ run_upgrade_tests () { if valid_upgrade_test_p $lisp $tag $method ; then echo "Testing ASDF upgrade from ${tag} using method $method" extract_tagged_asdf $tag - $cmd $eval \ + $cmd $debugp $eval \ "'(#.(load\"$su\")#.(in-package :asdf-test)#.(test-upgrade $method \"$tag\"))" || { echo "upgrade FAILED for $lisp from $tag using method $method" ; echo "you can retry just that test with:" ; echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ADSF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ; echo "or more interactively (and maybe with rlwrap or in emacs), start with:" - echo "$command" + echo "$cmd" echo "then copy/paste:" echo "(load\"$su\") (da) (test-upgrade $method \"$tag\")" exit 1 ;} @@ -300,7 +320,7 @@ run_tests () { mkdir -p ../build/results echo failure > ../build/results/status thedate=`date "+%Y-%m-%d"` - do_tests "$cmd" "$eval" 2>&1 | \ + do_tests "$@" 2>&1 | \ tee "../build/results/${lisp}.text" "../build/results/${lisp}-${thedate}.save" read a < ../build/results/status clean_up @@ -341,5 +361,5 @@ elif [ -n "$clean_load" ] ; then elif [ -n "$upgrade" ] ; then run_upgrade_tests else - run_tests + run_tests "$@" fi diff --git a/test/script-support.lisp b/test/script-support.lisp index e2cf8ea970791a101759c1814dabab4d75a99eac..2fe0e5f74dea1ec8056e21c754f09eb8c8621f53 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -23,6 +23,7 @@ Some constraints: #:assert-compare #:assert-equal #:leave-test #:def-test-system + #:test-source #:test-fasl #:resolve-output #:output-location #:quietly)) (in-package :asdf-test) @@ -36,15 +37,16 @@ Some constraints: `(;; If you want to trace some stuff while debugging ASDF, ;; here's a nice place to say what. ;; These string designators will be interned in ASDF after it is loaded. + + ;;#+ecl ,@'( :perform :input-files :output-files :compile-file* :compile-file-pathname* :load*) )) (defvar *debug-asdf* nil) (defvar *quit-when-done* t) -(defun verbose (&optional (verbose t)) - (loop :for v :in '(*load-verbose* *compile-verbose* - *load-print* *compile-print*) - :do (setf (symbol-value v) verbose))) +(defun verbose (&optional (verbose t) (print verbose)) + (setf *load-verbose* verbose *compile-verbose* verbose) + (setf *load-print* print *compile-print* print)) (verbose nil) @@ -142,6 +144,7 @@ Some constraints: ;;; Test helper functions (load (debug-lisp)) +(verbose t nil) (defmacro assert-compare (expr) (destructuring-bind (op x y) expr @@ -169,7 +172,6 @@ Some constraints: (loop :for key :being :the :hash-keys :of table :using (:hash-value value) :collect (cons key value))) - (defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit (finish-outputs*) #+(or abcl xcl) (ext:quit :status code) @@ -351,6 +353,7 @@ is bound, write a message and exit on an error. If (defun test-upgrade (old-method new-method tag) ;; called by run-test (with-test () + #+clisp (trace compile-file load) (when old-method (cond ((string-equal tag "REQUIRE") @@ -369,6 +372,20 @@ is bound, write a message and exit on an error. If (assert (eval (intern (symbol-name '#:*file1*) :test-package))) (assert (eval (intern (symbol-name '#:*file3*) :test-package))))) +(defun output-location (&rest sublocation) + (list* *asdf-directory* "build/fasls" :implementation sublocation)) +(defun resolve-output (&rest sublocation) + (acall :resolve-location (apply 'output-location sublocation))) + +(defun test-source (file) + (acall :subpathname *test-directory* file)) +(defun test-output-dir () + (resolve-output "asdf" "test")) +(defun test-output (file) + (acall :subpathname (test-output-dir) file)) +(defun test-fasl (file) + (acall :compile-file-pathname* (test-source file))) + (defun configure-asdf () (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))) (untrace) @@ -377,8 +394,8 @@ is bound, write a message and exit on an error. If `(:source-registry :ignore-inherited-configuration)) (acall :initialize-output-translations `(:output-translations - ((,*asdf-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "asdf")) - (t (,*asdf-directory* "build/fasls" :implementation "root")) + ((,*asdf-directory* :**/ :*.*.*) ,(output-location "asdf")) + (t ,(output-location "root")) :ignore-inherited-configuration)) (set (asym :*central-registry*) `(,*test-directory*)) (set (asym :*verbose-out*) *standard-output*) @@ -420,5 +437,4 @@ is bound, write a message and exit on an error. If It depends on the DBG macro in contrib/debug.lisp, that you should load in your asdf/plan by inserting an (asdf-debug) form in it. -#+DBG-ASDF (DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)) -|# +#+DBG-ASDF (DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))|# diff --git a/test/test-around-compile.script b/test/test-around-compile.script index 729b254f71ceb8c81206f018eb2f8998e3d1c023..299c12fc0d227552b7678006ada8880fff7fab0e 100644 --- a/test/test-around-compile.script +++ b/test/test-around-compile.script @@ -1,12 +1,12 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (defun call-in-base-2 (thunk) (let ((*read-base* 2)) (funcall thunk))) -(with-test () +(progn (def-test-system test-around-compile :around-compile call-in-base-2 ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. diff --git a/test/test-asdf.asd b/test/test-asdf.asd index 6abd8e6c3271641c32f9cec7b961f3f99da05108..3826d362486d0ae1060ea24f4d352bcaf2ef4eb8 100644 --- a/test/test-asdf.asd +++ b/test/test-asdf.asd @@ -1,7 +1,10 @@ (defpackage :test-asdf-system - (:use :cl :asdf :asdf/driver)) + (:use :cl :asdf)) (in-package :test-asdf-system) +(defsystem :test-asdf + :components ()) + (defsystem :test-asdf/test9-1 :version "1.1" :components ((:file "file2")) diff --git a/test/test-builtin-source-file-type.script b/test/test-builtin-source-file-type.script index 30d9f4c4534671aa332ab275cf4ead5a3fa3c1be..21536a4066253fe10efd9caa9f76f30f5fd89aee 100644 --- a/test/test-builtin-source-file-type.script +++ b/test/test-builtin-source-file-type.script @@ -1,10 +1,10 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) ;;(trace source-file-type) -(with-test () +(progn (format t "~D~%" (asdf:asdf-version)) (def-test-system test-builtin-source-file-type-1 diff --git a/test/test-bundle.script b/test/test-bundle.script index db0d352a89bb755c657c0e46abef91d5e044b446..a23144f320627160b018a2513f61ea64d0b0902f 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -1,35 +1,34 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) +(in-package :asdf-test) ;;;--------------------------------------------------------------------------- ;;; Check to see if the bundle functionality is doing something. ;;;--------------------------------------------------------------------------- -(with-test () - (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) - (asdf:clear-system :test-bundle-1) - (asdf:clear-system :test-bundle-2) - (when (find-package :test-package) (delete-package :test-package)) - (eval `(def-test-system :test-bundle-1 - :pathname ,*test-directory* - :components ((:file "file1") (:file "file3")))) - (eval `(def-test-system :test-bundle-2 - :pathname ,*test-directory* - :depends-on (:test-bundle-1) :components ((:file "file2")))) - #-(or abcl (and ecl ecl-bytecmp) gcl) - (let* ((op (make-instance 'asdf::fasl-op)) - (bundle-1 (asdf:output-file op (find-system :test-bundle-1))) - (bundle-2 (asdf:output-file op (find-system :test-bundle-2)))) - (DBG :test-bundle bundle-1 bundle-2) - (assert-equal (list bundle-2) - (input-files (make-operation 'load-fasl-op) (find-system :test-bundle-2))) - (delete-file-if-exists bundle-1) - (delete-file-if-exists bundle-2) - (operate 'load-fasl-op :test-bundle-2) - ;; Check that the bundles were indeed created. - (assert (probe-file bundle-2)) - (assert (probe-file bundle-1)) - ;; Check that the files were indeed loaded. - (assert (symbol-value (find-symbol* :*file1* :test-package))) - (assert (symbol-value (find-symbol* :*file3* :test-package))))) +(asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) +(asdf:clear-system :test-bundle-1) +(asdf:clear-system :test-bundle-2) +(when (find-package :test-package) (delete-package :test-package)) +(def-test-system :test-bundle-1 + :components ((:file "file1") (:file "file3"))) +(def-test-system :test-bundle-2 + :depends-on (:test-bundle-1) :components ((:file "file2"))) +#+(or abcl (and ecl ecl-bytecmp) gcl) +(leave-test "bundles not on this implementation" 0) + +(defparameter *bundle-1* (output-file 'fasl-op :test-bundle-1)) +(defparameter *bundle-2* (output-file 'fasl-op :test-bundle-2)) +(DBG :test-bundle *bundle-1* *bundle-2*) +(assert-equal (list *bundle-2*) + (input-files 'load-fasl-op :test-bundle-2)) +(delete-file-if-exists *bundle-1*) +(delete-file-if-exists *bundle-2*) +(operate 'load-fasl-op :test-bundle-2) +;; Check that the bundles were indeed created. +(assert (probe-file *bundle-2*)) +(assert (probe-file *bundle-1*)) +;; Check that the files were indeed loaded. +(assert (symbol-value (find-symbol* :*file1* :test-package))) +(assert (symbol-value (find-symbol* :*file3* :test-package))) diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script index 6ddf8c3d0b55f66835a1a5a4b48a8b03af95df5f..e3b7ca557d3ed8bcbba78d4c46d0f8366e0dc03f 100644 --- a/test/test-compile-file-failure.script +++ b/test/test-compile-file-failure.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn #-gcl<2.7 (assert (handler-case (let ((asdf:*compile-file-failure-behaviour* :warn)) diff --git a/test/test-concatenate-source.script b/test/test-concatenate-source.script index 0e5e91c38c232680c2c7011077b11ccaea4b71e9..b096bdbb9b72b4477caa14a41d3f10b89c4edea5 100644 --- a/test/test-concatenate-source.script +++ b/test/test-concatenate-source.script @@ -1,40 +1,37 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () - (def-test-system :test-concatenate-source - :depends-on (:file3-only) - :components - ((:file "file2" :depends-on ("foo")) - (:module "foo" :pathname "" - :components ((:file "file1") - (:file "file4" :if-feature (:not :common-lisp)))))) - (let ((mcso (make-operation 'monolithic-concatenate-source-op)) - (mccso (make-operation 'monolithic-compile-concatenated-source-op)) - (mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op)) - (sys (find-system :test-concatenate-source))) - (assert (operation-monolithic-p mcso)) - (assert-equal ;; on CLISP, we get un-equal pathnames with same namestrings. Sigh. - (princ-to-string (input-files mcso sys)) - (princ-to-string (loop :for n :in '(3 1 2) - :collect (subpathname *test-directory* (format nil "file~D.lisp" n))))) - (assert-equal - (output-file mcso sys) - (apply-output-translations - (subpathname *test-directory* - "test-concatenate-source.all-systems.lisp"))) - (assert-equal - (output-files mcso sys) - (input-files mccso sys)) - (assert-equal ;; on ECL, we get un-equal pathnames. - (princ-to-string (output-file mccso sys)) - (princ-to-string (apply-output-translations - (compile-file-pathname - (subpathname *test-directory* - "test-concatenate-source.all-systems.lisp"))))) - (assert-equal - (output-files mccso sys) - (input-files mlccso sys)) - (operate 'monolithic-load-compiled-concatenated-source-op sys) - (assert (symbol-value (find-symbol* :*file3* :test-package))))) +(def-test-system :test-concatenate-source + :depends-on (:file3-only) + :components + ((:file "file2" :depends-on ("foo")) + (:module "foo" :pathname "" + :components ((:file "file1") + (:file "file4" :if-feature (:not :common-lisp)))))) + +(defparameter mcso (make-operation 'monolithic-concatenate-source-op)) +(defparameter mccso (make-operation 'monolithic-compile-concatenated-source-op)) +(defparameter mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op)) +(defparameter sys (find-system :test-concatenate-source)) +(assert (operation-monolithic-p mcso)) +(assert-equal ;; on CLISP, we get un-equal pathnames with same namestrings. Sigh. + (princ-to-string (input-files mcso sys)) + (princ-to-string (loop :for n :in '(3 1 2) + :collect (test-source (format nil "file~D.lisp" n))))) +(assert-equal + (output-file mcso sys) + (apply-output-translations + (subpathname *test-directory* + "test-concatenate-source.all-systems.lisp"))) +(assert-equal + (output-files mcso sys) + (input-files mccso sys)) +(assert-equal ;; on ECL, we get un-equal pathnames. + (princ-to-string (output-file mccso sys)) + (princ-to-string (test-fasl "test-concatenate-source.all-systems.lisp"))) +(assert-equal + (output-files mccso sys) + (input-files mlccso sys)) +(operate 'monolithic-load-compiled-concatenated-source-op sys) +(assert (symbol-value (find-symbol* :*file3* :test-package))) diff --git a/test/test-configuration.script b/test/test-configuration.script index 6b0f7f8c04500fbdb5171808462ce77996d609ee..a7342b19b0d2ae7b1b00a26c75eaf9825ae18268 100644 --- a/test/test-configuration.script +++ b/test/test-configuration.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (in-package :asdf) @@ -63,7 +63,7 @@ :if-does-not-exist :create) (format s "(defsystem :foo~D)~%" i)))) -(with-test () +(progn (assert-equal (asdf::parse-output-translations-string "/foo:/bar::/baz:/quux") '(:output-translations ("/foo" "/bar") :inherit-configuration ("/baz" "/quux"))) diff --git a/test/test-encodings.script b/test/test-encodings.script index 3305c636eb0441dc4308e1d689ca632b60904ce0..d4f37b24da045265ecb5dd09c80124b17c26a1b7 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (defparameter *lambda-string* nil) @@ -37,7 +37,7 @@ (eval `(assert-equal (string-char-codes ,*lambda-string*) (expected-char-codes ',',encoding)))))) -(with-test () +(progn (with-encoding-test (:utf-8) (def-test-system :test-encoding-explicit-u8 diff --git a/test/test-force.script b/test/test-force.script index 52fc9035ee017664d1678cdf07dbbb55f2ee44a6..584896f2c454973f087d8de7638f7df7cf089ef2 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -1,25 +1,24 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () - (asdf:operate 'asdf:load-op 'test-force) +(asdf:operate 'asdf:load-op 'test-force) - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file1-date (file-write-date file1)) - (date1 (- file1-date 600)) - (date2 (- file1-date 300))) +(defparameter file1 (test-fasl "file1")) +(defparameter file1-date (file-write-date file1)) +(defparameter date1 (- file1-date 600)) +(defparameter date2 (- file1-date 300)) - (assert file1) - (assert file1-date) +(assert file1) +(assert file1-date) - ;; unforced, date should stay same - (touch-file "test-force.asd" :timestamp date1) - (touch-file "file1.lisp" :timestamp date1) - (touch-file file1 :timestamp date2) - (asdf:operate 'asdf:load-op 'test-force) - (assert (equal (file-write-date file1) date2)) +;; unforced, date should stay same +(touch-file "test-force.asd" :timestamp date1) +(touch-file "file1.lisp" :timestamp date1) +(touch-file file1 :timestamp date2) +(asdf:operate 'asdf:load-op 'test-force) +(assert (equal (file-write-date file1) date2)) - ;; forced, it should be later - (asdf:operate 'asdf:load-op 'test-force :force t) - (assert (>= (file-write-date file1) file1-date)))) +;; forced, it should be later +(asdf:operate 'asdf:load-op 'test-force :force t) +(assert (>= (file-write-date file1) file1-date)) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index d9bea363459da8db654e6fc49aafdb25dbdb40de..770417f8c66bdd51ebe410fb10e875881f658004 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) #+clisp @@ -16,7 +16,7 @@ `(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf") :wilden t)))) -(with-test () +(progn #-gcl<2.7 (DBG :logical (logical-pathname-translations "ASDF") diff --git a/test/test-missing-lisp-file.script b/test/test-missing-lisp-file.script index a6b7664844543ee10052fad47a424a142c77b47f..b7154634352fb3417302d5e9bb533bffe1ab56f1 100644 --- a/test/test-missing-lisp-file.script +++ b/test/test-missing-lisp-file.script @@ -6,43 +6,37 @@ ;;; fasl when the source file is lost. ;;;--------------------------------------------------------------------------- -(load "script-support.lisp") + (load-asdf) -(with-test () - (def-test-system test-missing-lisp-file - :components ((:file "file2" :in-order-to ((compile-op (load-op "fileMissing")) - (load-op (load-op "fileMissing")))) - (:file "fileMissing"))) - (let ((missing-name (namestring - (make-pathname :name "fileMissing" - :type "lisp" - :defaults - *test-directory*))) - (template-file (namestring - (make-pathname :name "file1" - :type "lisp" - :defaults - *test-directory*)))) - (asdf::concatenate-files (list template-file) missing-name) - (unless (probe-file missing-name) - (format t "File copy failed.~%")) - (asdf:operate 'asdf:load-op 'test-missing-lisp-file) - ;; test that it compiled - (let* ((file1 (asdf:compile-file-pathname* "file2")) - (file2 (asdf:compile-file-pathname* "fileMissing")) - (file1-date (file-write-date file1))) - - (assert file1-date) - (assert (file-write-date file2)) - - ;; and loaded - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) - - ;; now remove the lisp file we created, and wait for an error - - (asdf::delete-file-if-exists missing-name) - ;; we shouldn't be able to find the input-file for the compile-op, and that - ;; should be an error. - (let ((err (nth-value 1 (ignore-errors (asdf:operate 'asdf:load-op 'test-missing-lisp-file))))) - (assert err))))) + +(def-test-system test-missing-lisp-file + :components ((:file "file2" :in-order-to ((compile-op (load-op "fileMissing")) + (load-op (load-op "fileMissing")))) + (:file "fileMissing"))) + +(defparameter missing-name (test-source "fileMissing.lisp")) +(defparameter template-file (test-source "file1.lisp")) +(concatenate-files (list template-file) missing-name) +(unless (probe-file missing-name) + (format t "File copy failed.~%")) + +(asdf:operate 'asdf:load-op 'test-missing-lisp-file) +;; test that it compiled + +(defparameter file1 (test-fasl "file2")) +(defparameter file2 (test-fasl "fileMissing")) +(defparameter file1-date (file-write-date file1)) + +(assert file1-date) +(assert (file-write-date file2)) + +;; and loaded +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) + +;; now remove the lisp file we created, and wait for an error + +(delete-file-if-exists missing-name) +;; we shouldn't be able to find the input-file for the compile-op, and that +;; should be an error. +(assert (nth-value 1 (ignore-errors (asdf:operate 'asdf:load-op 'test-missing-lisp-file)))) diff --git a/test/test-module-depend.script b/test/test-module-depend.script index 536d4a70405141bfdf87557d57f154656e7e13b7..db7842e84e7d1fcf27a13543a4325484fe2676e1 100644 --- a/test/test-module-depend.script +++ b/test/test-module-depend.script @@ -1,31 +1,30 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () - (asdf:load-system 'test-module-depend) +(asdf:load-system 'test-module-depend) - ;; test that it compiled - (let* ((file1.fasl (asdf:compile-file-pathname* "file1")) - (file2.fasl (asdf:compile-file-pathname* "file2")) - (file3.fasl (asdf:compile-file-pathname* "file3")) - (file1-date (file-write-date file1.fasl)) - (file3-date (file-write-date file3.fasl))) +;; test that it compiled +(defparameter file1.fasl (test-fasl "file1")) +(defparameter file2.fasl (test-fasl "file2")) +(defparameter file3.fasl (test-fasl "file3")) +(defparameter file1-date (file-write-date file1.fasl)) +(defparameter file3-date (file-write-date file3.fasl)) - (assert (and file1-date file3-date)) +(assert (and file1-date file3-date)) - ;; and loaded - (assert (eval (intern (symbol-name '#:*file1*) :test-package))) +;; and loaded +(assert (eval (intern (symbol-name '#:*file1*) :test-package))) - ;; now touch file1 and its fasl so the fasl is out of date, - ;; and check that file2 _is_ also recompiled - ;; this didn't work before the cross-module (intra-system) dependency bug was fixed. +;; now touch file1 and its fasl so the fasl is out of date, +;; and check that file2 _is_ also recompiled +;; this didn't work before the cross-module (intra-system) dependency bug was fixed. - (touch-file "file1.lisp" :timestamp (- file3-date 60)) - (touch-file file1.fasl :timestamp (- file3-date 90)) - (touch-file file2.fasl :timestamp (- file3-date 30)) - (touch-file file3.fasl :timestamp (- file3-date 15)) - (asdf:operate 'asdf:load-op 'test-module-depend) - (assert (>= (file-write-date (asdf:compile-file-pathname* "file2")) file3-date)) - ;; does this properly go to the second level? - (assert (>= (file-write-date (asdf:compile-file-pathname* "file3")) file3-date)))) +(touch-file "file1.lisp" :timestamp (- file3-date 60)) +(touch-file file1.fasl :timestamp (- file3-date 90)) +(touch-file file2.fasl :timestamp (- file3-date 30)) +(touch-file file3.fasl :timestamp (- file3-date 15)) +(asdf:operate 'asdf:load-op 'test-module-depend) +(assert (>= (file-write-date (test-fasl "file2")) file3-date)) +;; does this properly go to the second level? +(assert (>= (file-write-date (test-fasl "file3")) file3-date)) diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script index 96671dea5979e423b31b33fb67f33900d2c2f5e5..704e7d02293731eab54ad3d333b0f86ab329622c 100644 --- a/test/test-module-excessive-depend.script +++ b/test/test-module-excessive-depend.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) ;;;--------------------------------------------------------------------------- @@ -14,75 +14,73 @@ ;;; and reloading of "file2," but /not/ of system Y. ;;;--------------------------------------------------------------------------- -(with-test () - - (def-test-system :test-module-excessive-depend - :components ((:file "file1") - (:module "quux" - :pathname "" - :depends-on ("file1") - :components ((:file "file2"))))) +(def-test-system :test-module-excessive-depend + :components ((:file "file1") + (:module "quux" + :pathname "" + :depends-on ("file1") + :components ((:file "file2"))))) - (defun find-quux () - (find-component :test-module-excessive-depend "quux")) +(defun find-quux () + (find-component :test-module-excessive-depend "quux")) - (defun find-file2 () - (find-component (find-quux) "file2")) +(defun find-file2 () + (find-component (find-quux) "file2")) - (defmethod component-depends-on ((op load-op) - (c (eql (find-file2)))) - (cons `(load-op ,(find-system "file3-only")) - (call-next-method))) +(defmethod component-depends-on ((op load-op) + (c (eql (find-file2)))) + (cons `(load-op ,(find-system "file3-only")) + (call-next-method))) - (defmethod component-depends-on ((op compile-op) - (c (eql (find-file2)))) - (cons `(load-op ,(find-system "file3-only")) - (call-next-method))) +(defmethod component-depends-on ((op compile-op) + (c (eql (find-file2)))) + (cons `(load-op ,(find-system "file3-only")) + (call-next-method))) - (DBG "loading test-module-excessive-depend" - (operate 'load-op 'test-module-excessive-depend)) +(DBG "loading test-module-excessive-depend" + (operate 'load-op 'test-module-excessive-depend)) - ;; test that it compiled - (let* ((file1 (compile-file-pathname* "file1")) - (file2 (compile-file-pathname* "file2")) - (file3 (compile-file-pathname* "file3")) - (file1-date (file-write-date file1)) - (file2-date (file-write-date file2)) - (file3-date (file-write-date file3))) - (unless (and file1-date file2-date file3-date) - (error "Failed to compile one of the three files ~ +;; test that it compiled +(defparameter file1 (test-fasl "file1")) +(defparameter file2 (test-fasl "file2")) +(defparameter file3 (test-fasl "file3")) +(defparameter file1-date (file-write-date file1)) +(defparameter file2-date (file-write-date file2)) +(defparameter file3-date (file-write-date file3)) +(unless (and file1-date file2-date file3-date) + (error "Failed to compile one of the three files ~ that should be compiled for this test: ~{~a~}" - (mapcar #'cdr - (remove-if #'car - (pairlis (list file1-date file2-date file3-date) - '("file1" "file2" "file3")))))) + (mapcar #'cdr + (remove-if #'car + (pairlis (list file1-date file2-date file3-date) + '("file1" "file2" "file3")))))) - ;; and loaded - (assert (eval (asdf::find-symbol* '#:*file1* :test-package))) - (assert (eval (asdf::find-symbol* '#:*file3* :test-package))) +;; and loaded +(assert (eval (asdf::find-symbol* '#:*file1* :test-package))) +(assert (eval (asdf::find-symbol* '#:*file3* :test-package))) - ;; now touch file1 and check that file2 _is_ also recompiled - ;; but that file3 is _not_ recompiled. - ;; this will only work if the cross-module (intra-system) - ;; dependency bug is fixed and the excessive compilation bug is fixed. +;; now touch file1 and check that file2 _is_ also recompiled +;; but that file3 is _not_ recompiled. +;; this will only work if the cross-module (intra-system) +;; dependency bug is fixed and the excessive compilation bug is fixed. - (let ((before file3-date)) - (touch-file "file1.lisp" :timestamp (- before 60)) - (touch-file file1 :timestamp (- before 90)) - (touch-file "file2.lisp" :timestamp (- before 30)) - (touch-file file2 :timestamp (- before 15)) +(defparameter before file3-date) +(touch-file "file1.lisp" :timestamp (- before 60)) +(touch-file file1 :timestamp (- before 90)) +(touch-file "file2.lisp" :timestamp (- before 30)) +(touch-file file2 :timestamp (- before 15)) - (let ((plan (asdf::traverse - (make-instance 'asdf:load-op) - (asdf:find-system 'test-module-excessive-depend))) - (file3 (asdf:find-component :file3-only "file3"))) - #|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|# - (when (loop :for (o . c) :in plan :thereis (and (eq c file3) (typep o 'asdf:compile-op))) - (error "Excessive operations on file3-only system. Bad propagation of dependencies."))) - (asdf:operate 'asdf:load-op 'test-module-excessive-depend) - (assert (>= (file-write-date file1) before)) - (assert (>= (file-write-date file2) before))) - (unless (= (file-write-date file3) - file3-date) - (error "Excessive compilation of file3.lisp: traverse bug.")))) +(defparameter plan (asdf::traverse + (make-instance 'asdf:load-op) + (asdf:find-system 'test-module-excessive-depend))) +(defparameter file3 (asdf:find-component :file3-only "file3")) +#|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|# +(when (loop :for (o . c) :in plan :thereis (and (eq c file3) (typep o 'asdf:compile-op))) + (error "Excessive operations on file3-only system. Bad propagation of dependencies.")) +(asdf:operate 'asdf:load-op 'test-module-excessive-depend) +(assert (>= (file-write-date file1) before)) +(assert (>= (file-write-date file2) before))) +(unless (= (file-write-date file3) + file3-date) + (error "Excessive compilation of file3.lisp: traverse bug.")) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index 06f3f6fbc4ebb715ab0635d103a55da1cddca05b..f2fb061fd1356a776d12833e328b216cd87783a8 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (asdf:load-system 'test-module-pathnames) (flet ((pathname-foo (x) (list (or (normalize-pathname-directory-component (pathname-directory x)) '(:relative)) diff --git a/test/test-multiple.script b/test/test-multiple.script index 0436def4a8ed15e6f594f2e2b7e735b3a1b88791..649bba298b3c12174a9ce1524b734e1f0a639a51 100644 --- a/test/test-multiple.script +++ b/test/test-multiple.script @@ -1,21 +1,20 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (in-package :asdf) (use-package :asdf-test) -(with-test () - (let* ((asd (subpathname *test-directory* "test-multiple.asd")) - (tmp (subpathname *test-directory* "../build/")) - (asd2 (subpathname tmp "test-multiple-too.asd")) - (file4 (compile-file-pathname* "file4"))) - (setf *central-registry* `(,*test-directory* ,tmp)) - (run-shell-command - (format nil "/bin/ln -sf ~A ~A 2>&1" - (native-namestring asd) - (native-namestring asd2))) - (oos 'load-source-op 'test-multiple-too) - (assert (symbol-value (asdf::find-symbol* :*file3* :test-package))) - (load-system 'test-multiple-free) - (assert (asdf::probe-file* file4)))) +(defparameter asd (subpathname *test-directory* "test-multiple.asd")) +(defparameter tmp (subpathname *test-directory* "../build/")) +(defparameter asd2 (subpathname tmp "test-multiple-too.asd")) +(defparameter file4 (test-fasl "file4")) +(setf *central-registry* `(,*test-directory* ,tmp)) +(run-program/ + (format nil "/bin/ln -sf ~A ~A 2>&1" + (native-namestring asd) + (native-namestring asd2))) +(oos 'load-source-op 'test-multiple-too) +(assert (symbol-value (find-symbol* :*file3* :test-package))) +(load-system 'test-multiple-free) +(assert (probe-file* file4)) diff --git a/test/test-nested-components.script b/test/test-nested-components.script index 2877604213b3344225f259d94a6538734cff59fd..9f3f0c3501de0d9bb0f1a0fa032393938a7c95b5 100644 --- a/test/test-nested-components.script +++ b/test/test-nested-components.script @@ -2,10 +2,10 @@ ;;; check that added nesting via modules doesn't confuse ASDF -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (setf asdf:*central-registry* nil) (load "test-nested-components-1.asd") (print diff --git a/test/test-package.script b/test/test-package.script index 4ea06b6a49d694351db825ea4c3ca985062c9781..c6a3f9e7fa9a01fe803d023fd78b3c2e5b714845 100644 --- a/test/test-package.script +++ b/test/test-package.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (in-package :cl-user) (asdf-test::with-test () diff --git a/test/test-program.script b/test/test-program.script index c6d1ab761aed03cb37e63ee31afc43253e78357b..84875243e6bbe31da65433bfaf4eb7e46b791181 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (DBG :foo (current-lisp-file-pathname)) diff --git a/test/test-redundant-recompile.script b/test/test-redundant-recompile.script index 2ed920f2ad67762c738228eb2569be910764ddff..52d92573caeb1581088c7837da068a7c9e8c81d9 100644 --- a/test/test-redundant-recompile.script +++ b/test/test-redundant-recompile.script @@ -1,27 +1,24 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") -(load-asdf) -(with-test () - (asdf:operate 'asdf:load-op 'test-redundant-recompile) - ;; test that it compiled - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file2 (asdf:compile-file-pathname* "file2")) - (file1-date (file-write-date file1)) - (file2-date (file-write-date file2))) +(load-asdf) - (format t "~&test-redundant-recompile 1: ~S ~S~%" file1 file1-date) - (format t "~&test-redundant-recompile 2: ~S ~S~%" file2 file2-date) - (assert file1-date) - (assert file2-date) +(asdf:operate 'asdf:load-op 'test-redundant-recompile) +;; test that it compiled +(defparameter file1 (test-fasl "file1")) +(defparameter file2 (test-fasl "file2")) +(defparameter file1-date (file-write-date file1)) +(defparameter file2-date (file-write-date file2)) - ;; and loaded - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) +(format t "~&test-redundant-recompile 1: ~S ~S~%" file1 file1-date) +(format t "~&test-redundant-recompile 2: ~S ~S~%" file2 file2-date) +(assert file1-date) +(assert file2-date) - ;; now rerun the load-op and check that no files are recompiled +;; and loaded +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) - ;;(trace asdf::operation-done-p asdf::traverse) - (asdf:operate 'asdf:load-op 'test-redundant-recompile) - (assert (= file1-date (file-write-date file1))) - (assert (= file2-date (file-write-date file2))))) +;; now rerun the load-op and check that no files are recompiled +(load-system 'test-redundant-recompile) +(assert (= file1-date (file-write-date file1))) +(assert (= file2-date (file-write-date file2))) diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index 66e81f1ba9c56a0cc301c2659d47605c121db6a1..871fadf37f12db1ee965517d061946e1220da014 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -2,10 +2,10 @@ ;;; test asdf:try-recompiling restart -(load "script-support.lisp") + (load-asdf) (defvar *caught-error* nil) -(with-test () +(progn (DBG "trlc1 1") (asdf::delete-file-if-exists "try-reloading-dependency.asd") (setf asdf::*defined-systems* (asdf::make-defined-systems-table)) diff --git a/test/test-samedir-modules.script b/test/test-samedir-modules.script index 343aee3e7b5899a21ae8a079610bb506191f9cbb..b9ec483b29b129b91061441d2e983ff847644c6d 100644 --- a/test/test-samedir-modules.script +++ b/test/test-samedir-modules.script @@ -1,17 +1,16 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () - (DBG "loading test-samedir-modules") - (asdf:operate 'asdf:load-op 'test-samedir-modules) - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file2 (asdf:compile-file-pathname* "file2")) - (file1-date (file-write-date file1))) +(DBG "loading test-samedir-modules") +(asdf:operate 'asdf:load-op 'test-samedir-modules) +(defparameter file1 (test-fasl "file1")) +(defparameter file2 (test-fasl "file2")) +(defparameter file1-date (file-write-date file1)) - (DBG "test that it compiled" file1 file1-date) - (assert file1-date) - (assert (file-write-date file2)) +(DBG "test that it compiled" file1 file1-date) +(assert file1-date) +(assert (file-write-date file2)) - (DBG "and loaded") - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))))) +(DBG "and loaded") +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) diff --git a/test/test-source-file-type.script b/test/test-source-file-type.script index c85c4677b03e00b46e9a1d63f49a4a9371568e61..e924e1db7dc73d01729c7a67240b16f6645831cd 100644 --- a/test/test-source-file-type.script +++ b/test/test-source-file-type.script @@ -1,10 +1,10 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) ;;(trace asdf::source-file-type asdf::source-file-explicit-type) -(with-test () +(progn (asdf:load-system 'test-source-file-type-1 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (assert diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index 35488516c3fd89c1246af6e3ee5b7def550865d9..56cc2e442dd130e770e57f20a1031e3a8e18ba33 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -3,41 +3,40 @@ make sure that serial t and static-files don't cause full rebuilds all the time... |# -(load "script-support.lisp") + (load-asdf) (in-package :asdf-test) -(with-test () - - (let ((s '(def-test-system static-and-serial - :version "0.1" - :serial t - :components - ((:static-file "file2.lisp") - (:static-file "run-tests.sh") - (:file "file1"))))) - (eval s) - (load-test-system 'static-and-serial) +(defparameter s + '(def-test-system static-and-serial + :version "0.1" + :serial t + :components + ((:static-file "file2.lisp") + (:static-file "run-tests.sh") + (:file "file1")))) +(eval s) +(load-test-system 'static-and-serial) - (let* ((file1 (asdf:compile-file-pathname* "file1.lisp")) - (file1-date (file-write-date file1)) - (date1 (- file1-date 600)) - (date2 (- file1-date 300)) - (date3 (- file1-date 150))) +(defparameter file1 (test-fasl "file1.lisp")) +(defparameter file1-date (file-write-date file1)) +(defparameter date1 (- file1-date 600)) +(defparameter date2 (- file1-date 300)) +(defparameter date3 (- file1-date 150)) - (assert file1-date) - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) - (format t "file: ~S~%date: ~S~%" file1 file1-date) +(assert file1-date) +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) +(format t "file: ~S~%date: ~S~%" file1 file1-date) - ;; date should stay same - (clear-system 'static-and-serial) - (delete-package :test-package) - (eval s) - (touch-file "file2.lisp" :timestamp date1) - (touch-file "run-tests.sh" :timestamp date1) - (touch-file "file1.lisp" :timestamp date2) - (touch-file file1 :timestamp date3) - (DBG "load again" (oos 'load-op 'static-and-serial)) - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) - (assert-equal (file-write-date file1) date3)))) +;; date should stay same +(clear-system 'static-and-serial) +(delete-package :test-package) +(eval s) +(touch-file "file2.lisp" :timestamp date1) +(touch-file "run-tests.sh" :timestamp date1) +(touch-file "file1.lisp" :timestamp date2) +(touch-file file1 :timestamp date3) +(DBG "load again" (oos 'load-op 'static-and-serial)) +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) +(assert-equal (file-write-date file1) date3) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index 59f4174c4ae179eb1a5f85d5d84c4ac61c83ecba..4c55519083981482c2f62bc44ba41bbbc50a50d9 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (asdf:load-system :asdf) (asdf:initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) :ignore-inherited-configuration)) diff --git a/test/test-system-pathnames.script b/test/test-system-pathnames.script index 4cfc02db98c40490a23f82aa9aa778e6cd61c84a..606b0d04777dab40a520c01db8017821516da794 100644 --- a/test/test-system-pathnames.script +++ b/test/test-system-pathnames.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (asdf:load-system 'test-system-pathnames) (assert (find-package :test-package) () "package test-package not found") diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index 5c9ec5cb985becd2bc88a51fe0444d3f22060c80..8d1cf145bcd4cab8a3fc0b132b59fc4b327305e6 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -3,27 +3,24 @@ ;;; test system def reloading if touched ;;; system that can be found using *system-definition-search-functions* -(load "script-support.lisp") (load-asdf) -(with-test () - (flet ((system-load-time (name) - (let ((data (asdf::system-registered-p name))) - (when data - (car data))))) - (let* ((file "test1.asd") - (date1 (file-write-date file)) - (date2 (- date1 600)) - (date3 (- date1 300))) - (touch-file file :timestamp date2) - (asdf:find-system :test1) - (let ((date4 (file-write-date (asdf::compile-file-pathname* "file1.lisp"))) - (date5 (system-load-time :test1))) - (DBG :blah date2 date3 date4 date5) - (assert-equal date2 date5) - (assert (>= date4 date3)) - (sleep 1) - (touch-file file) - (asdf:find-system :test1) - (let ((date6 (system-load-time :test1))) - (assert (> date6 date4))))))) - \ No newline at end of file + +(defun system-load-time (name) + (if-let (data (asdf::system-registered-p name)) + (car data))) +(defparameter file "test1.asd") +(defparameter date1 (file-write-date file)) +(defparameter date2 (- date1 600)) +(defparameter date3 (- date1 300)) +(touch-file file :timestamp date2) +(asdf:find-system :test1) +(defparameter date4 (file-write-date (test-fasl "file1.lisp"))) +(defparameter date5 (system-load-time :test1)) +(DBG :blah date2 date3 date4 date5) +(assert-equal date2 date5) +(assert (>= date4 date3)) +(sleep 1) +(touch-file file) +(find-system :test1) +(defparameter date6 (system-load-time :test1)) +(assert (> date6 date4)) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 3694802512124a50cdc8e2bea3ec0c4944bf819c..6078bfe26b5b8a240bca1c54bfa3ca5144e81feb 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -3,9 +3,9 @@ ;;; test system definition reloading if touched ;;; system that canNOT be found using *system-definition-search-functions* -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (flet ((system-load-time (name) (let ((data (asdf::system-registered-p name))) (when data diff --git a/test/test-try-recompiling-1.script b/test/test-try-recompiling-1.script index e1c669301f34bc6b55cd14b4b5f49d15b27bb453..39062487bec802f66e1274753c6c16c7dec9c99f 100644 --- a/test/test-try-recompiling-1.script +++ b/test/test-try-recompiling-1.script @@ -2,26 +2,28 @@ ;;; test asdf:try-recompiling restart -(load "script-support.lisp") + (load-asdf) -(defvar *caught-error* nil) +(defparameter *caught-error* nil) + +(delete-file-if-exists (test-fasl "try-recompiling-1")) + +#-gcl +(handler-bind + ((error (lambda (c) + (setf *caught-error* t) + (multiple-value-bind (name mode) + (find-symbol + (symbol-name 'try-recompiling) + :asdf) + (assert (eq mode :external)) + (let ((restart (find-restart name c))) + #+(or) + ;; debug + (print (list c restart (compute-restarts c))) + (when restart + (invoke-restart restart))))))) + (oos 'load-op 'try-recompiling-1)) -(with-test () - (asdf::delete-file-if-exists (compile-file-pathname "try-recompiling-1")) - #-gcl - (handler-bind ((error (lambda (c) - (setf *caught-error* t) - (multiple-value-bind (name mode) - (find-symbol - (symbol-name 'try-recompiling) - :asdf) - (assert (eq mode :external)) - (let ((restart (find-restart name c))) - #+(or) - ;; debug - (print (list c restart (compute-restarts c))) - (when restart - (invoke-restart restart))))))) - (oos 'load-op 'try-recompiling-1)) - #-gcl - (assert *caught-error*)) +#-gcl +(assert *caught-error*) diff --git a/test/test-urls-1.script b/test/test-urls-1.script index 47f26ed14d3ab8e3f417b17656e0a3d472fba584..a5e12a9af123c13efca7780c868fcf4c3d5149d5 100644 --- a/test/test-urls-1.script +++ b/test/test-urls-1.script @@ -1,35 +1,34 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) #+scl (require :http-library) -(with-test () - ;; Compare the source files with local versions before loading them. - #+(and (or abcl scl) trust-the-net) - (flet ((compare (url local) - (with-open-file (stream1 url :element-type 'character - :external-format :utf-8) - (with-open-file (stream2 local :element-type 'character - :external-format :utf-8) - (loop - (let ((ch1 (read-char stream1 nil nil)) - (ch2 (read-char stream2 nil nil))) - (unless (eql ch1 ch2) - (error "Unexpected source content.")) - (unless (and ch1 ch2) - (return)))))))) - (let* ((system (asdf:find-system "test-urls-1")) - (url (asdf:component-pathname - (asdf:find-component system "test")))) - (compare url "test.lisp")) +;; Compare the source files with local versions before loading them. +#+(and (or abcl scl) trust-the-net) +(flet ((compare (url local) + (with-open-file (stream1 url :element-type 'character + :external-format :utf-8) + (with-open-file (stream2 local :element-type 'character + :external-format :utf-8) + (loop + (let ((ch1 (read-char stream1 nil nil)) + (ch2 (read-char stream2 nil nil))) + (unless (eql ch1 ch2) + (error "Unexpected source content.")) + (unless (and ch1 ch2) + (return)))))))) + (let* ((system (find-system "test-urls-1")) + (url (asdf:component-pathname + (asdf:find-component system "test")))) + (compare url "test.lisp")) - (asdf:operate 'asdf:load-op 'test-urls-1) + (load-system 'test-urls-1) - ;; test that it compiled - (let* ((path (asdf:component-pathname - (asdf:find-component "test-urls-1" "test"))) - (test (asdf:compile-file-pathname* path)) - (test-date (file-write-date test))) - (format t "~&test-urls-1 1: ~S ~S~%" test test-date) - (assert test-date)))) + ;; test that it compiled + (let* ((path (component-pathname + (find-component "test-urls-1" "test"))) + (test (test-fasl path)) + (test-date (file-write-date test))) + (format t "~&test-urls-1 1: ~S ~S~%" test test-date) + (assert test-date))) diff --git a/test/test-urls-2.script b/test/test-urls-2.script index 46237b1eda93dcdaf167ae9ec4e660c986f9b4cd..532136a455af43ad64d3b3ffc62314612b465c38 100644 --- a/test/test-urls-2.script +++ b/test/test-urls-2.script @@ -1,10 +1,10 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) #+scl (require :http-library) -(with-test () +(progn (setf asdf:*central-registry* '("http://www.scieneer.com/files/")) ;; Compare the source files with local versions before loading them. #+(and (or abcl scl) trust-the-net) @@ -20,19 +20,19 @@ (error "Unexpected source content.")) (unless (and ch1 ch2) (return)))))))) - (let ((url (asdf:system-definition-pathname "test-urls-2"))) + (let ((url (system-definition-pathname "test-urls-2"))) (compare url "test-urls-2.asd")) (let* ((system (asdf:find-system "test-urls-2")) - (url (asdf:component-pathname - (asdf:find-component system "test")))) + (url (component-pathname + (find-component system "test")))) (compare url "test.lisp")) - (asdf:operate 'asdf:load-op 'test-urls-2) + (load-system 'test-urls-2) ;; Test that it compiled - (let* ((path (asdf:component-pathname - (asdf:find-component "test-urls-2" "test"))) - (test (asdf:compile-file-pathname* path)) + (let* ((path (component-pathname + (find-component "test-urls-2" "test"))) + (test (test-fasl path)) (test-date (file-write-date test))) (format t "~&test-urls-2 1: ~S ~S~%" test test-date) (assert test-date)))) diff --git a/test/test-utilities.script b/test/test-utilities.script index ef4d6439b0ad6c8a9469e58a719e27e5f9dcf680..4ff33cd7f9b7ebcca5646882801d26c7b8526507 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -1,11 +1,11 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (in-package :asdf) (use-package :asdf-test) -(with-test () +(progn (assert (every #'directory-pathname-p diff --git a/test/test-version.script b/test/test-version.script index c2e160a53487f756215282b5cdd6785ea358fc92..250e0c90d2756ad26e85b0b0987342ebea3c76c2 100644 --- a/test/test-version.script +++ b/test/test-version.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (def-test-system :versioned-system-1 :pathname #.*test-directory* :version "1.0") diff --git a/test/test-weakly-depends-on-present.asd b/test/test-weakly-depends-on-present.asd deleted file mode 100644 index 04c3b55baa413bd05bfb855b4082a73f6c64bcb2..0000000000000000000000000000000000000000 --- a/test/test-weakly-depends-on-present.asd +++ /dev/null @@ -1,4 +0,0 @@ -(defsystem test-weakly-depends-on-present - :weakly-depends-on (file3-only) - :components ((:file "file1"))) - diff --git a/test/test-weakly-depends-on-present.script b/test/test-weakly-depends-on-present.script index 63e42619cfb4e024b515bb7cddfc9b470f173338..1296e70d09f2d6deecdbf8bfc8b392dd8529649b 100644 --- a/test/test-weakly-depends-on-present.script +++ b/test/test-weakly-depends-on-present.script @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) ;;;--------------------------------------------------------------------------- @@ -7,24 +7,24 @@ ;;; directory, actually gets loaded. ;;;--------------------------------------------------------------------------- +(def-test-system test-weakly-depends-on-present + :weakly-depends-on (file3-only) + :components ((:file "file1"))) + +(DBG "Loading" (operate 'load-op 'test-weakly-depends-on-present)) -(with-test () - (asdf:load-system 'test-weakly-depends-on-present) - ;; The weakly-depended-on system, file3-only, should be loaded... - (let* ((file3 (asdf:compile-file-pathname* "file3")) - (file3-date (file-write-date file3))) +(DBG "The weakly-depended-on system, file3-only, should be loaded...") +(defparameter *file3* (test-fasl "file3")) +(defparameter *file3-date* (file-write-date *file3*)) - ;; (format t "~&test1 1: ~S ~S~%" file1 file1-date) - (assert file3-date) - ;; and loaded - (assert (symbol-value (find-symbol (symbol-name :*file3*) :test-package))))) +(DBG "test1 1" *file3* *file3-date*) +(assert *file3-date*) +(assert (symbol-value (find-symbol (symbol-name :*file3*) :test-package))) - ;; The depending system (test-weakly-depends-on-present) loads - ;; successfully. [2011/12/14:rpg] - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file1-date (file-write-date file1))) +(DBG "The depending system (test-weakly-depends-on-present) loads successfully. [2011/12/14:rpg]") +(defparameter *file1* (test-fasl "file1")) +(defparameter *file1-date* (file-write-date *file1*)) - ;; (format t "~&test1 1: ~S ~S~%" file1 file1-date) - (assert file1-date) - ;; and loaded - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))))) +(DBG "test1 2" *file1* *file1-date*) +(assert *file1-date*) +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) diff --git a/test/test-weakly-depends-on-unpresent.script b/test/test-weakly-depends-on-unpresent.script index 791d7dc0c3350b05b2673f97e7457de9d96788f5..da079d9bbee45fa6a96b487be006c4440f28e313 100644 --- a/test/test-weakly-depends-on-unpresent.script +++ b/test/test-weakly-depends-on-unpresent.script @@ -6,16 +6,15 @@ ;;; system will still load successfully. [2011/12/14:rpg] ;;;--------------------------------------------------------------------------- -(load "script-support.lisp") + (load-asdf) -(with-test () - (asdf:load-system 'test-weakly-depends-on-unpresent) - ;; test that it compiled - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file1-date (file-write-date file1))) +(asdf:load-system 'test-weakly-depends-on-unpresent) +;; test that it compiled +(defparameter file1 (test-fasl "file1")) +(defparameter file1-date (file-write-date file1)) - (format t "~&test1 1: ~S ~S~%" file1 file1-date) - (assert file1-date) - ;; and loaded - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))))) +(format t "~&test1 1: ~S ~S~%" file1 file1-date) +(assert file1-date) +;; and loaded +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) diff --git a/test/test-xach-update-bug.script b/test/test-xach-update-bug.script index 380e57de3863a2ce664ced995c0c8ea3cecd64b2..161f907d8844d99519b997f51687b2e5afbc38f6 100644 --- a/test/test-xach-update-bug.script +++ b/test/test-xach-update-bug.script @@ -1,9 +1,9 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) #+gcl (trace load compile-file asdf:perform asdf::perform-plan) -(with-test () +(progn (let ((foo :test-asdf-location-change)) (DBG "load foo. Should load from xach-foo-1/") (setf *central-registry* (list (subpathname *test-directory* "xach-foo-1/"))) diff --git a/test/test1.script b/test/test1.script index 5ad1176d285d35bdbb1afe08da4046958246fb09..7c29cb8b68504edb97be973baafed4d182906720 100644 --- a/test/test1.script +++ b/test/test1.script @@ -1,46 +1,47 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) (touch-file "test1.asd" :offset -3600) ;; touch test1.asd an hour ago. (touch-file "file1.lisp" :offset -3500) (touch-file "file2.lisp" :offset -3400) - -(with-test () - (DBG "loading test1") - (asdf:load-system 'test1) - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file2 (asdf:compile-file-pathname* "file2")) - (date (file-write-date "test1.asd")) - (then (file-write-date file2))) - - (DBG "test that it compiled" date then) - (assert (probe-file file1)) - (assert (probe-file file2)) - - (DBG "and loaded") - (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) - - (DBG "now remove file2 that depends-on file1" date) - (touch-file file1 :timestamp (+ date 500)) - (assert-equal (+ date 500) (file-write-date file1)) - (asdf::delete-file-if-exists file2) - - (DBG "load again") - (asdf:clear-system 'test1) - (asdf:load-system 'test1) - (DBG "check that file1 is _not_ recompiled, but file2 is" (file-write-date file1)) - (assert-equal (+ date 500) (file-write-date file1)) - (assert-compare (<= then (file-write-date file2))) - - (DBG "now touch file1 and check that file2 _is_ also recompiled") - ;; XXX run-shell-command loses if *default-pathname-defaults* is not the - ;; unix cwd. this is not a problem for run-tests.sh, but can be in general - (let ((before (file-write-date file2))) - (touch-file "file1.lisp" :timestamp (+ date 3000)) ;; touch file1 a minute ago. - (touch-file file2 :timestamp (+ date 2000)) ;; touch file2.fasl some time before. - (asdf:clear-system 'test1) - (asdf:operate 'asdf:load-op 'test1) - (DBG :foo (file-write-date file2) before) - (assert-compare (>= (file-write-date file2) before))))) +(DBG "loading test1") +(asdf:load-system 'test1) + +(defparameter *file1* (test-fasl "file1")) +(defparameter *file2* (test-fasl "file2")) +(defparameter *date* (file-write-date "test1.asd")) +(defparameter *then* (file-write-date *file2*)) + +(assert-equal *file1* (first (output-files 'compile-op '("test1" "file1")))) + +(DBG "test that it compiled" *date* *then*) +(assert (probe-file *file1*)) +(assert (probe-file *file2*)) + +(DBG "and loaded") +(assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) + +(DBG "now remove file2 that depends-on file1" *date*) +(touch-file *file1* :timestamp (+ *date* 500)) +(assert-equal (+ *date* 500) (file-write-date *file1*)) +(asdf::delete-file-if-exists *file2*) + +(DBG "load again") +(asdf:clear-system 'test1) +(asdf:load-system 'test1) +(DBG "check that file1 is _not_ recompiled, but file2 is" (file-write-date *file1*)) +(assert-equal (+ *date* 500) (file-write-date *file1*)) +(assert-compare (<= *then* (file-write-date *file2*))) + +(DBG "now touch file1 and check that file2 _is_ also recompiled") +;; XXX run-shell-command loses if *default-pathname-defaults* is not the +;; unix cwd. this is not a problem for run-tests.sh, but can be in general +(defparameter *before* (file-write-date *file2*)) +(touch-file "file1.lisp" :timestamp (+ *date* 3000)) ;; touch file1 a minute ago. +(touch-file *file2* :timestamp (+ *date* 2000)) ;; touch file2.fasl some time before. +(asdf:clear-system 'test1) +(asdf:operate 'asdf:load-op 'test1) +(DBG :foo (file-write-date *file2*) *before*) +(assert-compare (>= (file-write-date *file2*) *before*)) diff --git a/test/test2.script b/test/test2.script index ca0613e0d2777d4265bb56523b4ef3a89b640eac..b175caf249e7a433774d4f105ccdd1bec64c56b4 100644 --- a/test/test2.script +++ b/test/test2.script @@ -1,27 +1,30 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () - (DBG "test2: loading test2b1") - (asdf:load-system 'test2b1) - (DBG "test2: file3 and file4 were compiled") - (assert (and (probe-file (asdf:compile-file-pathname* (truename "file3.lisp"))) - (probe-file (asdf:compile-file-pathname* (truename "file4.lisp"))))) - (DBG "test2: loading test2b2 should fail") - #-gcl - (handler-case - (asdf:load-system 'test2b2) - (asdf:missing-dependency (c) - (format t "load failed as expected: - ~%~A~%" c)) - (:no-error (c) - (declare (ignore c)) - (error "should have failed, oops"))) - (DBG "test2: loading test2b3 should fail") - #-gcl - (handler-case - (asdf:load-system 'test2b3) - (asdf:missing-dependency (c) - (format t "load failed as expected: - ~%~A~%" c)) - (:no-error (c) - (declare (ignore c)) - (error "should have failed, oops")))) + +(DBG "test2: loading test2b1") +(asdf:load-system 'test2b1) + +(DBG "test2: file3 and file4 were compiled") +(assert (and (probe-file (test-fasl "file3.lisp")) + (probe-file (test-fasl "file4.lisp")))) + +(DBG "test2: loading test2b2 should fail") +#-gcl +(handler-case + (asdf:load-system 'test2b2) + (asdf:missing-dependency (c) + (format t "load failed as expected: - ~%~A~%" c)) + (:no-error (c) + (declare (ignore c)) + (error "should have failed, oops"))) + +(DBG "test2: loading test2b3 should fail") +#-gcl +(handler-case + (asdf:load-system 'test2b3) + (asdf:missing-dependency (c) + (format t "load failed as expected: - ~%~A~%" c)) + (:no-error (c) + (declare (ignore c)) + (error "should have failed, oops"))) diff --git a/test/test3.script b/test/test3.script index ad32ffc52dc2d3130ca7da85c2c4c87756f06784..ba4e222bfb380760c96022fbea7336a15d52a501 100644 --- a/test/test3.script +++ b/test/test3.script @@ -1,18 +1,18 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () - (let* ((fasl1 (asdf:compile-file-pathname* (truename "file1.lisp"))) - (fasl2 (asdf:compile-file-pathname* (truename "file2.lisp"))) - (ns1 (asdf::native-namestring fasl1)) - (ns2 (asdf::native-namestring fasl2))) - (asdf:run-shell-command "rm -f ~A ~A" ns1 ns2) - (DBG "should load file1 but not file2") - (asdf:load-system :test3) - (assert (probe-file fasl1)) - (assert (not (probe-file fasl2))) - (assert (not (component-property (find-system 'test3) :foo))) - (assert (equal (component-property (find-system 'test3) :prop1) "value")) - (setf (component-property (find-system 'test3) :foo) "bar") - (assert (equal (component-property (find-system 'test3) :foo) "bar")))) +(defparameter *fasl1* (test-fasl "file1.lisp")) +(defparameter *fasl2* (test-fasl "file2.lisp")) + +(delete-file-if-exists *fasl1*) +(delete-file-if-exists *fasl2*) +(DBG "should load file1 but not file2") +(asdf:load-system :test3) +(assert (probe-file *fasl1*)) +(assert (not (probe-file *fasl2*))) + +(assert (not (component-property (find-system 'test3) :foo))) +(assert (equal (component-property (find-system 'test3) :prop1) "value")) +(setf (component-property (find-system 'test3) :foo) "bar") +(assert (equal (component-property (find-system 'test3) :foo) "bar")) diff --git a/test/test8.script b/test/test8.script index b530fda5d10f22d006e92a756d45426a1a35bb71..a76c320de25e2c999051634e4f12f327f36e0cd8 100644 --- a/test/test8.script +++ b/test/test8.script @@ -2,11 +2,11 @@ ;;; make sure we get a missing-component error -(load "script-support.lisp") + (load-asdf) (in-package :asdf-test) -(with-test () +(progn (trace operate) (handler-case (asdf:oos 'asdf:load-op 'system-does-not-exist) diff --git a/test/test9.script b/test/test9.script index b09690d282a83a4c4598f63e46b25912611ac79a..4463130262804d652963b1bfad0eaf10d1bc0505 100644 --- a/test/test9.script +++ b/test/test9.script @@ -2,10 +2,10 @@ ;;; make sure we get a missing-component-of-version error -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (handler-case (load-test-system :test-asdf/test9-1) (asdf:missing-component-of-version (c) diff --git a/test/wild-module.script b/test/wild-module.script index adc0c5d18c306bc561cbdd71a4539092caabe659..2bf412be0525e247dc8055698733c67bac379788 100644 --- a/test/wild-module.script +++ b/test/wild-module.script @@ -1,7 +1,7 @@ ;;; -*- Lisp -*- -(load "script-support.lisp") + (load-asdf) -(with-test () +(progn (load (asdf::subpathname *asdf-directory* "contrib/wild-modules.lisp")) (def-test-system :wild-module :version "0.0" diff --git a/upgrade.lisp b/upgrade.lisp index f3d4ed3d163fcfd08273a2623d74a2d699162d3d..ab2f19551d0e59e5274782d651e6cbd5820d0c75 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -9,23 +9,13 @@ #:upgrade-asdf #:asdf-upgrade-error #:when-upgrade #:*asdf-upgrade-already-attempted* #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf - #:asdf-version #:*upgraded-p* + #:asdf-version #:*upgraded-p* #:*asdf-version* #:asdf-message #:*asdf-verbose* #:*verbose-out* ;; There will be no symbol left behind! #:intern*) (:import-from :asdf/package #:intern* #:find-symbol*)) (in-package :asdf/upgrade) -;; Note that this massive package destruction makes it impossible -;; to use asdf/driver on top of an old ASDF on these implementations -(eval-when (:load-toplevel :compile-toplevel :execute) - #+(or clisp xcl) - (unless (let ((vs (find-symbol* 'version-satisfies :asdf nil)) - (av (find-symbol* 'asdf-version :asdf nil))) - (and vs av (funcall vs (funcall av) "2.26.59"))) - (if-let (p (find-package :asdf)) - (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))))) - ;;; Special magic to detect if this is an upgrade (eval-when (:load-toplevel :compile-toplevel :execute) @@ -45,17 +35,62 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.125") + (asdf-version "2.26.126") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) - (already-there (equal asdf-version existing-version))) - (unless (and existing-asdf already-there) + (already-there (equal asdf-version existing-version)) + (redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. + '(#:perform #:explain #:output-files #:operation-done-p + #:component-parent-pathname #:traverse + #:component-depends-on #:input-files + #:perform-with-restarts #:component-relative-pathname + #:system-source-file #:operate #:find-component #:find-system + #:apply-output-translations + #:system-relative-pathname + #:inherit-source-registry #:process-source-registry + #:process-source-registry-directive #:source-file-type + #:process-output-translations-directive + #:trivial-system-p + )) + (uninterned-symbols + '(#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component + #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function + (when (and existing-asdf (not already-there)) (when existing-asdf (asdf-message "~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%" - existing-version asdf-version)) - (unless already-there + existing-version asdf-version) (push existing-version *upgraded-p*)) - (setf *asdf-version* asdf-version)))) + ;;(format t "UPGRADE FROBBING! ~S~%" (list existing-asdf existing-version asdf-version)) ;XXX + (loop :for name :in (append #-(or clisp ecl) redefined-functions) + :for sym = (find-symbol* name :asdf nil) :do + (when sym + ;;(format t "Undefining ~S~%" sym);XXX + (fmakunbound sym))) + (loop :with asdf = (find-package :asdf) + :for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX + :for sym = (find-symbol* name :asdf nil) + :for base-pkg = (and sym (symbol-package sym)) :do + (when sym + ;;(format t "frobbing symbol ~S~%" sym);XXX + (cond + ((or (eq base-pkg asdf) (not base-pkg)) + (unintern* sym asdf) + (intern* sym asdf)) + (t + (unintern* sym base-pkg) + (let ((new (intern* sym base-pkg))) + (shadowing-import new asdf)))))) + ;; Note that this massive package destruction makes it impossible + ;; to use asdf/driver on top of an old ASDF on these implementations + #+(or clisp xcl) + (let ((p (find-package :asdf))) + (when p + (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))) + (rename-package-away p :prefix (format nil "~A-~A" :asdf (or existing-version :1.x)) + :index 0 :separator "-")))) + (setf *asdf-version* asdf-version))) ;;; Upgrade interface @@ -81,8 +116,6 @@ You can compare this string with e.g.: ;;; Self-upgrade functions -(defvar *asdf-upgrade-already-attempted* nil) - (defvar *post-upgrade-cleanup-hook* ()) (defvar *post-upgrade-restart-hook* ()) @@ -108,9 +141,9 @@ You can compare this string with e.g.: (defun* upgrade-asdf () "Try to upgrade of ASDF. If a different version was used, return T. We need do that before we operate on anything that may possibly depend on ASDF." - (unless *asdf-upgrade-already-attempted* - (setf *asdf-upgrade-already-attempted* t) - (let ((version (asdf-version))) - (handler-bind (((or style-warning warning) #'muffle-warning)) - (symbol-call :asdf :load-system :asdf :verbose nil)) - (cleanup-upgraded-asdf version)))) + (let ((version (asdf-version)) + (*load-print* nil) + (*compile-print* nil)) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (symbol-call :asdf :load-system :asdf :verbose nil)) + (cleanup-upgraded-asdf version))) diff --git a/utility.lisp b/utility.lisp index fd91ea1cbf44a21c246d90a41b6c79c71b9d2b83..d57f2a1e00cdff097d69ea9f37a9be02a06f8ca5 100644 --- a/utility.lisp +++ b/utility.lisp @@ -52,18 +52,24 @@ (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) - `(progn + (destructuring-bind (name &key (supersede t)) + (if (or (atom name) (eq (car name) 'setf)) + (list name :supersede nil) + name) + (declare (ignorable supersede)) + `(progn ;; undefining the previous function is the portable way - ;; of overriding any incompatible previous gf, but somehow - ;; this causes CLISP to fail to see COMPONENT-NAME methods after ugprade - ;; so instead, for CLISP we delete-package* in package.lisp - ;; any time the API changes. - #-clisp - (undefine-function ',name) - #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( - ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl - `((declaim (notinline ,name)))) - (,',def ,name ,formals ,@rest))))) + ;; of overriding any incompatible previous gf, + ;; but we usually try to do it only for the functions that need it, + ;; which happens in asdf/upgrade - however, for ECL, we need this hammer, + ;; (which causes issues in clisp) + #-ecl ;XXX + ,@(when (or supersede #+(or (and gcl (not gcl-pre2.7))) t) + `((undefine-function ',name))) + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `((declaim (notinline ,name)))) + (,',def ,name ,formals ,@rest)))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) diff --git a/version.lisp-expr b/version.lisp-expr index 16fb0f044bb62a4b897351b70f63085a4af26d41..a69540736d6e1b1a59663dc3ca89350336c7f795 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.125" +"2.26.126"