Skip to content
Snippets Groups Projects
Commit 3d3b65d4 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.95: more frobbing of the runtime support

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.
parent eef7278f
No related branches found
No related tags found
No related merge requests found
......@@ -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))))
......
......@@ -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))
......
......@@ -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*))
......
......@@ -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)))))
......
;; -*- 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>.
......
......@@ -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))
......@@ -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))))))
......
......@@ -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)))))
......
......@@ -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*)
......@@ -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)
......
......@@ -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)
......
......@@ -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*)
......@@ -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
......
......@@ -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 ()
......
......@@ -2,6 +2,8 @@
(load "script-support.lisp")
(load-asdf)
(trace d:match-any-condition-p)
(with-test ()
#-gcl<2.7
(assert (handler-case
......
......@@ -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)))
......
......@@ -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))
"2.26.94"
"2.26.95"
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment