Commit 67d8d7df authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.129: adding warnings file support for CCL.

parent cab5dfa1
......@@ -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
......
......@@ -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))))
......
......@@ -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)
......
;; -*- 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>.
......
......@@ -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)))
#+(or clozure sbcl)
,@(let ((s (component-system c)))
(unless (builtin-system-p s) ; includes ASDF itself
`(,(make-pathname :type "sbcl-warnings" :defaults f)))))))
`(,(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)
......
......@@ -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
......
......@@ -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!
......
......@@ -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))
......
......@@ -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
))
|#
......@@ -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*))
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment