2.26.95: more frobbing of the runtime support
authorFrancois-Rene Rideau <tunes@google.com>
Mon, 14 Jan 2013 19:07:07 +0000 (14:07 -0500)
committerFrancois-Rene Rideau <tunes@google.com>
Mon, 14 Jan 2013 19:07:07 +0000 (14:07 -0500)
Settle on "restore-image" and "dump-image" for our API names.
Unbreak match-condition-p and move it to utility,
give static scoping to the generic muffler,
rename the compiler and loader mufflers.
Fix with-input.
Remove crud from script-support.

18 files changed:
asdf.asd
bin/bump-version
configuration.lisp
find-system.lisp
header.lisp
image.lisp
lisp-action.lisp
lisp-build.lisp
output-translations.lisp
package.lisp
plan.lisp
source-registry.lisp
stream.lisp
test/script-support.lisp
test/test-compile-file-failure.script
upgrade.lisp
utility.lisp
version.lisp-expr

index 46b77b1..53864ac 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.94" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.95" ;; 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))))
index 03ac3ca..d3902c6 100755 (executable)
@@ -5,15 +5,15 @@
 (setf *load-verbose* nil *load-print* nil
       *compile-verbose* nil *compile-print* nil)
 
-(format t "Loading ASDF... ~%")
+(format t "Loading your implementation's ASDF... ~%")
 (require :asdf)
 (in-package :asdf)
 #-asdf2 (error "Not ASDF2, you lose!")
 (format t "Initializing the source registry... ~%")
 (initialize-source-registry)
-(format t "Making sure that's the latest... ~%")
+(format t "Upgrading to the latest ASDF... ~%")
 (upgrade-asdf)
-(format t "Now load some dependencies... ~%")
+(format t "Now loading some dependencies... ~%")
 (load-systems :cl-ppcre :xcvb-utils)
 
 (in-package :xcvb-utils)
@@ -22,7 +22,7 @@
 (asdf-debug)
 
 (DBG "There we are!")
-(resume-image)
+(restore-image)
 
 (defun afile (x)
   (asdf:system-relative-pathname :asdf x))
index 5da2e79..d0ad6c0 100644 (file)
@@ -12,7 +12,7 @@
    #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
    #:configuration-inheritance-directive-p
    #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
-   #:*clear-configuration-hook* #:clear-configuration
+   #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
    #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
    #:resolve-relative-location-component #:resolve-absolute-location-component))
 (in-package :asdf/configuration)
@@ -277,6 +277,9 @@ Please remove it from your ASDF configuration"))
 
 (defvar *clear-configuration-hook* '())
 
+(defun* register-clear-configuration-hook (hook-function &optional call-now-p)
+  (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
+
 (defun* clear-configuration ()
   (call-functions *clear-configuration-hook*))
 
index 80e225e..a4096d2 100644 (file)
@@ -251,7 +251,7 @@ Going forward, we recommend new users should be using the source-registry.
                    (external-format (encoding-external-format (detect-encoding pathname))))
                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
                              pathname package)
-               (with-controlled-loader-conditions ()
+               (with-muffled-loader-conditions ()
                  (load* pathname :external-format external-format))))
         (delete-package package)))))
 
index 239714b..7210b2f 100644 (file)
@@ -1,5 +1,5 @@
 ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.94: Another System Definition Facility.
+;;; This is ASDF 2.26.95: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
index 0658c7b..1cfad50 100644 (file)
@@ -5,40 +5,50 @@
   (:recycle :asdf/image :xcvb-driver)
   (:use :common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
   (:export
-   #:*dumped* #:raw-command-line-arguments #:*command-line-arguments*
+   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
    #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
-   #:*debugging* #:*post-image-restart* #:*entry-point*
+   #:*lisp-interaction*
+   #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
+   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
+   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
+   #:*image-postlude* #:*image-dump-hook*
    #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
-   #:bork #:with-coded-exit #:shell-boolean
-   #:register-image-resume-hook #:register-image-dump-hook
-   #:call-image-resume-hook #:call-image-dump-hook
-   #:initialize-asdf-utilities
-   #:resume-image #:run-resumed-image #:dump-image 
+   #:shell-boolean-exit
+   #:register-image-restore-hook #:register-image-dump-hook
+   #:call-image-restore-hook #:call-image-dump-hook
+   #:initialize-asdf-utilities #:restore-image #:dump-image
 ))
 (in-package :asdf/image)
 
