#: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)
(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
: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))))
: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)
;; -*- 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 <asdf-devel@common-lisp.net>.
(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 ()
: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))))))
(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)))
(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)
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)
#: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
(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)
(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
: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.
(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
(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)
;;;; 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
#: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
(: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!
(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.
;; 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))
#:assert-compare
#:assert-equal
#:leave-test #:def-test-system
+ #:action-name #:in-plan-p
#:test-source #:test-fasl #:resolve-output #:output-location
#:quietly))
`(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
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
+))
+|#
(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*))
+
;; "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))
#: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
common-lisp.net / projects/asdf/asdf.git / commitdiff
