From 3aa35aa347a2aad3e9beb4ebc2a948bd9842e184 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Fri, 11 Jan 2013 11:33:46 -0500
Subject: [PATCH] 2.26.76: export bork, shuffle some bits, fix some tests and
 asds

---
 Makefile           |  16 ++-
 asdf-driver.asd    |   2 +-
 asdf.asd           |   2 +-
 compatibility.lisp |   6 +-
 generate-asdf.asd  |   3 +-
 header.lisp        |   2 +-
 lisp-build.lisp    | 242 ++++++++++++++++++++++++++++++++-------------
 test/test3.script  |   4 +-
 upgrade.lisp       |   2 +-
 9 files changed, 203 insertions(+), 76 deletions(-)

diff --git a/Makefile b/Makefile
index 29bc7202..34d2417c 100644
--- a/Makefile
+++ b/Makefile
@@ -51,9 +51,21 @@ archive-copy: archive build/asdf.lisp
 	${MAKE} push
 	git checkout master
 
+driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp upgrade.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp
+asdf_lisp := component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
+
 build/asdf.lisp: $(wildcard *.lisp)
 	mkdir -p build
-	cat header.lisp package.lisp compatibility.lisp utility.lisp upgrade.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp > $@
+	cat $(driver_lisp) $(asdf_lisp) > $@
+
+wc:
+	wc $(driver_lisp) $(asdf_lisp) | sort -n
+
+wc-driver:
+	wc $(driver_lisp)
+
+wc-asdf:
+	wc $(asdf_lisp)
 
 push:
 	git status
@@ -211,7 +223,7 @@ release: TODO test-all test-on-other-machines-too debian-changelog debian-packag
 	test-all test-all-lisps test-all-noupgrade \
 	debian-package release \
 	replace-sbcl-asdf replace-ccl-asdf \
-	fix-local-git-tags fix-remote-git-tags
+	fix-local-git-tags fix-remote-git-tags wc wc-driver wc-asdf
 
 # RELEASE checklist:
 # make test-all
diff --git a/asdf-driver.asd b/asdf-driver.asd
index 1cc19f64..6b240de4 100644
--- a/asdf-driver.asd
+++ b/asdf-driver.asd
@@ -15,4 +15,4 @@ that you can't portably construct a complete program without using them."
    (:file "os" :depends-on ("pathname" "stream"))
    (:file "image" :depends-on ("os"))
    (:file "run-program" :depends-on ("os"))
-   (:file "lisp-build" :depends-on ("pathname"))))
+   (:file "lisp-build" :depends-on ("image"))))
diff --git a/asdf.asd b/asdf.asd
index e0ec4212..9cfbb43c 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.75" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.76" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components ((:module "build" :components ((:file "asdf")))))
 
