diff --git a/asdf.asd b/asdf.asd index 46b77b176604eaecef694d9f491a78a632e8c001..53864ac3e2d9e09c647309268c6169efd3654d09 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.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)))) diff --git a/bin/bump-version b/bin/bump-version index 03ac3ca5a3edf2fa6b78b2450ac2cda36c82eea8..d3902c6baa0ae1770648b09f02f9ae61594b7897 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -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)) diff --git a/configuration.lisp b/configuration.lisp index 5da2e79451909d20a6a53d2e04a031d280fdb5bb..d0ad6c0d053a70686f9bb60f4bbf67a6f43ff7e8 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -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*)) diff --git a/find-system.lisp b/find-system.lisp index 80e225eb7fdf25b158eb985e6224010f87fbb212..a4096d2cd53fa89a93fd3babdba90e8cf579c715 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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))))) diff --git a/header.lisp b/header.lisp index 239714bb3c8d1cf4ba5d43cffa25c91826f96468..7210b2f0a5acaf4118765ed85f740d711174a49c 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.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 . diff --git a/image.lisp b/image.lisp index 0658c7bce9748d38079fb75e9e3beedc03a94f16..1cfad50109ccbb525d6c861959ca4473a092ea7e 100644 --- a/image.lisp +++ b/image.lisp @@ -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)) diff --git a/lisp-action.lisp b/lisp-action.lisp index 7ae892b005f2b711e660090f4326a58a0356b0a6..35c3c350d609cb21e961aed8009e72b4bf2c651a 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -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) @@ -159,7 +159,7 @@ (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)) @@ -205,7 +205,7 @@ (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)))))) diff --git a/lisp-build.lisp b/lisp-build.lisp index 2c4b3fe759738c6a83f01d7eb38bb520ae4f2b9b..fd90b0163823f29631c43a552463fdf01d12b989 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -10,15 +10,12 @@ #:*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))))) diff --git a/output-translations.lisp b/output-translations.lisp index 7b0fc2a67f7afcd8aef45798fb1e658cf947a396..5cff98558c318d5b3ad3d6ee12f703c8fd03eac9 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -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*) diff --git a/package.lisp b/package.lisp index cc5472b195ec13771d4adc3cf95521002947c1e1..7b8c3338aac98811bc50d4175f4e4e3fb115ca91 100644 --- a/package.lisp +++ b/package.lisp @@ -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) diff --git a/plan.lisp b/plan.lisp index a4adc79508680bfeef880d7f76e6d7fceb8597df..af784bb292d77a6832f0fb9cb77797f4e150c810 100644 --- 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) diff --git a/source-registry.lisp b/source-registry.lisp index 49bc9b1e5a40e9c02ceb64aa614523c72123c340..f1d665bf313a2d8312778de696dfdf0b55c4126e 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -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*) diff --git a/stream.lisp b/stream.lisp index 4a92263023b2e4c8f7a30eb30be61c728f0d9889..af143acfffbfb0ad927755db1a94ef288602fed2 100644 --- a/stream.lisp +++ b/stream.lisp @@ -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*)) @@ -52,59 +52,57 @@ ;;; 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 diff --git a/test/script-support.lisp b/test/script-support.lisp index 82ff0a98752e56e96c91af8cf327dbefa14834df..0cd8ed08ffa7791a61979a8ae1d0e284f6c23a71 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -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 () diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script index 668fd8f7068e2c16d58353eec5acdf8c407a233d..525a63b1e5532c362b269b5afab41244564a95ba 100644 --- a/test/test-compile-file-failure.script +++ b/test/test-compile-file-failure.script @@ -2,6 +2,8 @@ (load "script-support.lisp") (load-asdf) +(trace d:match-any-condition-p) + (with-test () #-gcl<2.7 (assert (handler-case diff --git a/upgrade.lisp b/upgrade.lisp index 8f6a0aa5e74236560d7772b495618ec889057038..b15a570b425d934d6d25d43736446f3c871c4656 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -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))) diff --git a/utility.lisp b/utility.lisp index be863b4e6970bf439e9ab95d312697c6938d2e30..78f9b6630f00a619a12e36e747232e33f53b5549 100644 --- a/utility.lisp +++ b/utility.lisp @@ -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)) + diff --git a/version.lisp-expr b/version.lisp-expr index 160cf57a58f4ffb3db81fa5aa8cc43188b70084c..6bb778c878dbbf3a8e07d47cd74df22eba0b98b0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.94" +"2.26.95"