From d8508de1f744ac3231db92e021ed2aba8fa3dc7f Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Fri, 18 Jan 2013 06:04:51 -0500
Subject: [PATCH] 2.26.114: import the deferred warnings support from POIU to
 ASDF-DRIVER.

Still not used by ASDF itself.

Also, don't use compile-file-pathname after all, it's a bad idea,
since we may be loading a .asd from within an eval-when during a compile-file,
but we won't be compiling the .asd.
---
 asdf.asd          |   2 +-
 defsystem.lisp    |  12 +--
 find-system.lisp  |   7 +-
 header.lisp       |   2 +-
 lisp-build.lisp   | 194 +++++++++++++++++++++++++++++++++-------------
 operate.lisp      |   3 +-
 plan.lisp         |  14 ++--
 upgrade.lisp      |   2 +-
 version.lisp-expr |   2 +-
 9 files changed, 162 insertions(+), 76 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 77e9deea..02d15b0a 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.113" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.114" ;; 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 generate-asdf))))
diff --git a/defsystem.lisp b/defsystem.lisp
index 40dcdb0a..69203612 100644
--- a/defsystem.lisp
+++ b/defsystem.lisp
@@ -22,18 +22,20 @@
   ;; the pathname of a system as follows:
   ;; 1. if the pathname argument is an pathname object (NOT a namestring),
   ;;    that is already an absolute pathname, return it.
-  ;; 2. otherwise, the directory containing the CURRENT-LISP-FILE-PATHNAME
+  ;; 2. otherwise, the directory containing the LOAD-PATHNAME
   ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
   ;;    if it is indeed available and an absolute pathname, then
   ;;    the PATHNAME argument is normalized to a relative pathname
   ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
   ;;    and merged into that DIRECTORY as per SUBPATHNAME.
+  ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
+  ;;    and may be from within the EVAL-WHEN of a file compilation.
   ;; If no absolute pathname was found, we return NIL.
   (check-type pathname (or null string pathname))
   (or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname))
-      (let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname))))
-        (when (absolute-pathname-p lisp-file-pathname)
-          (subpathname lisp-file-pathname pathname :type :directory)))))
+      (let* ((load-pathname (resolve-symlinks* (load-pathname))))
+        (when (absolute-pathname-p load-pathname)
+          (subpathname load-pathname pathname :type :directory)))))
 
 
 ;;; Component class