diff --git a/compatibility.lisp b/compatibility.lisp
index fc906df8..f86053ba 100644
--- a/compatibility.lisp
+++ b/compatibility.lisp
@@ -55,7 +55,11 @@
                  (< system::*gcl-minor-version* 7)))
     (shadow 'type-of :asdf/compatibility)
     (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
-    (pushnew :gcl<2.7 *features*)))
+    (pushnew :gcl<2.7 *features*))
+  (unless (member :ansi-cl *features*)
+    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
+  (setf compiler::*compiler-default-type* (pathname "")
+        compiler::*lsp-ext* ""))
 
 #+mkcl
 (eval-when (:load-toplevel :compile-toplevel :execute)
diff --git a/generate-asdf.asd b/generate-asdf.asd
index 8500b594..d0522b04 100644
--- a/generate-asdf.asd
+++ b/generate-asdf.asd
@@ -8,8 +8,9 @@
   :class :concatenated-source-system
   ;; :include-dependencies t
   :translate-output-p nil
-  :concatenated-source-file "tmp/generated-asdf.lisp"
+  :concatenated-source-file "build/asdf.lisp"
   :serial t
+  :depends-on (:asdf-driver)
   :components
   ((:file "upgrade")
    (:file "component")
diff --git a/header.lisp b/header.lisp
index b645a181..3b35dd39 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.75: Another System Definition Facility.
+;;; This is ASDF 2.26.76: 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 c742bcf5..fd9652d0 100644
--- a/lisp-build.lisp
+++ b/lisp-build.lisp
@@ -3,7 +3,7 @@
 
 (asdf/package:define-package :asdf/lisp-build
   (:recycle :asdf/lisp-build :asdf)
-  (:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
+  (:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/image)
   (:export
    #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
    #:*compile-file-function* #:compile-file* #:compile-file-pathname* #:*output-translation-hook*
@@ -32,6 +32,181 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
 
 (defvar *output-translation-hook* 'identity)
 
+
+;;; Optimization settings
+
+(defvar *optimization-settings* nil)
+(defvar *previous-optimization-settings* nil)
+(defun get-optimization-settings ()
+  "Get current compiler optimization settings, ready to PROCLAIM again"
+  (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
+    #-(or clisp clozure cmu ecl sbcl scl)
+    (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
+    #.`(loop :for x :in settings
+         ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
+               #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
+               #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
+         :for y = (or #+clisp (gethash x system::*optimize*)
+                      #+(or clozure ecl) (symbol-value v)
+                      #+(or cmu scl) (funcall f c::*default-cookie*)
+                      #+sbcl (cdr (assoc x sb-c::*policy*)))
+         :when y :collect (list x y))))
+(defun proclaim-optimization-settings ()
+  "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
+  (proclaim `(optimize ,@*optimization-settings*))
+  (let ((settings (get-optimization-settings)))
+    (unless (equal *previous-optimization-settings* settings)
+      (setf *previous-optimization-settings* settings))))
+
+
+;;; Condition control
+
+(defvar *uninteresting-conditions*
+  (append
+   #+sbcl
+   '(sb-c::simple-compiler-note
+     "&OPTIONAL and &KEY found in the same lambda list: ~S"
+     sb-int:package-at-variance
+     sb-kernel:uninteresting-redefinition
+     ;; the below four are controversial to include here;
+     ;; however there are issues with the asdf upgrade if they are not present
+     sb-kernel:redefinition-with-defun
+     sb-kernel:redefinition-with-defgeneric
+     sb-kernel:redefinition-with-defmethod
+     sb-kernel::redefinition-with-defmacro ; not exported by old SBCLs
+     sb-kernel:undefined-alien-style-warning
+     sb-ext:implicit-generic-function-warning
+     sb-kernel:lexical-environment-too-complex
+     "Couldn't grovel for ~A (unknown to the C compiler).")
+   ;;#+clozure '(ccl:compiler-warning)
+   '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.") ;; from closer2mop
+   )
+  "Conditions that may be skipped. type symbols, predicates or strings")
+
+(defvar *uninteresting-load-conditions*
+  (append
+   '("Overwriting already existing readtable ~S." ;; from named-readtables
+     #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
+   #+clisp '(clos::simple-gf-replacing-method-warning))
+  "Additional conditions that may be skipped while loading. type symbols, predicates or strings")
+
+(defvar *fatal-conditions*
+  '(serious-condition)
+  "Conditions to be considered fatal during compilation.")
+
+(defvar *deferred-warnings* ()
+  "Warnings the handling of which is deferred until the end of the compilation unit")
+
+;;;; ----- Filtering conditions while building -----
+
+(defun match-condition-p (x condition)
+  "Compare received CONDITION to some pattern X:
+a symbol naming a condition class,
+a simple vector of length 2, arguments to find-symbol* with result as above,
+or a string describing the format-control of a simple-condition."
+  (etypecase x
+    (symbol (typep condition x))
+    ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
+    (function (funcall x condition))
+    (string (and (typep condition 'simple-condition)
+                 #+(or clozure cmu scl) ; Note: on SBCL, always bound, and testing triggers warning
+		 (slot-boundp condition
+			      #+clozure 'ccl::format-control
+			      #+(or cmu scl) 'conditions::format-control)
+                 (ignore-errors (equal (simple-condition-format-control condition) x))))))
+
+(defun match-any-condition-p (condition conditions)
+  "match CONDITION against any of the patterns of CONDITIONS supplied"
+  (loop :for x :in conditions :thereis (match-condition-p x condition)))
+
+(defun uninteresting-condition-p (condition)
+  "match CONDITION against any of the patterns of *UNINTERESTING-CONDITIONS*"
+  (match-any-condition-p condition *uninteresting-conditions*))
+
+(defun fatal-condition-p (condition)
+  "match CONDITION against any of the patterns of *FATAL-CONDITIONS*"
+  (match-any-condition-p condition *fatal-conditions*))
+
+(defun call-with-controlled-compiler-conditions (thunk)
+  (handler-bind
+      ((t
+        #'(lambda (condition)
+            ;; TODO: do something magic for undefined-function,
+            ;; save all of aside, and reconcile in the end of the virtual compilation-unit.
+            (cond
+              ((uninteresting-condition-p condition)
+               (muffle-warning condition))
+              ((fatal-condition-p condition)
+               (bork condition))))))
+    (funcall thunk)))
+
+(defmacro with-controlled-compiler-conditions ((&optional) &body body)
+  "Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS*"
+  `(call-with-controlled-compiler-conditions #'(lambda () ,@body)))
+
+(defun call-with-controlled-loader-conditions (thunk)
+  (let ((*uninteresting-conditions*
+         (append
+          *uninteresting-load-conditions*
+          *uninteresting-conditions*)))
+    (call-with-controlled-compiler-conditions thunk)))
+
+(defmacro with-controlled-loader-conditions ((&optional) &body body)
+  "Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS* plus a few others that don't matter at load-time."
+  `(call-with-controlled-loader-conditions #'(lambda () ,@body)))
+
+(defun save-forward-references (forward-references)
+  "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-controlled-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))
+
+
+;;; from ASDF
+
 (defun* lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
 
@@ -141,68 +316,3 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
       (loop :for f :in fasls :do (ignore-errors (delete-file f)))
       (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
 
-
-;;; Optimization settings
-
-(defvar *optimization-settings* nil)
-(defvar *previous-optimization-settings* nil)
-(defun get-optimization-settings ()
-  "Get current compiler optimization settings, ready to PROCLAIM again"
-  (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
-    #-(or clisp clozure cmu ecl sbcl scl)
-    (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
-    #.`(loop :for x :in settings
-         ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
-               #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
-               #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
-         :for y = (or #+clisp (gethash x system::*optimize*)
-                      #+(or clozure ecl) (symbol-value v)
-                      #+(or cmu scl) (funcall f c::*default-cookie*)
-                      #+sbcl (cdr (assoc x sb-c::*policy*)))
-         :when y :collect (list x y))))
-(defun proclaim-optimization-settings ()
-  "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
-  (proclaim `(optimize ,@*optimization-settings*))
-  (let ((settings (get-optimization-settings)))
-    (unless (equal *previous-optimization-settings* settings)
-      (setf *previous-optimization-settings* settings))))
-
-
-;;; Condition control
-
-(defvar *uninteresting-conditions*
-  (append
-   #+sbcl
-   '(sb-c::simple-compiler-note
-     "&OPTIONAL and &KEY found in the same lambda list: ~S"
-     sb-int:package-at-variance
-     sb-kernel:uninteresting-redefinition
-     ;; the below four are controversial to include here;
-     ;; however there are issues with the asdf upgrade if they are not present
-     sb-kernel:redefinition-with-defun
-     sb-kernel:redefinition-with-defgeneric
-     sb-kernel:redefinition-with-defmethod
-     sb-kernel::redefinition-with-defmacro ; not exported by old SBCLs
-     sb-kernel:undefined-alien-style-warning
-     sb-ext:implicit-generic-function-warning
-     sb-kernel:lexical-environment-too-complex
-     "Couldn't grovel for ~A (unknown to the C compiler).")
-   ;;#+clozure '(ccl:compiler-warning)
-   '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.") ;; from closer2mop
-   )
-  "Conditions that may be skipped. type symbols, predicates or strings")
-
-(defvar *uninteresting-load-conditions*
-  (append
-   '("Overwriting already existing readtable ~S." ;; from named-readtables
-     #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
-   #+clisp '(clos::simple-gf-replacing-method-warning))
-  "Additional conditions that may be skipped while loading. type symbols, predicates or strings")
-
-(defvar *fatal-conditions*
-  '(serious-condition)
-  "Conditions to be considered fatal during compilation.")
-
-(defvar *deferred-warnings* ()
-  "Warnings the handling of which is deferred until the end of the compilation unit")
-
diff --git a/test/test3.script b/test/test3.script
index 44c28a71..ceb240dc 100644
--- a/test/test3.script
+++ b/test/test3.script
@@ -4,8 +4,8 @@
 (quit-on-error
  (let* ((fasl1 (asdf:compile-file-pathname* (truename "file1.lisp")))
         (fasl2 (asdf:compile-file-pathname* (truename "file2.lisp")))
-        (ns1 (native-namestring fasl1))
-        (ns2 (native-namestring fasl2)))
+        (ns1 (asdf::native-namestring fasl1))
+        (ns2 (asdf::native-namestring fasl2)))
    (asdf:run-shell-command "rm -f ~A ~A" ns1 ns2)
    (setf asdf:*central-registry* '(*default-pathname-defaults*))
    (DBG "should load file1 but not file2")
diff --git a/upgrade.lisp b/upgrade.lisp
index 1e5b43e4..3b1d3add 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -31,7 +31,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.75")
+         (asdf-version "2.26.76")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
-- 
GitLab