-(defvar *debugging* nil
-  "Shall we print extra debugging information?")
+(defvar *lisp-interaction* t
+  "Is this an interactive Lisp environment, or is it batch processing?")
 
 (defvar *command-line-arguments* nil
   "Command-line arguments")
 
-(defvar *dumped* nil
+(defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
   "Is this a dumped image? As a standalone executable?")
 
-(defvar *image-resume-hook* nil
-  "Functions to call (in reverse order) when the image is resumed")
+(defvar *image-restore-hook* nil
+  "Functions to call (in reverse order) when the image is restored")
 
-(defvar *image-dump-hook* nil
-  "Functions to call (in order) when before an image is dumped")
+(defvar *image-prelude* nil
+  "a form to evaluate, or string containing forms to read and evaluate
+when the image is restarted, but before the entry point is called.")
+
+(defvar *image-entry-point* nil
+  "a function with which to restart the dumped image when execution is restored from it.")
 
-(defvar *post-image-restart* nil
-  "a string containing forms to read and evaluate when the image is restarted,
-but before the entry point is called.")
+(defvar *image-postlude* nil
+  "a form to evaluate, or string containing forms to read and evaluate
+before the image dump hooks are called and before the image is dumped.")
 
-(defvar *entry-point* nil
-  "a function with which to restart the dumped image when execution is resumed from it.")
+(defvar *image-dump-hook* nil
+  "Functions to call (in order) when before an image is dumped")
 
+(defvar *fatal-conditions* '(error)
+  "conditions that cause the Lisp image to enter the debugger if interactive,
+or to die if not interactive")
 
 
 ;;; Exiting properly or im-
@@ -133,40 +143,41 @@ This is designed to abstract away the implementation specific quit forms."
     (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
                   condition)))
 
-(defun* bork (condition)
-  "Depending on whether *DEBUGGING* is set, enter debugger or die"
-  (safe-format! *stderr* "~&BORK:~%~A~%" condition)
+(defun fatal-condition-p (condition)
+  (match-any-condition-p condition *fatal-conditions*))
+
+(defun* handle-fatal-condition (condition)
+  "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
   (cond
-    (*debugging*
+    (*lisp-interaction*
      (invoke-debugger condition))
     (t
+     (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
      (print-condition-backtrace condition :stream *stderr*)
      (die 99 "~A" condition))))
 
-(defun* call-with-coded-exit (thunk)
-  (handler-bind ((error 'bork))
-    (funcall thunk)
-    (quit 0)))
+(defun* call-with-fatal-condition-handler (thunk)
+  (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
+    (funcall thunk)))
 
-(defmacro with-coded-exit ((&optional) &body body)
-  "Run BODY, BORKing on error and otherwise exiting with a success status"
-  `(call-with-coded-exit #'(lambda () ,@body)))
+(defmacro with-fatal-condition-handler ((&optional) &body body)
+  `(call-with-fatal-condition-handler #'(lambda () ,@body)))
 
-(defun* shell-boolean (x)
+(defun* shell-boolean-exit (x)
   "Quit with a return code that is 0 iff argument X is true"
   (quit (if x 0 1)))
 
 
-;;; Using hooks
+;;; Using image hooks
 
-(defun* register-image-resume-hook (hook &optional (now t))
-  (register-hook-function '*image-resume-hook* hook now))
+(defun* register-image-restore-hook (hook &optional (call-now-p t))
+  (register-hook-function '*image-restore-hook* hook call-now-p))
 
-(defun* register-image-dump-hook (hook &optional (now nil))
-  (register-hook-function '*image-dump-hook* hook now))
+(defun* register-image-dump-hook (hook &optional (call-now-p nil))
+  (register-hook-function '*image-dump-hook* hook call-now-p))
 
-(defun* call-image-resume-hook ()
-  (call-functions (reverse *image-resume-hook*)))
+(defun* call-image-restore-hook ()
+  (call-functions (reverse *image-restore-hook*)))
 
 (defun* call-image-dump-hook ()
   (call-functions *image-dump-hook*))
@@ -197,7 +208,7 @@ if we are not called from a directly executable image dumped by XCVB."
   #-abcl
   (let* (#-(or sbcl allegro)
         (arguments
-         (if (eq *dumped* :executable)
+         (if (eq *image-dumped-p* :executable)
              arguments
              (member "--" arguments :test 'string-equal))))
     (rest arguments)))
@@ -205,37 +216,41 @@ if we are not called from a directly executable image dumped by XCVB."
 (defun setup-command-line-arguments ()
   (setf *command-line-arguments* (command-line-arguments)))
 
-(defun* resume-image (&key (post-image-restart *post-image-restart*)
-                           (entry-point *entry-point*)
-                           (image-resume-hook *image-resume-hook*))
-  (call-functions image-resume-hook)
-  (when post-image-restart
-    (with-safe-io-syntax ()
-      (let ((*read-eval* t))
-        (eval-input post-image-restart))))
-  (when entry-point
-    (apply entry-point *command-line-arguments*)))
-
-(defun* run-resumed-image ()
-  (with-coded-exit ()
-    (let ((ret (resume-image)))
-      (if (typep ret 'integer)
-          (quit ret)
-          (quit 99)))))
+(defun* restore-image (&key
+                       ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
+                       ((:restore-hook *image-restore-hook*) *image-restore-hook*)
+                       ((:prelude *image-prelude*) *image-prelude*)
+                       ((:entry-point *image-entry-point*) *image-entry-point*)
+                       ((:package *package*) *package*))
+  (with-fatal-condition-handler ()
+    (call-image-restore-hook)
+    (when *image-prelude*
+      (with-safe-io-syntax (:package *package*)
+        (let ((*read-eval* t))
+          (eval-text *image-prelude*))))
+    (let ((results (multiple-value-list
+                    (if *image-entry-point*
+                        (apply *image-entry-point* *command-line-arguments*)
+                        t))))
+      (if *lisp-interaction*
+          (apply 'values results)
+          (shell-boolean-exit (first results))))))
 
 
 ;;; Dumping an image
 
 #-(or ecl mkcl)
-(defun* dump-image (filename &key output-name executable pre-image-dump post-image-restart entry-point package)
-  (declare (ignorable filename output-name executable pre-image-dump post-image-restart entry-point))
-  (setf *dumped* (if executable :executable t))
-  (setf *package* (find-package (or package :cl-user)))
-  (with-safe-io-syntax ()
-    (let ((*read-eval* t))
-      (when pre-image-dump (eval-input pre-image-dump))
-      (setf *entry-point* (when entry-point (ensure-function entry-point)))
-      (when post-image-restart (setf *post-image-restart* post-image-restart))))
+(defun* dump-image (filename &key output-name executable
+                             ((:postlude *image-postlude*) *image-postlude*)
+                             ((:dump-hook *image-dump-hook*) *image-dump-hook*)
+                             ((:package *package*) *package*))
+  (declare (ignorable filename output-name executable))
+  (setf *image-dumped-p* (if executable :executable t))
+  (when *image-postlude*
+    (with-safe-io-syntax ()
+      (let ((*read-eval* t))
+        (eval-text *image-postlude*))))
+  (call-image-dump-hook)
   #-(or clisp clozure cmu lispworks sbcl)
   (when executable
     (error "Dumping an executable is not supported on this implementation! Aborting."))
@@ -251,28 +266,25 @@ if we are not called from a directly executable image dumped by XCVB."
    :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
    (when executable
      (list
-      :norc t
-      :script nil
-      :init-function #'run-resumed-image
       ;; :parse-options nil ;--- requires a non-standard patch to clisp.
-      )))
+      :norc t :script nil :init-function #'restore-image)))
   #+clozure
   (ccl:save-application filename :prepend-kernel t
-                        :toplevel-function (when executable #'run-resumed-image))
+                        :toplevel-function (when executable #'restore-image))
   #+(or cmu scl)
   (progn
    (ext:gc :full t)
    (setf ext:*batch-mode* nil)
    (setf ext::*gc-run-time* 0)
    (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
-          (when executable '(:init-function run-resumed-image :process-command-line nil))))
+          (when executable '(:init-function restore-image :process-command-line nil))))
   #+gcl
   (progn
    (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
    (si::save-system filename))
   #+lispworks
   (if executable
-      (lispworks:deliver 'run-resumed-image filename 0 :interface nil)
+      (lispworks:deliver 'restore-image filename 0 :interface nil)
       (hcl:save-image filename :environment nil))
   #+sbcl
   (progn
@@ -280,12 +292,12 @@ if we are not called from a directly executable image dumped by XCVB."
    (setf sb-ext::*gc-run-time* 0)
    (apply 'sb-ext:save-lisp-and-die filename
     :executable t ;--- always include the runtime that goes with the core
-    (when executable (list :toplevel #'run-resumed-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
+    (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
   #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
-  (die 98 "Can't dump ~S: asdf doesn't support image dumping with this Lisp implementation.~%" filename))
+  (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
+       filename (nth-value 1 (implementation-type))))
 
 
-;;; Initial environmental hooks
-(pushnew 'setup-temporary-directory *image-resume-hook*)
-(pushnew 'setup-stderr *image-resume-hook*)
-(pushnew 'setup-command-line-arguments *image-resume-hook*)
+;;; Some universal image restore hooks
+(map () 'register-image-restore-hook
+     '(setup-temporary-directory setup-stderr setup-command-line-arguments))
index 7ae892b..35c3c35 100644 (file)
@@ -93,7 +93,7 @@
     (multiple-value-bind (output warnings-p failure-p)
         (call-with-around-compile-hook
          c #'(lambda (&rest flags)
-               (with-controlled-compiler-conditions ()
+               (with-muffled-compiler-conditions ()
                  (apply *compile-file-function* input-file
                         :output-file output-file
                         :external-format (component-external-format c)
         (perform (find-operation o 'compile-op) c)))))
 (defun* perform-lisp-load-fasl (o c)
   (if-bind (fasl (first (input-files o c)))
-    (with-controlled-loader-conditions () (load* fasl))))
+    (with-muffled-loader-conditions () (load* fasl))))
 (defmethod perform ((o load-op) (c cl-source-file))
   (perform-lisp-load-fasl o c))
 (defmethod perform ((o load-op) (c static-file))
 (defun* perform-lisp-load-source (o c)
   (call-with-around-compile-hook
    c #'(lambda ()
-         (with-controlled-loader-conditions ()
+         (with-muffled-loader-conditions ()
            (load* (first (input-files o c))
                   :external-format (component-external-format c))))))
 
index 2c4b3fe..fd90b01 100644 (file)
    #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
    #:*compile-file-function* #:*output-translation-function*
    #:*optimization-settings* #:*previous-optimization-settings*
-   #:*uninteresting-conditions*
    #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
    #:*deferred-warnings*
    ;; Functions & Macros
    #:get-optimization-settings #:proclaim-optimization-settings
-   #:match-condition-p #:match-any-condition-p #:uninteresting-condition-p
-   #:call-with-muffled-uninteresting-conditions #:with-muffled-uninteresting-conditions
-   #:call-with-controlled-compiler-conditions #:with-controlled-compiler-conditions
-   #:call-with-controlled-loader-conditions #:with-controlled-loader-conditions
+   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
+   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
    #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
    #:lispize-pathname #:fasl-type #:call-around-hook
    #:compile-file* #:compile-file-pathname*
@@ -70,9 +67,6 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
 
 ;;; Condition control
 
-(defvar *uninteresting-conditions* nil
-  "Uninteresting conditions, as per MATCH-CONDITION-P")
-
 (defvar *uninteresting-compiler-conditions*
   (append
    #+sbcl
@@ -105,56 +99,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
 
 ;;;; ----- Filtering conditions while building -----
 
-(defparameter +simple-condition-format-control-slot+
-  #+allegro 'excl::format-control
-  #+clozure 'ccl::format-control
-  #+(or cmu scl) 'conditions::format-control
-  #+sbcl 'sb-kernel:format-control
-  #-(or allegro clozure cmu sbcl scl) :NOT-KNOWN-TO-ASDF
-  "Name of the slot for FORMAT-CONTROL in simple-condition")
-
-(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 (unreify-symbol x)))
-    (function (funcall x condition))
-    (string (and (typep condition 'simple-condition)
-                 #+(or allegro clozure cmu scl) ;; On SBCL, it's always set & the check warns
-                (slot-boundp condition +simple-condition-format-control-slot+)
-                 (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* call-with-muffled-uninteresting-conditions
-    (thunk &optional (conditions *uninteresting-conditions*))
-  (let ((*uninteresting-conditions* conditions))
-    (handler-bind (((satisfies uninteresting-condition-p) #'muffle-warning))
-      (funcall thunk))))
-(defmacro with-muffled-uninteresting-conditions ((&optional conditions) &body body)
-  `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))
-
-(defun* call-with-controlled-compiler-conditions (thunk)
-  (call-with-muffled-uninteresting-conditions
+(defun* call-with-muffled-compiler-conditions (thunk)
+  (call-with-muffled-conditions
     thunk *uninteresting-compiler-conditions*))
-(defmacro with-controlled-compiler-conditions ((&optional) &body body)
+(defmacro with-muffled-compiler-conditions ((&optional) &body body)
   "Run BODY where uninteresting compiler conditions are muffled"
-  `(call-with-controlled-compiler-conditions #'(lambda () ,@body)))
-(defun* call-with-controlled-loader-conditions (thunk)
-  (call-with-muffled-uninteresting-conditions
+  `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
+(defun* call-with-muffled-loader-conditions (thunk)
+  (call-with-muffled-conditions
    thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
-(defmacro with-controlled-loader-conditions ((&optional) &body body)
+(defmacro with-muffled-loader-conditions ((&optional) &body body)
   "Run BODY where uninteresting compiler and additional loader conditions are muffled"
-  `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body)))
+  `(call-with-muffled-loader-conditions #'(lambda () ,@body)))
 
 (defun* save-forward-references (forward-references)
   ;; TODO: replace with stuff in POIU
@@ -197,7 +153,7 @@ possibly in a different process."
     (let ((*deferred-warnings* ())
           #+sbcl (sb-c::*undefined-warnings* nil))
       (multiple-value-prog1
-          (with-controlled-compiler-conditions ()
+          (with-muffled-compiler-conditions ()
             (funcall thunk))
         (save-forward-references forward-references)))))
 
index 7b0fc2a..5cff985 100644 (file)
@@ -52,11 +52,10 @@ and the order is by decreasing length of namestring of the source pathname.")
   (and *output-translations* t))
 
 (defun* clear-output-translations ()
-  "Undoes any initialization of the output translations.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then."
+  "Undoes any initialization of the output translations."
   (setf *output-translations* '())
   (values))
+(register-clear-configuration-hook 'clear-source-registry)
 
 (defun* validate-output-translations-directive (directive)
   (or (member directive '(:enable-user-cache :disable-cache nil))
@@ -281,6 +280,9 @@ effectively disabling the output translation facility."
        :return (translate-pathname* p absolute-source destination root source)
        :finally (return p)))))
 
+;; Hook into asdf/driver's output-translation mechanism
+(setf *output-translation-function* 'apply-output-translations)
+
 #+abcl
 (defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
@@ -307,6 +309,3 @@ effectively disabling the output translation facility."
            (target
              (merge-pathnames* relative-source target-root)))
       (normalize-device (apply-output-translations target)))))
-
-(setf *output-translation-function* 'apply-output-translations)
-(pushnew 'clear-output-translations *clear-configuration-hook*)
index cc5472b..7b8c333 100644 (file)
@@ -13,7 +13,7 @@
 (defpackage :asdf/package
   (:use :common-lisp)
   (:export
-   #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern*
+   #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* #:make-symbol*
    #:symbol-shadowing-p #:rehome-symbol
    #:delete-package* #:package-names #:packages-from-names
    #:reify-symbol #:unreify-symbol
@@ -52,6 +52,10 @@ or when loading the package is optional."
     (apply (find-symbol* name package) args))
   (defun intern* (name package-designator &optional (error t))
     (intern (string name) (find-package* package-designator error)))
+  (defun make-symbol* (name)
+    (etypecase name
+      (string (make-symbol name))
+      (symbol (copy-symbol name))))
   (defun unintern* (name package-designator &optional (error t))
     (block nil
       (let ((package (find-package* package-designator error)))
@@ -98,8 +102,8 @@ or when loading the package is optional."
        (let* ((symbol-name (svref symbol 0))
               (package-foo (svref symbol 1))
               (package (unreify-package package-foo package-context)))
-         (if package (intern symbol-name package)
-             (make-symbol symbol-name)))))))
+         (if package (intern* symbol-name package)
+             (make-symbol* symbol-name)))))))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
   #+(or clisp clozure)
index a4adc79..af784bb 100644 (file)
--- a/plan.lisp
+++ b/plan.lisp
@@ -3,7 +3,7 @@
 
 (asdf/package:define-package :asdf/plan
   (:recycle :asdf/plan :asdf)
-  (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade
+  (:use :common-lisp :asdf/driver :asdf/upgrade
    :asdf/component :asdf/system :asdf/find-system :asdf/find-component
    :asdf/operation :asdf/action)
   #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
index 49bc9b1..f1d665b 100644 (file)
@@ -45,11 +45,10 @@ system names to pathnames of .asd files")
   (typep *source-registry* 'hash-table))
 
 (defun* clear-source-registry ()
-  "Undoes any initialization of the source registry.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then."
+  "Undoes any initialization of the source registry."
   (setf *source-registry* nil)
   (values))
+(register-clear-configuration-hook 'clear-source-registry)
 
 (defparameter *wild-asd*
   (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
@@ -314,5 +313,3 @@ with a different configuration, so the configuration would be re-read then."
 (defun* sysdef-source-registry-search (system)
   (ensure-source-registry)
   (values (gethash (coerce-name system) *source-registry*)))
-
-(pushnew 'clear-source-registry *clear-configuration-hook*)
index 4a92263..af143ac 100644 (file)
@@ -16,7 +16,7 @@
    #:slurp-stream-string #:slurp-stream-lines
    #:slurp-stream-forms #:read-file-string
    #:read-file-lines #:read-file-forms
-   #:safe-read-first-file-form #:eval-input
+   #:safe-read-first-file-form #:eval-input #:eval-text
    #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
    #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
    #:*default-encoding* #:*utf-8-external-format*))
 
 ;;; Output to a stream or string, FORMAT-style
 
-(defun* call-with-output (x thunk)
-  "Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
-If OBJ is a stream, use it as the stream.
-If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
-If OBJ is T, use *STANDARD-OUTPUT* as the stream.
-If OBJ is a string with a fill-pointer, use it as a string-output-stream.
+(defun* call-with-output (output function)
+  "Calls FUNCTION with an actual stream argument,
+behaving like FORMAT with respect to how stream designators are interpreted:
+If OUTPUT is a stream, use it as the stream.
+If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
+If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
+If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
 Otherwise, signal an error."
-  (typecase x
+  (etypecase output
     (null
-     (with-output-to-string (s) (funcall thunk s)))
+     (with-output-to-string (stream) (funcall function stream)))
     ((eql t)
-     (funcall thunk *standard-output*))
+     (funcall function *standard-output*))
     (stream
-     (funcall thunk x))
+     (funcall function output))
     (string
-     (assert (fill-pointer x))
-     (with-output-to-string (s x) (funcall thunk s)))
-    (t (error "not a valid stream designator ~S" x))))
+     (assert (fill-pointer output))
+     (with-output-to-string (stream output) (funcall function stream)))))
 
-(defmacro with-output ((x &optional (value x)) &body body)
-  "Bind X to an output stream, coercing VALUE (default: previous binding of X)
+(defmacro with-output ((output-var &optional (value output-var)) &body body)
+  "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
 as per FORMAT, and evaluate BODY within the scope of this binding."
-  `(call-with-output ,value #'(lambda (,x) ,@body)))
+  `(call-with-output ,value #'(lambda (,output-var) ,@body)))
 
-(defun* output-string (string &optional stream)
-  (if stream
-      (with-output (stream) (princ string stream))
+(defun* output-string (string &optional output)
+  "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
+  (if output
+      (with-output (output) (princ string output))
       string))
 
 
 ;;; Input helpers
 
-(defun* call-with-input (x fun)
-  "Calls FUN with an actual stream argument, coercing behaving like READ with respect to stream'ing:
-If OBJ is a stream, use it as the stream.
-If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
-If OBJ is T, use *STANDARD-OUTPUT* as the stream.
-If OBJ is a string with a fill-pointer, use it as a string-output-stream.
+(defun* call-with-input (input function)
+  "Calls FUNCTION with an actual stream argument, interpreting
+stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
+If INPUT is a STREAM, use it as the stream.
+If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
+If INPUT is T, use *TERMINAL-IO* as the stream.
+As an extension, if INPUT is a string, use it as a string-input-stream.
 Otherwise, signal an error."
-  (typecase x
-    (null
-     (funcall fun *terminal-io*))
-    ((eql t)
-     (funcall fun *standard-input*))
-    (stream
-     (funcall fun x))
-    (string
-     (with-input-from-string (s x) (funcall fun s)))
-    (t
-     (error "not a valid input stream designator ~S" x))))
+  (etypecase input
+    (null (funcall function *standard-input*))
+    ((eql t) (funcall function *terminal-io*))
+    (stream (funcall function input))
+    (string (with-input-from-string (stream input) (funcall function stream)))))
 
-(defmacro with-input ((x &optional (value x)) &body body)
-  `(call-with-input ,value #'(lambda (,x) ,@body)))
+(defmacro with-input ((input-var &optional (value input-var)) &body body)
+  "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
+as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
+  `(call-with-input ,value #'(lambda (,input-var) ,@body)))
 
 (defun* call-with-input-file (pathname thunk
                              &key (element-type *default-stream-element-type*)
@@ -234,6 +232,12 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
           :do (setf results (multiple-value-list (eval form)))
           :finally (return (apply 'values results)))))
 
+(defun* eval-text (text)
+  "Evaluate a form, or if a string, read and evaluate from the string."
+  (etypecase text
+    ((or cons symbol) (eval text))
+    (string (eval-input text))))
+
 
 ;;; Encodings
 
index 82ff0a9..0cd8ed0 100644 (file)
@@ -346,32 +346,24 @@ is bound, write a message and exit on an error.  If
   `(testing-asdf #'(lambda () ,@body)))
 
 (defun configure-asdf ()
-  (DBG "Debugging?" *debug-asdf*)
   (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
-  (DBG "Tracing?" *trace-symbols*)
   (untrace)
   (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
-  (DBG "Initializing source registry")
   (acall :initialize-source-registry
          `(:source-registry :ignore-inherited-configuration))
-  (DBG "Initializing output-translations")
   (acall :initialize-output-translations
          `(:output-translations
            ((,*asdf-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "asdf"))
            (t (,*asdf-directory* "build/fasls" :implementation "root"))
            :ignore-inherited-configuration))
   (set (asym :*central-registry*) `(,*test-directory*))
-  (DBG "Verbose output for ASDF")
   (set (asym :*verbose-out*) *standard-output*)
   (set (asym :*asdf-verbose*) t))
 
 (defun load-asdf (&optional tag)
-  (DBG "loading the ASDF fasl")
   (load-asdf-fasl tag)
   (use-package :asdf :asdf-test)
-  (DBG "configuring ASDF")
   (configure-asdf)
-  (DBG "reading for your script")
   (setf *package* (find-package :asdf-test)))
 
 (defun debug-asdf ()
index 668fd8f..525a63b 100644 (file)
@@ -2,6 +2,8 @@
 (load "script-support.lisp")
 (load-asdf)
 
+(trace d:match-any-condition-p)
+
 (with-test ()
  #-gcl<2.7
  (assert (handler-case
index 8f6a0aa..b15a570 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.94")
+         (asdf-version "2.26.95")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
index be863b4..78f9b66 100644 (file)
@@ -18,7 +18,9 @@
    #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
    #:list-to-hash-set ;; hash-table
    #:ensure-function #:call-function #:call-functions #:register-hook-function ;; functions
-   #:eval-string #:load-string #:load-stream
+   #:match-condition-p #:match-any-condition-p ;; conditions
+   #:call-with-muffled-conditions #:with-muffled-conditions
+   #:eval-text #:load-string #:load-stream
    #:parse-version #:unparse-version #:version-compatible-p)) ;; version
 (in-package :asdf/utility)
 
@@ -217,10 +219,6 @@ starting the separation from the end, e.g. when called with arguments
 
 
 ;;; Code execution
-(defun* eval-string (string)
-  "Evaluate a form read from a string."
-  (eval (read-from-string string)))
-
 (defun* ensure-function (fun &key (package :cl))
   (etypecase fun
     ((or boolean keyword character number pathname) (constantly fun))
@@ -236,9 +234,9 @@ starting the separation from the end, e.g. when called with arguments
 (defun* call-functions (function-specs)
   (map () 'call-function function-specs))
 
-(defun* register-hook-function (variable hook &optional (now t))
+(defun* register-hook-function (variable hook &optional (call-now-p t))
   (pushnew hook (symbol-value variable))
-  (when now (call-function hook)))
+  (when call-now-p (call-function hook)))
 
 
 ;;; Version handling
@@ -280,3 +278,48 @@ with later being determined by a lexicographical comparison of minor numbers."
       (and x y (= (car x) (car y))
            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
 
+
+;;; Condition control
+
+(defvar *uninteresting-conditions* nil
+  "Uninteresting conditions, as per MATCH-CONDITION-P")
+
+(defparameter +simple-condition-format-control-slot+
+  #+abcl 'system::format-control
+  #+allegro 'excl::format-control
+  #+clisp 'system::$format-control
+  #+clozure 'ccl::format-control
+  #+ecl 'si::format-control
+  #+(or cmu scl) 'conditions::format-control
+  #+(or gcl lispworks) 'conditions::format-string
+  #+sbcl 'sb-kernel:format-control
+  #-(or abcl allegro clisp clozure cmu gcl lispworks sbcl scl) nil
+  "Name of the slot for FORMAT-CONTROL in simple-condition")
+
+(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)
+                 ;; On SBCL, it's always set and the check triggers a warning
+                 #+(or allegro clozure cmu lispworks scl)
+                (slot-boundp condition +simple-condition-format-control-slot+)
+                 (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* call-with-muffled-conditions (thunk conditions)
+  (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
+                                    (muffle-warning c)))))
+    (funcall thunk)))
+
+(defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
+  `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))
+
index 160cf57..6bb778c 100644 (file)
@@ -1 +1 @@
-"2.26.94"
+"2.26.95"