@@ -169,7 +171,7 @@
   ;; we also need to remember it in a special variable *systems-being-defined*.
   (with-system-definitions ()
     (let* ((name (coerce-name name))
-           (source-file (if sfp source-file (resolve-symlinks* (current-lisp-file-pathname))))
+           (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
            (registered (system-registered-p name))
            (registered! (if registered
                             (rplaca registered (safe-file-write-date source-file))
diff --git a/find-system.lisp b/find-system.lisp
index 2e15fecc..e50284c7 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -133,10 +133,9 @@ called with an object of type asdf:system."
 (cleanup-system-definition-search-functions)
 
 (defun* search-for-system-definition (system)
-  (with-pathname-defaults ()
-    (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
-          (cons 'find-system-if-being-defined
-                *system-definition-search-functions*))))
+  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
+        (cons 'find-system-if-being-defined
+              *system-definition-search-functions*)))
 
 (defvar *central-registry* nil
 "A list of 'system directory designators' ASDF uses to find systems.
diff --git a/header.lisp b/header.lisp
index 0489cb02..1d40043f 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.113: Another System Definition Facility.
+;;; This is ASDF 2.26.114: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/lisp-build.lisp b/lisp-build.lisp
index f2527bca..8e664de3 100644
--- a/lisp-build.lisp
+++ b/lisp-build.lisp
@@ -16,8 +16,13 @@
    #:get-optimization-settings #:proclaim-optimization-settings
    #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
    #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
+   #:reify-simple-sexp #:unreify-simple-sexp
+   #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
+   #:reset-deferred-warnings #:save-deferred-warnings
+   #:with-saved-deferred-warnings
    #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
-   #:current-lisp-file-pathname #:lispize-pathname #:compile-file-type #:call-around-hook
+   #:current-lisp-file-pathname #:load-pathname
+   #:lispize-pathname #:compile-file-type #:call-around-hook
    #:compile-file* #:compile-file-pathname*
    #:load* #:load-from-string #:combine-fasls)
   (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
@@ -108,55 +113,124 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
   "Run BODY where uninteresting compiler and additional loader conditions are muffled"
   `(call-with-muffled-loader-conditions #'(lambda () ,@body)))
 
-(defun* save-forward-references (forward-references)
-  ;; TODO: replace with stuff in POIU
+
+;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
+
+(defun reify-simple-sexp (sexp)
+  (etypecase sexp
+    (symbol (reify-symbol sexp))
+    ((or number character simple-string pathname) sexp)
+    (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
+(defun unreify-simple-sexp (sexp)
+  (etypecase sexp
+    ((or symbol number character simple-string pathname) sexp)
+    (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
+    ((simple-vector 2) (unreify-symbol sexp))))
+
+(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-count warning)
+   (mapcar
+    #'(lambda (frob)
+        ;; the lexenv slot can be ignored for reporting purposes
+        `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
+          :source ,(sb-c::compiler-error-context-source frob)
+          :original-source ,(sb-c::compiler-error-context-original-source frob)
+          :context ,(sb-c::compiler-error-context-context frob)
+          :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
+          :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
+          :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
+    (sb-c::undefined-warning-warnings warning))))
+
+(defun reify-deferred-warnings ()
+  #-sbcl nil
+  #+sbcl
+  (when sb-c::*in-compilation-unit*
+    ;; Try to send nothing through the pipe if nothing needs to be accumulated
+    `(,@(when sb-c::*undefined-warnings*
+          `((sb-c::*undefined-warnings*
+             ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
+      ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
+                              sb-c::*compiler-error-count*
+                              sb-c::*compiler-warning-count*
+                              sb-c::*compiler-style-warning-count*
+                              sb-c::*compiler-note-count*)
+              :for value = (symbol-value what)
+              :when (plusp value)
+                :collect `(,what . ,value)))))
+
+(defun unreify-deferred-warnings (constructor-list)
+  #-sbcl (declare (ignore constructor-list))
+  #+sbcl
+  (dolist (item constructor-list)
+    ;; 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.
+    (destructuring-bind (symbol . adjustment) item
+      (case symbol
+        ((sb-c::*undefined-warnings*)
+         (setf sb-c::*undefined-warnings*
+               (nconc (mapcan
+                       #'(lambda (stuff)
+                           (destructuring-bind (kind name count . rest) stuff
+                             (if (and (eq kind :function) (fboundp name))
+                                 nil
+                                 (list
+                                  (sb-c::make-undefined-warning
+                                   :name name
+                                   :kind kind
+                                   :count count
+                                   :warnings
+                                   (mapcar #'(lambda (x)
+                                               (apply #'sb-c::make-compiler-error-context x))
+                                           rest))))))
+                       adjustment)
+                      sb-c::*undefined-warnings*)))
+        (otherwise
+         (set symbol (+ (symbol-value symbol) adjustment)))))))
+
+(defun reset-deferred-warnings ()
+  #+sbcl
+  (when sb-c::*in-compilation-unit*
+    (setf sb-c::*undefined-warnings* nil
+          sb-c::*aborted-compilation-unit-count* 0
+          sb-c::*compiler-error-count* 0
+          sb-c::*compiler-warning-count* 0
+          sb-c::*compiler-style-warning-count* 0
+          sb-c::*compiler-note-count* 0)))
+
+(defun* save-deferred-warnings (warnings-file)
   "Save forward reference conditions so they may be issued at a latter time,
 possibly in a different process."
-  #+sbcl
-  (loop :for w :in sb-c::*undefined-warnings*
-    :for kind = (sb-c::undefined-warning-kind w) ; :function :variable :type
-    :for name = (sb-c::undefined-warning-name w)
-    :for symbol = (cond
-                    ((consp name)
-                     (unless (eq kind :function)
-                       (error "unrecognized warning ~S not a function?" w))
-                     (ecase (car name)
-                       ((setf)
-                        (assert (and (consp (cdr name)) (null (cddr name))) ())
-				  (setf kind :setf-function)
-                        (second name))
-                       ((sb-pcl::slot-accessor)
-                        (assert (eq :global (second name)))
-                        (assert (eq 'boundp (fourth name)))
-                        (assert (null (nthcdr 4 name)))
-                        (setf kind :sb-pcl-global-boundp-slot-accessor)
-                        (third name))))
-                    (t
-                     (assert (member kind '(:function :variable :type)) ())
-                     name))
-    :for symbol-name = (symbol-name symbol)
-    :for package-name = (package-name (symbol-package symbol))
-    :collect `(:undefined ,symbol-name ,package-name ,kind) :into undefined-warnings
-    :finally (setf *deferred-warnings* undefined-warnings
-                   sb-c::*undefined-warnings* nil))
-  (when forward-references
-    (with-open-file (s forward-references :direction :output :if-exists :supersede)
-      (write *deferred-warnings* :stream s :pretty t :readably t)
-      (terpri s))))
-
-(defun* call-with-asdf-compilation-unit (thunk &key forward-references)
-  (with-compilation-unit (:override t)
-    (let ((*deferred-warnings* ())
-          #+sbcl (sb-c::*undefined-warnings* nil))
-      (multiple-value-prog1
-          (with-muffled-compiler-conditions ()
-            (funcall thunk))
-        (save-forward-references forward-references)))))
-
-(defmacro with-asdf-compilation-unit ((&key forward-references) &body body)
-  "Like WITH-COMPILATION-UNIT, but saving forward-reference issues
-for processing later (possibly in a different process)."
-  `(call-with-xcvb-compilation-unit #'(lambda () ,@body) :forward-references ,forward-references))
+  (with-open-file (s warnings-file :direction :output :if-exists :supersede)
+    (if-let ((deferred-warnings (reify-deferred-warnings)))
+      (with-safe-io-syntax ()
+        (write deferred-warnings :stream s :pretty t :readably t)
+        (terpri s))))
+  (reset-deferred-warnings))
+
+(defun* call-with-saved-deferred-warnings (thunk warnings-file)
+  (if warnings-file
+      (with-compilation-unit (:override t)
+        (let ((*deferred-warnings* ())
+              #+sbcl (sb-c::*undefined-warnings* nil))
+          (multiple-value-prog1
+              (with-muffled-compiler-conditions ()
+                (funcall thunk))
+            (save-deferred-warnings warnings-file))))
+      (funcall thunk)))
+
+(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
+  "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
+and saves those warnings to the given file for latter use,
+possibly in a different process. Otherwise just run the BODY."
+  `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))
 
 
 ;;; from ASDF
@@ -164,6 +238,9 @@ for processing later (possibly in a different process)."
 (defun* current-lisp-file-pathname ()
   (or *compile-file-pathname* *load-pathname*))
 
+(defun* load-pathname ()
+  *load-pathname*)
+
 (defun* lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
 
@@ -177,7 +254,8 @@ for processing later (possibly in a different process)."
   (call-function (or hook 'funcall) function))
 
 (defun* compile-file* (input-file &rest keys
-                                  &key compile-check output-file #+(or ecl mkcl) object-file
+                                  &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
@@ -193,11 +271,12 @@ with appropriate implementation-dependent defaults,
 and if a failure (respectively warnings) are reported by COMPILE-FILE
 with consider it an error unless the respective behaviour flag
 is one of :SUCCESS :WARN :IGNORE.
+If WARNINGS-FILE is defined, deferred warnings are saved to that file.
 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-keys
-                    `(:compile-check
+                    `(:compile-check :warnings-file
                       #+gcl<2.7 ,@'(:external-format :print :verbose)) keys))
          (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
          #+ecl
@@ -211,12 +290,14 @@ it will filter them appropriately."
                (compile-file-pathname output-file :fasl-p nil)))
          (tmp-file (tmpize-pathname output-file)))
     (multiple-value-bind (output-truename warnings-p failure-p)
-        (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
-            #+ecl (apply 'compile-file input-file :output-file
-                         (if object-file
-                             (list* object-file :system-p t keywords)
-                             (list* output-file keywords)))
-            #+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords))
+        (with-saved-deferred-warnings (warnings-file)
+          (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
+              #+ecl (apply 'compile-file input-file :output-file
+                           (if object-file
+                               (list* object-file :system-p t keywords)
+                               (list* output-file keywords)))
+              #+mkcl (apply 'compile-file input-file
+                            :output-file object-file :fasl-p nil keywords)))
       (cond
         ((and output-truename
               (flet ((check-flag (flag behaviour)
@@ -301,3 +382,4 @@ it will filter them appropriately."
            (scm:concatenate-system output :fasls-to-concatenate))
       (loop :for f :in fasls :do (ignore-errors (delete-file f)))
       (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
+
diff --git a/operate.lisp b/operate.lisp
index 3d73f3be..1ca31be9 100644
--- a/operate.lisp
+++ b/operate.lisp
@@ -7,7 +7,8 @@
    :asdf/component :asdf/system :asdf/operation :asdf/action
    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
   (:export
-   #:operate #:oos #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
+   #:operate #:oos
+   #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
    #:build-system
    #:load-system #:load-systems #:compile-system #:test-system #:require-system
    #:*load-system-operation* #:module-provide-asdf
diff --git a/plan.lisp b/plan.lisp
index 2ed943b0..0cc484f1 100644
--- a/plan.lisp
+++ b/plan.lisp
@@ -7,12 +7,9 @@
    :asdf/component :asdf/system :asdf/find-system :asdf/find-component
    :asdf/operation :asdf/action)
   #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
-  (:intern #:planned-p #:index #:forced #:forced-not #:total-action-count
-           #:planned-action-count #:planned-output-action-count #:visited-actions
-           #:visiting-action-set #:visiting-action-list #:actions-r)
   (:export
    #:component-operation-time #:mark-operation-done
-   #:plan-traversal #:sequential-plan
+   #:plan-traversal #:sequential-plan #:*default-plan-class*
    #:planned-action-status #:plan-action-status #:action-already-done-p
    #:circular-dependency #:circular-dependency-actions
    #:node-for #:needed-in-image-p
@@ -22,7 +19,10 @@
    #:visit-dependencies #:compute-action-stamp #:traverse-action
    #:circular-dependency #:circular-dependency-actions
    #:call-while-visiting-action #:while-visiting-action
-   #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p))
+   #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
+   #:planned-p #:index #:forced #:forced-not #:total-action-count
+   #:planned-action-count #:planned-output-action-count #:visited-actions
+   #:visiting-action-set #:visiting-action-list #:actions-r))
 (in-package :asdf/plan)
 
 ;;;; Planned action status
@@ -316,9 +316,11 @@ processed in order by OPERATE."))
 (defgeneric* perform-plan (plan &key))
 (defgeneric* plan-operates-on-p (plan component))
 
+(defparameter *default-plan-class* 'sequential-plan)
+  
 (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
   (let ((plan (apply 'make-instance
-                     (or plan-class 'sequential-plan)
+                     (or plan-class *default-plan-class*)
                      :system (component-system c) (remove-key :plan-class keys))))
     (traverse-action plan o c t)
     (plan-actions plan)))
diff --git a/upgrade.lisp b/upgrade.lisp
index 76f38f3f..81b94789 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -45,7 +45,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.113")
+         (asdf-version "2.26.114")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 9fa3492c..4a80d397 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.26.113"
+"2.26.114"
-- 
GitLab