diff --git a/action.lisp b/action.lisp index 0a713673e27284f9f10b7bf061be46953bb90296..1555c234a14b31c63f15756d6ae2491b79c02047 100644 --- a/action.lisp +++ b/action.lisp @@ -18,6 +18,7 @@ #:component-operation-time #:mark-operation-done #:compute-action-stamp #:perform #:perform-with-restarts #:retry #:accept #:feature #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan + #:action-path #:find-action )) (in-package :asdf/action) @@ -27,6 +28,12 @@ (defgeneric* traverse-sub-actions (operation component &key &allow-other-keys)) (defgeneric* required-components (component &key &allow-other-keys)) +;;;; Reified representation for storage or debugging. Note: dropping original-initags +(defun action-path (action) + (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c)))) +(defun find-action (path) + (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))) + ;;;; Convenience methods (defmacro define-convenience-action-methods diff --git a/asdf.asd b/asdf.asd index 4eb5a40e3fafda66b033b53b990731416bc8be43..1d8e18a28191a7a27b187d5baa53366c61e89b65 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.128" ;; to be automatically updated by make bump-version + :version "2.26.129" ;; to be automatically updated by make bump-version :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem)))) diff --git a/configuration.lisp b/configuration.lisp index 010ab089c12cbb246096b10af2a9a99ce4c8666a..57672cb0ba0bd4ec95649e569cf92bc78bf83a4a 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -235,6 +235,10 @@ directive.") :wilden (and wilden (not (pathnamep x))) :want-absolute t)) +;; Try to override declaration in previous versions of ASDF. +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) + (:ensure-directory boolean)) t) resolve-location)) + (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) diff --git a/header.lisp b/header.lisp index c0d93d18990df0621643a83bb42e8c980b94a50f..507b4f6fa7cc20d6934de7c147b539575578e81b 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.128: Another System Definition Facility. +;;; This is ASDF 2.26.129: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . diff --git a/lisp-action.lisp b/lisp-action.lisp index 30d7e6168e0b976b81f4a6f2f6879d474a3d963b..b982ad1812560a79874c69aa11335c2cdd3953f7 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -81,7 +81,7 @@ (outputs (output-files o c))) (multiple-value-bind (output warnings-p failure-p) (destructuring-bind - (output-file &optional #+(or ecl mkcl) object-file #+sbcl warnings-file) outputs + (output-file &optional #+(or ecl mkcl) object-file #+(or clozure sbcl) warnings-file) outputs (call-with-around-compile-hook c #'(lambda (&rest flags) (with-muffled-compiler-conditions () @@ -90,7 +90,7 @@ :external-format (component-external-format c) (append #+(or ecl mkcl) (list :object-file object-file) - #+sbcl (list :warnings-file warnings-file) + #+(or clozure sbcl) (list :warnings-file warnings-file) flags (compile-op-flags o))))))) (check-lisp-compile-results output warnings-p failure-p "~/asdf-action::format-action/" (list (cons o c)))))) @@ -114,12 +114,15 @@ (f (compile-file-pathname 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))) - #+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file - #+sbcl ,@(let ((s (component-system c))) - (unless (builtin-system-p s) ; includes ASDF itself - `(,(make-pathname :type "sbcl-warnings" :defaults f))))))) + #+(or clozure sbcl) + ,@(let ((s (component-system c))) + (unless (builtin-system-p s) ; includes ASDF itself + `(,(make-pathname :type (warnings-file-type) :defaults f)))) + #+ecl + ,@(unless (use-ecl-byte-compiler-p) + `(,(compile-file-pathname i :type :object))) + #+mkcl + ,(compile-file-pathname i :fasl-p nil)))) ;; object file (defmethod component-depends-on ((o compile-op) (c component)) (declare (ignorable o)) `((prepare-op ,c) ,@(call-next-method))) @@ -133,7 +136,7 @@ (declare (ignorable o c)) nil #+sbcl (perform-lisp-warnings-check o c)) -#+sbcl +#+(or clozure sbcl) (defmethod input-files ((o compile-op) (c system)) (declare (ignorable o c)) (unless (builtin-system-p c) @@ -142,7 +145,7 @@ o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) :append (remove-if-not 'warnings-file-p - (output-files sub-o sub-c))))) + (output-files sub-o sub-c))))) #+sbcl (defmethod output-files ((o compile-op) (c system)) (unless (builtin-system-p c) diff --git a/lisp-build.lisp b/lisp-build.lisp index 93e23a4270a929bce7819dea37c4821391baad16..4f31d586c12b65876d755aba7abbaf40945f86b0 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -22,7 +22,7 @@ #:reify-simple-sexp #:unreify-simple-sexp #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings - #:with-saved-deferred-warnings #:warnings-file-p + #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit #:current-lisp-file-pathname #:load-pathname #:lispize-pathname #:compile-file-type #:call-around-hook @@ -193,11 +193,41 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) ((simple-vector 2) (unreify-symbol sexp)))) +#+clozure +(progn + (defun reify-source-note (source-note) + (when source-note + (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) + (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note + (declare (ignorable source)) + (list :filename filename :start-pos start-pos :end-pos end-pos + #|:source (reify-source-note source)|#)))) + (defun unreify-source-note (source-note) + (when source-note + (destructuring-bind (&key filename start-pos end-pos source) source-note + (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos + :source (unreify-source-note source))))) + (defun reify-deferred-warning (deferred-warning) + (with-accessors ((warning-type ccl::compiler-warning-warning-type) + (args ccl::compiler-warning-args) + (source-note ccl:compiler-warning-source-note) + (function-name ccl:compiler-warning-function-name)) deferred-warning + (list :warning-type warning-type :function-name (reify-simple-sexp function-name) + :source (reify-source-note source-note) :args (reify-simple-sexp args)))) + (defun unreify-deferred-warning (reified-deferred-warning) + (destructuring-bind (&key warning-type function-name source-note args) + reified-deferred-warning + (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) + 'ccl::compiler-warning) + :function-name (unreify-simple-sexp function-name) + :source-note (unreify-source-note source-note) + :warning-type warning-type + :args (unreify-simple-sexp args))))) + +#+sbcl (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" - #-sbcl (declare (ignore warning)) - #+sbcl (list* (sb-c::undefined-warning-kind warning) (sb-c::undefined-warning-name warning) @@ -215,7 +245,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (sb-c::undefined-warning-warnings warning)))) (defun reify-deferred-warnings () - #-sbcl nil + #+clozure + (mapcar 'reify-deferred-warning + (if-let (dw ccl::*outstanding-deferred-warnings*) + (ccl::deferred-warnings.warnings dw))) #+sbcl (when sb-c::*in-compilation-unit* ;; Try to send nothing through the pipe if nothing needs to be accumulated @@ -231,10 +264,15 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when :when (plusp value) :collect `(,what . ,value))))) -(defun unreify-deferred-warnings (constructor-list) - #-sbcl (declare (ignore constructor-list)) +(defun unreify-deferred-warnings (reified-deferred-warnings) + (declare (ignorable reified-deferred-warnings)) + #+clozure + (let ((dw (or ccl::*outstanding-deferred-warnings* + (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) + (setf (ccl::deferred-warnings.warnings dw) + (mapcar 'unreify-deferred-warning reified-deferred-warnings))) #+sbcl - (dolist (item constructor-list) + (dolist (item reified-deferred-warnings) ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. ;; For *undefined-warnings*, the adjustment is a list of initargs. ;; For everything else, it's an integer. @@ -261,6 +299,9 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (set symbol (+ (symbol-value symbol) adjustment))))))) (defun reset-deferred-warnings () + #+clozure + (if-let ((dw ccl::*outstanding-deferred-warnings*)) + (setf (ccl::deferred-warnings.warnings dw) nil)) #+sbcl (when sb-c::*in-compilation-unit* (setf sb-c::*undefined-warnings* nil @@ -279,8 +320,14 @@ possibly in a different process." (terpri s))) (reset-deferred-warnings)) -(defun* warnings-file-p (file) - (equal (pathname-type file) "sbcl-warnings")) +(defun* warnings-file-type (&optional implementation-type) + (case (or implementation-type *implementation-type*) + (:sbcl "sbcl-warnings") + ((:clozure :ccl) "ccl-warnings"))) + +(defun* warnings-file-p (file &optional implementation-type) + (if-let (type (warnings-file-type implementation-type)) + (equal (pathname-type file) type))) (defun* check-deferred-warnings (files &optional context-format context-arguments) (let ((file-errors nil) @@ -306,6 +353,26 @@ possibly in a different process." ;;;; Deferred warnings +#| +Mini-guide to adding support for deferred warnings on an implementation. + +First, look at what such a warning looks like: + +(describe + (handler-case + (and (eval '(lambda () (some-undefined-function))) nil) + (t (c) c))) + +Then you can grep for the condition type in your compiler sources +and see how to catch those that have been deferred, +and/or read, clear and restore the deferred list. + +ccl:: +undefined-function-reference +verify-deferred-warning +report-deferred-warnings + +|# (defun* call-with-saved-deferred-warnings (thunk warnings-file) (if warnings-file diff --git a/os.lisp b/os.lisp index 20dd04f2eca6c7be23950c1381e5e63e968e5f68..0bef9497b2b837fb23fed5328504d1904adfaf6c 100644 --- a/os.lisp +++ b/os.lisp @@ -12,7 +12,8 @@ #:getenv-pathname #:getenv-pathnames #:getenv-absolute-directory #:getenv-absolute-directories #:implementation-identifier ;; implementation identifier - #:implementation-type #:operating-system #:architecture #:lisp-version-string + #:implementation-type #:*implementation-type* + #:operating-system #:architecture #:lisp-version-string #:hostname #:user-homedir #:lisp-implementation-directory #:getcwd #:chdir #:call-with-current-directory #:with-current-directory #:*temporary-directory* #:temporary-directory #:default-temporary-directory @@ -161,6 +162,8 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (:lwpe :lispworks-personal-edition) (:lw :lispworks) :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) +(defvar *implementation-type* (implementation-type)) + (defun* operating-system () (first-feature '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! diff --git a/plan.lisp b/plan.lisp index 73eb951f1bff4af4d2ba6ff5083dabbe3cacebde..8192f2fb513588942ed1277e83f9f0a37e9963fc 100644 --- a/plan.lisp +++ b/plan.lisp @@ -196,6 +196,8 @@ the action of OPERATION on COMPONENT in the PLAN")) (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c))))) stamp) +(asdf-debug) + (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) ;; In a distant future, safe-file-write-date and component-operation-time ;; shall also be parametrized by the plan, or by a second model object. @@ -246,7 +248,6 @@ the action of OPERATION on COMPONENT in the PLAN")) ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet (values t nil)))) - ;;;; Generic support for plan-traversal (defgeneric* plan-record-dependency (plan operation component)) diff --git a/test/script-support.lisp b/test/script-support.lisp index 6a56d512eb818bb22cf44094b381fccbbef52333..299a25d5990fc36dba283309e9717ddb7c45dfe1 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 + #:action-name #:in-plan-p #:test-source #:test-fasl #:resolve-output #:output-location #:quietly)) @@ -438,6 +439,9 @@ is bound, write a message and exit on an error. If `(apply (asym :register-system-definition) ',name :pathname ,*test-directory* :source-file nil ',rest)) +(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal)) + + ;; These are shorthands for interactive debugging of test scripts: (!a common-lisp-user::debug-asdf debug-asdf @@ -451,4 +455,7 @@ 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))|# + (let ((action-path (action-path (cons o c)))) (DBG :cas action-path 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) +;;; blah +)) +|# diff --git a/test/test1.script b/test/test1.script index 7c29cb8b68504edb97be973baafed4d182906720..e35548f8cb1931dc3f9bebe6b277768d210db238 100644 --- a/test/test1.script +++ b/test/test1.script @@ -2,46 +2,57 @@ (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) +(touch-file (test-source "test1.asd") :offset -3600) ;; touch test1.asd an hour ago. +(defparameter *date* (file-write-date (test-source "test1.asd"))) + +(touch-file (test-source "file1.lisp") :timestamp (+ *date* 100)) +(touch-file (test-source "file2.lisp") :timestamp (+ *date* 200)) +(assert-equal (file-write-date (test-source "file1.lisp")) (+ *date* 100)) +(assert-equal (file-write-date (test-source "file2.lisp")) (+ *date* 200)) (DBG "loading test1") -(asdf:load-system 'test1) +(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*)) +(defparameter *file1.out* (output-files 'compile-op '(test1 "file1"))) +(defparameter *file2.out* (output-files 'compile-op '(test1 "file2"))) +(assert-equal (first *file1.out*) (test-fasl "file1")) +(assert-equal (first *file2.out*) (test-fasl "file2")) -(assert-equal *file1* (first (output-files 'compile-op '("test1" "file1")))) +(assert-equal *date* (file-write-date (test-source "test1.asd"))) +(defparameter *then* (file-write-date (first *file2.out*))) +(assert-compare (< *date* *then*)) (DBG "test that it compiled" *date* *then*) -(assert (probe-file *file1*)) -(assert (probe-file *file2*)) +(dolist (f (append *file1.out* *file2.out*)) + (eval `(assert (probe-file ,f)))) (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 "now remove file2 that depends-on file1") +(dolist (f *file1.out*) (touch-file f :timestamp (+ *date* 500))) +(assert-equal (+ *date* 500) (file-write-date (first *file1.out*))) +(map () 'delete-file-if-exists *file2.out*) +(clear-system 'test1) (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*))) +;;(trace input-files asdf::compute-action-stamp) +(defparameter *plan* (nth-value 1 (operate 'load-op 'test1))) +(DBG "check that file1 is _not_ recompiled, but file2 is") +(assert (in-plan-p *plan* '(compile-op "test1" "file2"))) +(assert (not (in-plan-p *plan* '(compile-op "test1" "file1")))) + +(assert-equal (+ *date* 500) (file-write-date (first *file1.out*))) +(assert-compare (<= *then* (file-write-date (first *file2.out*)))) (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. +(defparameter *before* (file-write-date (first *file2.out*))) +(touch-file (test-source "file1.lisp") :timestamp (+ *date* 3000)) ;; touch file1 a minute ago. +(dolist (f *file2.out*) (touch-file f :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 :foo (file-write-date (first *file2.out*)) *before*) +(assert-compare (>= (file-write-date (first *file2.out*)) *before*)) + diff --git a/upgrade.lisp b/upgrade.lisp index d19058f700c691a5416c43f7072a3965af52dbc3..1eab736416c794d9163bdb2b00f5641a199c91ab 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -35,7 +35,7 @@ ;; "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.128") + (asdf-version "2.26.129") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version)) @@ -46,7 +46,7 @@ #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:component-self-dependencies - #:system-relative-pathname + #:system-relative-pathname #:resolve-location #:inherit-source-registry #:process-source-registry #:process-source-registry-directive #:source-file-type #:process-output-translations-directive diff --git a/version.lisp-expr b/version.lisp-expr index a2f774a8ca06f7d51a1976327fee7f9af5d9d514..3a86b41d28784f90776279c21b59d97cbbd75553 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.128" +"2.26.129"