From fea63928f41f070ed66df2076ce0a176f7320349 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 14 Feb 2013 03:48:40 +0100
Subject: [PATCH] 2.28.9: implement deferred-warnings support for CMUCL (and
 SCL?)

Low-level code provided by Raymond Toy.
---
 asdf.asd                           |  2 +-
 header.lisp                        |  2 +-
 lisp-action.lisp                   |  4 +-
 lisp-build.lisp                    | 70 +++++++++++++++++++++++++++++-
 test/test-deferred-warnings.script | 19 ++++++--
 upgrade.lisp                       |  2 +-
 version.lisp-expr                  |  2 +-
 7 files changed, 90 insertions(+), 11 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 279ee54c..198d145f 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -74,7 +74,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.28.8" ;; to be automatically updated by make bump-version
+  :version "2.28.9" ;; to be automatically updated by make bump-version
   :depends-on ()
   #+asdf3 :encoding #+asdf3 :utf-8
   ;; For most purposes, asdf itself specially counts as a builtin system.
diff --git a/header.lisp b/header.lisp
index 7eb3bde3..9434d3d3 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.28.8: Another System Definition Facility.
+;;; This is ASDF 2.28.9: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/lisp-action.lisp b/lisp-action.lisp
index bfd5d482..1945d817 100644
--- a/lisp-action.lisp
+++ b/lisp-action.lisp
@@ -90,7 +90,7 @@
                &optional
                  #+clisp lib-file
                  #+(or ecl mkcl) object-file
-                 #+(or clozure sbcl) warnings-file) outputs
+                 #+(or cmu clozure sbcl scl) warnings-file) outputs
             (call-with-around-compile-hook
              c #'(lambda (&rest flags)
                    (with-muffled-compiler-conditions ()
@@ -100,7 +100,7 @@
                             (append
                              #+clisp (list :lib-file lib-file)
                              #+(or ecl mkcl) (list :object-file object-file)
-                             #+(or clozure sbcl) (list :warnings-file warnings-file)
+                             #+(or cmu clozure sbcl scl) (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))))))
diff --git a/lisp-build.lisp b/lisp-build.lisp
index 139670bb..627e5b9b 100644
--- a/lisp-build.lisp
+++ b/lisp-build.lisp
@@ -228,6 +228,26 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
                         :warning-type warning-type
                         :args (unreify-simple-sexp args)))))
 
