Commit 3d3b65d4 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :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 () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -5,15 +5,15 @@ ...@@ -5,15 +5,15 @@
(setf *load-verbose* nil *load-print* nil (setf *load-verbose* nil *load-print* nil
*compile-verbose* nil *compile-print* nil) *compile-verbose* nil *compile-print* nil)
(format t "Loading ASDF... ~%") (format t "Loading your implementation's ASDF... ~%")
(require :asdf) (require :asdf)
(in-package :asdf) (in-package :asdf)
#-asdf2 (error "Not ASDF2, you lose!") #-asdf2 (error "Not ASDF2, you lose!")
(format t "Initializing the source registry... ~%") (format t "Initializing the source registry... ~%")
(initialize-source-registry) (initialize-source-registry)
(format t "Making sure that's the latest... ~%") (format t "Upgrading to the latest ASDF... ~%")
(upgrade-asdf) (upgrade-asdf)
(format t "Now load some dependencies... ~%") (format t "Now loading some dependencies... ~%")
(load-systems :cl-ppcre :xcvb-utils) (load-systems :cl-ppcre :xcvb-utils)
(in-package :xcvb-utils) (in-package :xcvb-utils)
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
(asdf-debug) (asdf-debug)
(DBG "There we are!") (DBG "There we are!")
(resume-image) (restore-image)
(defun afile (x) (defun afile (x)
(asdf:system-relative-pathname :asdf x)) (asdf:system-relative-pathname :asdf x))
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
#:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
#:configuration-inheritance-directive-p #:configuration-inheritance-directive-p
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #: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-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location-component #:resolve-absolute-location-component)) #:resolve-relative-location-component #:resolve-absolute-location-component))
(in-package :asdf/configuration) (in-package :asdf/configuration)
...@@ -277,6 +277,9 @@ Please remove it from your ASDF configuration")) ...@@ -277,6 +277,9 @@ Please remove it from your ASDF configuration"))
(defvar *clear-configuration-hook* '()) (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 () (defun* clear-configuration ()
(call-functions *clear-configuration-hook*)) (call-functions *clear-configuration-hook*))
......
...@@ -251,7 +251,7 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -251,7 +251,7 @@ Going forward, we recommend new users should be using the source-registry.
(external-format (encoding-external-format (detect-encoding pathname)))) (external-format (encoding-external-format (detect-encoding pathname))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
pathname package) pathname package)
(with-controlled-loader-conditions () (with-muffled-loader-conditions ()
(load* pathname :external-format external-format)))) (load* pathname :external-format external-format))))
(delete-package package))))) (delete-package package)))))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
This diff is collapsed.
...@@ -93,7 +93,7 @@ ...@@ -93,7 +93,7 @@
(multiple-value-bind (output warnings-p failure-p) (multiple-value-bind (output warnings-p failure-p)
(call-with-around-compile-hook (call-with-around-compile-hook
c #'(lambda (&rest flags) c #'(lambda (&rest flags)
(with-controlled-compiler-conditions () (with-muffled-compiler-conditions ()
(apply *compile-file-function* input-file (apply *compile-file-function* input-file
:output-file output-file :output-file output-file
:external-format (component-external-format c) :external-format (component-external-format c)
...@@ -159,7 +159,7 @@ ...@@ -159,7 +159,7 @@
(perform (find-operation o 'compile-op) c))))) (perform (find-operation o 'compile-op) c)))))
(defun* perform-lisp-load-fasl (o c) (defun* perform-lisp-load-fasl (o c)
(if-bind (fasl (first (input-files 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)) (defmethod perform ((o load-op) (c cl-source-file))
(perform-lisp-load-fasl o c)) (perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file)) (defmethod perform ((o load-op) (c static-file))
...@@ -205,7 +205,7 @@ ...@@ -205,7 +205,7 @@
(defun* perform-lisp-load-source (o c) (defun* perform-lisp-load-source (o c)
(call-with-around-compile-hook (call-with-around-compile-hook
c #'(lambda () c #'(lambda ()
(with-controlled-loader-conditions () (with-muffled-loader-conditions ()
(load* (first (input-files o c)) (load* (first (input-files o c))
:external-format (component-external-format c)))))) :external-format (component-external-format c))))))
......
...@@ -10,15 +10,12 @@ ...@@ -10,15 +10,12 @@
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
#:*compile-file-function* #:*output-translation-function* #:*compile-file-function* #:*output-translation-function*
#:*optimization-settings* #:*previous-optimization-settings* #:*optimization-settings* #:*previous-optimization-settings*
#:*uninteresting-conditions*
#:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
#:*deferred-warnings* #:*deferred-warnings*
;; Functions & Macros ;; Functions & Macros
#:get-optimization-settings #:proclaim-optimization-settings #:get-optimization-settings #:proclaim-optimization-settings
#:match-condition-p #:match-any-condition-p #:uninteresting-condition-p #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
#:call-with-muffled-uninteresting-conditions #:with-muffled-uninteresting-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:call-with-controlled-compiler-conditions #:with-controlled-compiler-conditions
#:call-with-controlled-loader-conditions #:with-controlled-loader-conditions
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
#:lispize-pathname #:fasl-type #:call-around-hook #:lispize-pathname #:fasl-type #:call-around-hook
#:compile-file* #:compile-file-pathname* #: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 ...@@ -70,9 +67,6 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;; Condition control ;;; Condition control
(defvar *uninteresting-conditions* nil
"Uninteresting conditions, as per MATCH-CONDITION-P")
(defvar *uninteresting-compiler-conditions* (defvar *uninteresting-compiler-conditions*
(append (append
#+sbcl #+sbcl
...@@ -105,56 +99,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ...@@ -105,56 +99,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;;; ----- Filtering conditions while building ----- ;;;; ----- Filtering conditions while building -----
(defparameter +simple-condition-format-control-slot+ (defun* call-with-muffled-compiler-conditions (thunk)
#+allegro 'excl::format-control (call-with-muffled-conditions
#+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
thunk *uninteresting-compiler-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" "Run BODY where uninteresting compiler conditions are muffled"
`(call-with-controlled-compiler-conditions #'(lambda () ,@body))) `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
(defun* call-with-controlled-loader-conditions (thunk) (defun* call-with-muffled-loader-conditions (thunk)
(call-with-muffled-uninteresting-conditions (call-with-muffled-conditions
thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-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" "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) (defun* save-forward-references (forward-references)
;; TODO: replace with stuff in POIU ;; TODO: replace with stuff in POIU
...@@ -197,7 +153,7 @@ possibly in a different process." ...@@ -197,7 +153,7 @@ possibly in a different process."
(let ((*deferred-warnings* ()) (let ((*deferred-warnings* ())
#+sbcl (sb-c::*undefined-warnings* nil)) #+sbcl (sb-c::*undefined-warnings* nil))
(multiple-value-prog1 (multiple-value-prog1
(with-controlled-compiler-conditions () (with-muffled-compiler-conditions ()
(funcall thunk)) (funcall thunk))
(save-forward-references forward-references))))) (save-forward-references forward-references)))))
......
...@@ -52,11 +52,10 @@ and the order is by decreasing length of namestring of the source pathname.") ...@@ -52,11 +52,10 @@ and the order is by decreasing length of namestring of the source pathname.")
(and *output-translations* t)) (and *output-translations* t))
(defun* clear-output-translations () (defun* clear-output-translations ()
"Undoes any initialization of the 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."
(setf *output-translations* '()) (setf *output-translations* '())
(values)) (values))
(register-clear-configuration-hook 'clear-source-registry)
(defun* validate-output-translations-directive (directive) (defun* validate-output-translations-directive (directive)
(or (member directive '(:enable-user-cache :disable-cache nil)) (or (member directive '(:enable-user-cache :disable-cache nil))
...@@ -281,6 +280,9 @@ effectively disabling the output translation facility." ...@@ -281,6 +280,9 @@ effectively disabling the output translation facility."
:return (translate-pathname* p absolute-source destination root source) :return (translate-pathname* p absolute-source destination root source)
:finally (return p))))) :finally (return p)))))
;; Hook into asdf/driver's output-translation mechanism
(setf *output-translation-function* 'apply-output-translations)
#+abcl #+abcl
(defun* translate-jar-pathname (source wildcard) (defun* translate-jar-pathname (source wildcard)
(declare (ignore wildcard)) (declare (ignore wildcard))
...@@ -307,6 +309,3 @@ effectively disabling the output translation facility." ...@@ -307,6 +309,3 @@ effectively disabling the output translation facility."
(target (target
(merge-pathnames* relative-source target-root))) (merge-pathnames* relative-source target-root)))
(normalize-device (apply-output-translations target))))) (normalize-device (apply-output-translations target)))))
(setf *output-translation-function* 'apply-output-translations)
(pushnew 'clear-output-translations *clear-configuration-hook*)
...@@ -13,7 +13,7 @@ ...@@ -13,7 +13,7 @@
(defpackage :asdf/package (defpackage :asdf/package
(:use :common-lisp) (:use :common-lisp)
(:export (:export
#:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* #:make-symbol*
#:symbol-shadowing-p #:rehome-symbol #:symbol-shadowing-p #:rehome-symbol
#:delete-package* #:package-names #:packages-from-names #:delete-package* #:package-names #:packages-from-names
#:reify-symbol #:unreify-symbol #:reify-symbol #:unreify-symbol
...@@ -52,6 +52,10 @@ or when loading the package is optional." ...@@ -52,6 +52,10 @@ or when loading the package is optional."
(apply (find-symbol* name package) args)) (apply (find-symbol* name package) args))
(defun intern* (name package-designator &optional (error t)) (defun intern* (name package-designator &optional (error t))
(intern (string name) (find-package* package-designator error))) (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)) (defun unintern* (name package-designator &optional (error t))
(block nil (block nil
(let ((package (find-package* package-designator error))) (let ((package (find-package* package-designator error)))
...@@ -98,8 +102,8 @@ or when loading the package is optional." ...@@ -98,8 +102,8 @@ or when loading the package is optional."
(let* ((symbol-name (svref symbol 0)) (let* ((symbol-name (svref symbol 0))
(package-foo (svref symbol 1)) (package-foo (svref symbol 1))
(package (unreify-package package-foo package-context))) (package (unreify-package package-foo package-context)))
(if package (intern symbol-name package) (if package (intern* symbol-name package)
(make-symbol symbol-name))))))) (make-symbol* symbol-name)))))))
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
#+(or clisp clozure) #+(or clisp clozure)
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(asdf/package:define-package :asdf/plan (asdf/package:define-package :asdf/plan
(:recycle :asdf/plan :asdf) (: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/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action) :asdf/operation :asdf/action)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of) #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
......
...@@ -45,11 +45,10 @@ system names to pathnames of .asd files") ...@@ -45,11 +45,10 @@ system names to pathnames of .asd files")
(typep *source-registry* 'hash-table)) (typep *source-registry* 'hash-table))
(defun* clear-source-registry () (defun* clear-source-registry ()
"Undoes any initialization of the 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."
(setf *source-registry* nil) (setf *source-registry* nil)
(values)) (values))
(register-clear-configuration-hook 'clear-source-registry)
(defparameter *wild-asd* (defparameter *wild-asd*
(make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) (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." ...@@ -314,5 +313,3 @@ with a different configuration, so the configuration would be re-read then."
(defun* sysdef-source-registry-search (system) (defun* sysdef-source-registry-search (system)
(ensure-source-registry) (ensure-source-registry)
(values (gethash (coerce-name system) *source-registry*))) (values (gethash (coerce-name system) *source-registry*)))
(pushnew 'clear-source-registry *clear-configuration-hook*)
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
#:slurp-stream-string #:slurp-stream-lines #:slurp-stream-string #:slurp-stream-lines
#:slurp-stream-forms #:read-file-string #:slurp-stream-forms #:read-file-string
#:read-file-lines #:read-file-forms #: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 #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*)) #:*default-encoding* #:*utf-8-external-format*))
...@@ -52,59 +52,57 @@ ...@@ -52,59 +52,57 @@
;;; Output to a stream or string, FORMAT-style ;;; Output to a stream or string, FORMAT-style
(defun* call-with-output (x thunk) (defun* call-with-output (output function)
"Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing: "Calls FUNCTION with an actual stream argument,
If OBJ is a stream, use it as the stream. behaving like FORMAT with respect to how stream designators are interpreted:
If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. If OUTPUT is a stream, use it as the stream.
If OBJ is T, use *STANDARD-OUTPUT* as the stream. If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
If OBJ is a string with a fill-pointer, use it as a string-output-stream. 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." Otherwise, signal an error."
(typecase x (etypecase output
(null (null
(with-output-to-string (s) (funcall thunk s))) (with-output-to-string (stream) (funcall function stream)))
((eql t) ((eql t)
(funcall thunk *standard-output*)) (funcall function *standard-output*))
(stream (stream
(funcall thunk x)) (funcall function output))
(string (string
(assert (fill-pointer x)) (assert (fill-pointer output))
(with-output-to-string (s x) (funcall thunk s))) (with-output-to-string (stream output) (funcall function stream)))))
(t (error "not a valid stream designator ~S" x))))
(defmacro with-output ((x &optional (value x)) &body body) (defmacro with-output ((output-var &optional (value output-var)) &body body)
"Bind X to an output stream, coercing VALUE (default: previous binding of X) "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." 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) (defun* output-string (string &optional output)
(if stream "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
(with-output (stream) (princ string stream)) (if output
(with-output (output) (princ string output))
string)) string))
;;; Input helpers ;;; Input helpers
(defun* call-with-input (x fun) (defun* call-with-input (input function)
"Calls FUN with an actual stream argument, coercing behaving like READ with respect to stream'ing: "Calls FUNCTION with an actual stream argument, interpreting
If OBJ is a stream, use it as the stream. stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. If INPUT is a STREAM, use it as the stream.
If OBJ is T, use *STANDARD-OUTPUT* as the stream. If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
If OBJ is a string with a fill-pointer, use it as a string-output-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." Otherwise, signal an error."
(typecase x (etypecase input
(null (null (funcall function *standard-input*))
(funcall fun *terminal-io*)) ((eql t) (funcall function *terminal-io*))
((eql t) (stream (funcall function input))
(funcall fun *standard-input*)) (string (with-input-from-string (stream input) (funcall function stream)))))
(stream
(funcall fun x))
(string
(with-input-from-string (s x) (funcall fun s)))
(t
(error "not a valid input stream designator ~S" x))))
(defmacro with-input ((x &optional (value x)) &body body) (defmacro with-input ((input-var &optional (value input-var)) &body body)
`(call-with-input ,value #'(lambda (,x) ,@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 (defun* call-with-input-file (pathname thunk
&key (element-type *default-stream-element-type*) &key (element-type *default-stream-element-type*)
...@@ -234,6 +232,12 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" ...@@ -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))) :do (setf results (multiple-value-list (eval form)))
:finally (return (apply 'values results))))) :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 ;;; Encodings
......
...@@ -346,32 +346,24 @@ is bound, write a message and exit on an error. If ...@@ -346,32 +346,24 @@ is bound, write a message and exit on an error. If
`(testing-asdf #'(lambda () ,@body))) `(testing-asdf #'(lambda () ,@body)))
(defun configure-asdf () (defun configure-asdf ()
(DBG "Debugging?" *debug-asdf*)
(setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))) (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
(DBG "Tracing?" *trace-symbols*)
(untrace) (untrace)
(eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))) (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
(DBG "Initializing source registry")
(acall :initialize-source-registry (acall :initialize-source-registry
`(:source-registry :ignore-inherited-configuration)) `(:source-registry :ignore-inherited-configuration))
(DBG "Initializing output-translations")
(acall :initialize-output-translations (acall :initialize-output-translations
`(:output-translations `(:output-translations
((,*asdf-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "asdf")) ((,*asdf-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "asdf"))
(t (,*asdf-directory* "build/fasls" :implementation "root")) (t (,*asdf-directory* "build/fasls" :implementation "root"))
:ignore-inherited-configuration)) :ignore-inherited-configuration))
(set (asym :*central-registry*) `(,*test-directory*)) (set (asym :*central-registry*) `(,*test-directory*))
(DBG "Verbose output for ASDF")
(set (asym :*verbose-out*) *standard-output*) (set (asym :*verbose-out*) *standard-output*)
(set (asym :*asdf-verbose*) t)) (set (asym :*asdf-verbose*) t))
(defun load-asdf (&optional tag) (defun load-asdf (&optional tag)
(DBG "loading the ASDF fasl")
(load-asdf-fasl tag) (load-asdf-fasl tag)
(use-package :asdf :asdf-test) (use-package :asdf :asdf-test)
(DBG "configuring ASDF")
(configure-asdf) (configure-asdf)
(DBG "reading for your script")
(setf *package* (find-package :asdf-test))) (setf *package* (find-package :asdf-test)))
(defun debug-asdf () (defun debug-asdf ()
......
...@@ -2,6 +2,8 @@ ...@@ -2,6 +2,8 @@
(load "script-support.lisp") (load "script-support.lisp")
(load-asdf) (load-asdf)
(trace d:match-any-condition-p)
(with-test () (with-test ()
#-gcl<2.7 #-gcl<2.7
(assert (handler-case (assert (handler-case
......
...@@ -35,7 +35,7 @@ ...@@ -35,7 +35,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "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.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 ;; "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-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
......
...@@ -18,7 +18,9 @@ ...@@ -18,7 +18,9 @@
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
#:list-to-hash-set ;; hash-table #:list-to-hash-set ;; hash-table
#:ensure-function #:call-function #:call-functions #:register-hook-function ;; functions #: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 #:parse-version #:unparse-version #:version-compatible-p)) ;; version
(in-package :asdf/utility) (in-package :asdf/utility)
...@@ -217,10 +219,6 @@ starting the separation from the end, e.g. when called with arguments ...@@ -217,10 +219,6 @@ starting the separation from the end, e.g. when called with arguments
;;; Code execution ;;; 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)) (defun* ensure-function (fun &key (package :cl))
(etypecase fun (etypecase fun
((or boolean keyword character number pathname) (constantly 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 ...@@ -236,9 +234,9 @@ starting the separation from the end, e.g. when called with arguments
(defun* call-functions (function-specs) (defun* call-functions (function-specs)
(map () 'call-function 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)) (pushnew hook (symbol-value variable))
(when now (call-function hook))) (when call-now-p (call-function hook)))
;;; Version handling ;;; Version handling
...@@ -280,3 +278,48 @@ with later being determined by a lexicographical comparison of minor numbers." ...@@ -280,3 +278,48 @@ with later being determined by a lexicographical comparison of minor numbers."
(and x y (= (car x) (car y)) (and x y (= (car x) (car y))
(or (not (cdr y)) (bigger (cdr x) (cdr 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))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment