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.
: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))))
(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)
(asdf-debug)
(DBG "There we are!")
-(resume-image)
+(restore-image)
(defun afile (x)
(asdf:system-relative-pathname :asdf x))
#: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)
(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*))
(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)))))
;; -*- 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>.
(: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-
(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*))
#-abcl
(let* (#-(or sbcl allegro)
(arguments
- (if (eq *dumped* :executable)
+ (if (eq *image-dumped-p* :executable)
arguments
(member "--" arguments :test 'string-equal))))
(rest arguments)))
(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."))
: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
(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))
(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))))))
#:*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*
;;; Condition control
-(defvar *uninteresting-conditions* nil
- "Uninteresting conditions, as per MATCH-CONDITION-P")
-
(defvar *uninteresting-compiler-conditions*
(append
#+sbcl
;;;; ----- 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
(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)))))
(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))
: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))
(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*)
(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
(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)))
(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)
(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)
(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))
(defun* sysdef-source-registry-search (system)
(ensure-source-registry)
(values (gethash (coerce-name system) *source-registry*)))
-
-(pushnew 'clear-source-registry *clear-configuration-hook*)
#: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*)
: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
`(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 ()
(load "script-support.lisp")
(load-asdf)
+(trace d:match-any-condition-p)
+
(with-test ()
#-gcl<2.7
(assert (handler-case
;; "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)))
#: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)
;;; 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))
(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
(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))
+
common-lisp.net / projects/asdf/asdf.git / commitdiff
