2.26.129: adding warnings file support for CCL.
authorFrancois-Rene Rideau <tunes@google.com>
Mon, 21 Jan 2013 01:23:19 +0000 (20:23 -0500)
committerFrancois-Rene Rideau <tunes@google.com>
Mon, 21 Jan 2013 01:23:19 +0000 (20:23 -0500)
12 files changed:
action.lisp
asdf.asd
configuration.lisp
header.lisp
lisp-action.lisp
lisp-build.lisp
os.lisp
plan.lisp
test/script-support.lisp
test/test1.script
upgrade.lisp
version.lisp-expr

index 0a71367..1555c23 100644 (file)
@@ -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)
 
 (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
index 4eb5a40..1d8e18a 100644 (file)
--- 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))))
index 010ab08..57672cb 100644 (file)
@@ -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)
index c0d93d1..507b4f6 100644 (file)
@@ -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 <asdf-devel@common-lisp.net>.
index 30d7e61..b982ad1 100644 (file)
@@ -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))))))
          (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)
index 93e23a4..4f31d58 100644 (file)
@@ -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 20dd04f..0bef949 100644 (file)
--- 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!
index 73eb951..8192f2f 100644 (file)
--- 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))
index 6a56d51..299a25d 100644 (file)
@@ -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
+))
+|#
index 7c29cb8..e35548f 100644 (file)
@@ -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*))
+
index d19058f..1eab736 100644 (file)
@@ -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
index a2f774a..3a86b41 100644 (file)
@@ -1 +1 @@
-"2.26.128"
+"2.26.129"