+  #+(or cmu scl)
+  (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"
+    (list*
+     (c::undefined-warning-kind warning)
+     (c::undefined-warning-name warning)
+     (c::undefined-warning-count warning)
+     (mapcar
+      #'(lambda (frob)
+          ;; the lexenv slot can be ignored for reporting purposes
+          `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
+            :source ,(c::compiler-error-context-source frob)
+            :original-source ,(c::compiler-error-context-original-source frob)
+            :context ,(c::compiler-error-context-context frob)
+            :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
+            :file-position ,(c::compiler-error-context-file-position frob) ; an integer
+            :original-source-path ,(c::compiler-error-context-original-source-path frob)))
+      (c::undefined-warning-warnings warning))))
+
   #+sbcl
   (defun reify-undefined-warning (warning)
     ;; Extracting undefined-warnings from the compilation-unit
@@ -257,6 +277,18 @@ WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings sup
             (if-let (dw ccl::*outstanding-deferred-warnings*)
               (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
                 (ccl::deferred-warnings.warnings mdw))))
+    #+(or cmu scl)
+    (when lisp::*in-compilation-unit*
+      ;; Try to send nothing through the pipe if nothing needs to be accumulated
+      `(,@(when c::*undefined-warnings*
+            `((c::*undefined-warnings*
+               ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
+        ,@(loop :for what :in '(c::*compiler-error-count*
+                                c::*compiler-warning-count*
+                                c::*compiler-note-count*)
+                :for value = (symbol-value what)
+                :when (plusp value)
+                  :collect `(,what . ,value))))
     #+sbcl
     (when sb-c::*in-compilation-unit*
       ;; Try to send nothing through the pipe if nothing needs to be accumulated
@@ -284,6 +316,32 @@ One of three functions required for deferred-warnings support in ASDF."
                   (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
       (appendf (ccl::deferred-warnings.warnings dw)
                (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
+    #+(or cmu scl)
+    (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.
+      (destructuring-bind (symbol . adjustment) item
+        (case symbol
+          ((c::*undefined-warnings*)
+           (setf c::*undefined-warnings*
+                 (nconc (mapcan
+                         #'(lambda (stuff)
+                             (destructuring-bind (kind name count . rest) stuff
+                               (unless (case kind (:function (fboundp name)))
+                                 (list
+                                  (c::make-undefined-warning
+                                   :name name
+                                   :kind kind
+                                   :count count
+                                   :warnings
+                                   (mapcar #'(lambda (x)
+                                               (apply #'c::make-compiler-error-context x))
+                                           rest))))))
+                         adjustment)
+                        c::*undefined-warnings*)))
+          (otherwise
+           (set symbol (+ (symbol-value symbol) adjustment))))))
     #+sbcl
     (dolist (item reified-deferred-warnings)
       ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
@@ -318,6 +376,12 @@ One of three functions required for deferred-warnings support in ASDF."
     (if-let (dw ccl::*outstanding-deferred-warnings*)
       (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
         (setf (ccl::deferred-warnings.warnings mdw) nil)))
+    #+(or cmu scl)
+    (when lisp::*in-compilation-unit*
+      (setf c::*undefined-warnings* nil
+            c::*compiler-error-count* 0
+            c::*compiler-warning-count* 0
+            c::*compiler-note-count* 0))
     #+sbcl
     (when sb-c::*in-compilation-unit*
       (setf sb-c::*undefined-warnings* nil
@@ -339,8 +403,10 @@ possibly in a different process."
 
   (defun warnings-file-type (&optional implementation-type)
     (case (or implementation-type *implementation-type*)
-      (:sbcl "sbcl-warnings")
-      ((:clozure :ccl) "ccl-warnings")))
+      ((:cmu :cmucl) "cmucl-warnings")
+      ((:sbcl) "sbcl-warnings")
+      ((:clozure :ccl) "ccl-warnings")
+      ((:scl) "scl-warnings")))
 
   (defvar *warnings-file-type* (warnings-file-type)
     "Type for warnings files")
diff --git a/test/test-deferred-warnings.script b/test/test-deferred-warnings.script
index f8e3ab8d..2687d1c8 100644
--- a/test/test-deferred-warnings.script
+++ b/test/test-deferred-warnings.script
@@ -5,14 +5,27 @@
   :serial t
   :components ((:file "undefined-function")
                (:file "file1")))
+(DBG :tdw0 *compile-file-warnings-behaviour*)
 (assert
  (handler-case
      (let ((*compile-file-warnings-behaviour* :ignore))
        (load-system :test-deferred-warnings :force t)
        t)
-   (compile-file-error () nil)))
+   (error (c)
+     (DBG :cfwbi c)
+     nil)))
 
-#+(or clozure sbcl)
+(DBG :tdw1 *warnings-file-type*)
+(assert
+ (handler-case
+     (let ((*warnings-file-type* nil))
+       (load-system :test-deferred-warnings :force t)
+       t)
+   (error ()
+     (DBG :wftn c)
+     nil)))
+
+#+(or clozure cmu sbcl scl)
 (assert
  (handler-case
      (let ((*compile-file-warnings-behaviour* :error))
@@ -20,7 +33,7 @@
        nil)
    (compile-warned-error () t)))
 
-#+(or clozure sbcl)
+#+(or clozure cmu sbcl scl)
 (assert
  (handler-case
      (let ((*compile-file-warnings-behaviour* :error))
diff --git a/upgrade.lisp b/upgrade.lisp
index 47a8837b..5fc3b9d6 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
-         (asdf-version "2.28.8")
+         (asdf-version "2.28.9")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
diff --git a/version.lisp-expr b/version.lisp-expr
index c7114f1c..ade6f928 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.28.8"
+"2.28.9"
-- 
GitLab