diff --git a/Makefile b/Makefile index 4cc30a7fec300fdac81986cd95ef6e0e79903552..57e064abc249009b670e6d1eccda0d3b21bf219f 100644 --- a/Makefile +++ b/Makefile @@ -51,7 +51,7 @@ archive-copy: archive build/asdf.lisp ${MAKE} push git checkout master -driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp driver.lisp configuration.lisp +driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp driver.lisp asdf_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp build/asdf.lisp: $(wildcard *.lisp) @@ -101,67 +101,15 @@ mrproper: clean rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap test-upgrade: build/asdf.lisp - # 1.37 is the last release by Daniel Barlow - # 1.97 is the last release before Gary King takes over - # 1.369 is the last release by Gary King - # 2.000 to 2.019 and 2.20 to 2.27 and beyond are Faré's "stable" releases - fasl=fasl ; \ - use_ccl () { li="${CCL} --no-init --quiet" ; ev="--eval" ; } ; \ - use_clisp () { li="${CLISP} -norc -ansi --quiet --quiet" ; ev="-x" ; } ; \ - use_sbcl () { li="${SBCL} --noinform --no-userinit" ; ev="--eval" ; } ; \ - use_ecl () { li="${ECL} -norc" ; ev="-eval" ; } ; \ - use_ecl_bytecodes () { li="${ECL} -norc -eval (ext::install-bytecodes-compiler)" ; ev="-eval" ; } ; \ - use_mkcl () { li="${MKCL} -norc" ; ev="-eval" ; } ; \ - use_cmucl () { li="${CMUCL} -noinit" ; ev="-eval" ; } ; \ - use_abcl () { li="${ABCL} --noinit --nosystem --noinform" ; ev="--eval" ; } ; \ - use_xcl () { li="${XCL} --noinit --nosystem --noinform" ; ev="--eval" ; } ; \ - use_scl () { li="${SCL} -noinit" ; ev="-eval" ; } ; \ - use_gcl () { li="env GCL_ANSI=t ${GCL}" ; ev="-eval" ; } ; \ - use_allegro () { li="${ALLEGRO} -q" ; ev="-e" ; } ; \ - use_allegromodern () { li="${ALLEGROMODERN} -q" ; ev="-e" ; } ; \ - use_lispworks () { li="${LISPWORKS} -siteinit - -init -" ; ev="-eval" ; } ; \ - use_${lisp} ; \ - su=test/script-support.lisp ; lu="(load\"$$su\")" ; \ - lv="$$li $$ev $$lu $$ev" ; \ - for tag in 1.37 1.97 1.369 `git tag -l '2.0??'` `git tag -l '2.??'` ; do \ - rm -f $$fa ; \ - for x in load-system load-lisp load-lisp-compile-load-fasl load-fasl just-load-fasl ; do \ - lo="(asdf-test::load-old-asdf \"$${tag}\")" ; \ - echo "Testing upgrade from ASDF $${tag} using method $$x" ; \ - git show $${tag}:asdf.lisp > build/asdf-$${tag}.lisp ; \ - case ${lisp}:$$tag:$$x in \ - abcl:2.0[01][1-9]:*|abcl:2.2[1-2]:*) \ - : Skip, because it is so damn slow ;; \ - ccl:1.*|ccl:2.0[01]*) \ - : Skip, because ccl broke old asdf ;; \ - cmucl:1.*|cmucl:2.00*|cmucl:2.01[0-4]:*) \ - : Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade ;; \ - ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) \ - : Skip, because of various ASDF issues ;; \ - gcl:1.*|gcl:2.0*|gcl:2.2[0-6]*) : Skip old versions that do not support GCL 2.6 ;; \ - mkcl:1.*|mkcl:2.0[01]*|mkcl:2.2[0-3]:*) \ - : Skip, because MKCL is only supported starting with 2.24 ;; \ - xcl:1.*|xcl:2.00*|xcl:2.01[0-4]:*|xcl:*) \ - : XCL support starts with ASDF 2.014.2 - It also hangs badly during upgrade. ;; \ - *) (set -x ; \ - case $$x in \ - load-system) l="$$lo (asdf-test::load-asdf-system)" ;; \ - load-lisp) l="$$lo (asdf-test::load-asdf-lisp)" ;; \ - load-lisp-compile-load-fasl) l="$$lo (asdf-test::compile-load-asdf)" ;; \ - load-fasl) l="$$lo (asdf-test::load-asdf-fasl)" ;; \ - just-load-fasl) l="(asdf-test::load-asdf-fasl)" ;; \ - *) echo "WTF?" ; exit 2 ;; esac ; \ - $$lv "(asdf-test::test-asdf $$l)" ) || \ - { echo "upgrade FAILED" ; exit 1 ;} ;; esac ; \ - done ; done 2>&1 | tee build/results/${lisp}-upgrade.text - -test-forward-references: build/asdf.lisp + ./test/run-tests.sh -u ${lisp} + +test-compile: build/asdf.lisp ${SBCL} --noinform --no-userinit --no-sysinit --load build/asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null test-lisp: build/asdf.lisp @cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob} -test: test-lisp test-forward-references doc +test: test-lisp test-compile doc test-all-lisps: @for lisp in ${lisps} ; do \ diff --git a/action.lisp b/action.lisp index c8d79fac9c767967e90cc544b457b3c46a2d6d78..485979a1acbb04de5f20524ce0acee9609070cd8 100644 --- a/action.lisp +++ b/action.lisp @@ -95,7 +95,7 @@ You can put together sentences using this phrase.")) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF3: remove that. (defmethod component-depends-on ((o upward-operation) (c child-component)) - `(,@(aif (component-parent c) `((,o ,it))) ,@(call-next-method))) + `(,@(if-bind (p (component-parent c)) `((,o ,p))) ,@(call-next-method))) ;;;; Inputs, Outputs, and invisible dependencies diff --git a/asdf-driver.asd b/asdf-driver.asd index 83d9c7c8cdc349d44dca4d71272e5b57dd3ee791..29ed2a5fb991055f548cd5fdff19080de611000b 100644 --- a/asdf-driver.asd +++ b/asdf-driver.asd @@ -16,5 +16,5 @@ that you can't portably construct a complete program without using them." (:file "image" :depends-on ("os")) (:file "run-program" :depends-on ("os")) (:file "lisp-build" :depends-on ("image")) - (:file "driver" :depends-on ("lisp-build" "run-program")) - (:file "configuration" :depends-on ("os")))) + (:file "configuration" :depends-on ("os")) + (:file "driver" :depends-on ("lisp-build" "run-program" "configuration")))) diff --git a/asdf.asd b/asdf.asd index 6beb5559b3adf7749bb3b420c6cd9ee49d74065e..36c1c4e6650123cbef49d73ece5bbe83cd5f7b2f 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.81" ;; to be automatically updated by bin/bump-revision + :version "2.26.82" ;; 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/backward-internals.lisp b/backward-internals.lisp index 750381723c06951904c808313de770ee057c6a7f..a46c541e67f1ab528b08cef3b92ff2e4ee2fcd31 100644 --- a/backward-internals.lisp +++ b/backward-internals.lisp @@ -50,7 +50,7 @@ ;; This won't recurse into dependencies to accumulate feature conditions. ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL ;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. -(defun %resolve-if-component-dep-fails (if-component-dep-fails component) +(defun* %resolve-if-component-dep-fails (if-component-dep-fails component) (asdf-message "The system definition for ~S uses deprecated ~ ASDF option :IF-COMPONENT-DEP-DAILS. ~ Starting with ASDF 2.27, please use :IF-FEATURE instead" diff --git a/bundle.lisp b/bundle.lisp index 0cd3e242f87edadc9e43f0eb3aa086b72141d83e..4bc8f6e525ecb0d47c7fb5b7699542fbb370813d 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -277,7 +277,7 @@ nil) (defmethod perform ((o load-fasl-op) (c system)) - (aif (first (input-files o c)) (load it))) + (if-bind (it (first (input-files o c))) (load it))) (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) (mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components? diff --git a/compatibility.lisp b/compatibility.lisp index f86053ba599f1fafd335511be68e96a95ffe5899..f8ef8fe3292b094f33ea922158399ced0bb5d4d1 100644 --- a/compatibility.lisp +++ b/compatibility.lisp @@ -7,6 +7,7 @@ (asdf/package:define-package :asdf/compatibility (:use :common-lisp :asdf/package) (:recycle :asdf/compatibility :asdf) + #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:export #:logical-pathname #:translate-logical-pathname diff --git a/component.lisp b/component.lisp index 9aa705519cad453716210b421f173e2c6bde1bbe..bc624413e732dca0cc492a48a7ef80291903b5bf 100644 --- a/component.lisp +++ b/component.lisp @@ -106,9 +106,9 @@ another pathname in a degenerate way.")) (format stream "~{~S~^ ~}" (component-find-path c)))) (defmethod component-system ((component component)) - (aif (component-parent component) - (component-system it) - component)) + (if-bind (system (component-parent component)) + (component-system system) + component)) ;;;; component pathnames @@ -137,7 +137,8 @@ another pathname in a degenerate way.")) (defmethod component-relative-pathname ((component component)) (coerce-pathname - (or (slot-value component 'relative-pathname) + (or (and (slot-boundp component 'relative-pathname) + (slot-value component 'relative-pathname)) (component-name component)) :type (source-file-type component (component-system component)) ;; backward-compatibility :defaults (component-parent-pathname component))) diff --git a/configuration.lisp b/configuration.lisp index 4906c44566447988503b8f6b417a7fcfa1638041..36ec82886b698aeaad901bdb5eae1262d68ec52b 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -56,8 +56,8 @@ (cond ((os-unix-p) '(#p"/etc/common-lisp/")) ((os-windows-p) - (aif (subpathname* (get-folder-path :common-appdata) "common-lisp/config/") - (list it))))) + (if-bind (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")) + (list it))))) (defun* in-first-directory (dirs x &key (direction :input)) (loop :with fun = (ecase direction @@ -274,9 +274,8 @@ Please remove it from your ASDF configuration")) (eq (caadr x) 'lambda) (length=n-p (cadadr x) 2))))) - (defvar *clear-configuration-hook* '()) (defun* clear-configuration () - (map () #'funcall *clear-configuration-hook*)) + (call-functions *clear-configuration-hook*)) diff --git a/contrib/debug.lisp b/contrib/debug.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9df2cd5e5c46fc60222694aaa409113f1ee289fd --- /dev/null +++ b/contrib/debug.lisp @@ -0,0 +1,121 @@ +;;;;; A few essential debugging utilities by Faré, +;;;;; to be loaded in the *PACKAGE* in which you wish to debug. + +;; We want debugging utilities in the current package, +;; so we don't have to cheat with packages, +;; or have symbols that clash when trying use-package or import. +;; +;; The short names of symbols below are unlikely to have defined bindings +;; in a well-designed source file to be debugged, +;; but are quite practical in a debugging session. +;; + + +#| +;;; If ASDF is already loaded, you can load these utilities as follows: +(asdf/utility::asdf-debug) + +;; The above macro can be configured to load any other debugging utility +;; that you may prefer to this one, with your customizations, +;; by setting the variable +;; asdf-utility:*asdf-debug-utility* +;; to a form that evaluates to a designator of the pathname to your file. +;; For instance, on a home directory shared via NFS with different names +;; on different machines, with your debug file in ~/lisp/debug-utils.lisp +;; you could in your ~/.sbclrc have the following configuration setting: +(require :asdf) +(setf asdf-utility:*asdf-debug-utility* + '(asdf/pathname:subpathname (asdf/os:user-homedir) "lisp/debug-utils.lisp")) + +;;; If ASDF is not loaded (for instance, when debugging ASDF itself), +;;; Try the below, fixing the pathname to point to this file: +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((kw (read-from-string (format nil ":DBG-~A" (package-name *package*))))) + (unless (member kw *features*) + (load "/home/tunes/cl/asdf/contrib/debug.lisp") + ))) + +|# + +;;; Here we define the magic package-dependent feature. +;;; With it, you should be able to use #+DBG-/PACKAGE-NAME/ +;;; to annotate your debug statements, e.g. upper-case #+DBG-ASDF +;;; This will be all upper-case even in lower-case lisps. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((kw (read-from-string + (format nil ":DBG-~:@(~A~)" (package-name *package*))))) + (pushnew kw *features*))) + +;;; Now for the debugging stuff itself. +;;; First, my all-purpose print-debugging macro +(defmacro DBG (tag &rest exprs) + "simple debug statement macro: +TAG is typically a constant string or keyword, +but in general is an expression returning a tag to be printed first; +if the expression returns NIL, nothing is printed. +EXPRS are expression, the source then the value of which is printed; +The values of the last expression are returned. +Aim for relatively low overhead in space of time. +Other expressions are not evaluated if TAG returned NIL." + (let* ((last-expr (car (last exprs))) + (other-exprs (butlast exprs)) + (tag-var (gensym "TAG")) + (thunk-var (gensym "THUNK"))) + `(let ((,tag-var ,tag)) + (flet ,(when exprs `((,thunk-var () ,last-expr))) + (if ,tag-var + (DBG-helper ,tag-var + (list ,@(loop :for x :in other-exprs :collect + `(cons ',x #'(lambda () ,x)))) + ',last-expr ,(if exprs `#',thunk-var nil)) + ,(if exprs `(,thunk-var) '(values))))))) + +(defun DBG-helper (tag expressions-thunks last-expression last-thunk) + ;; Helper for the above debugging macro + (labels + ((f (stream fmt &rest args) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*package* (find-package :cl))) + (apply 'format stream fmt args) + (finish-output stream)))) + (z (stream) + (f stream "~&")) + (e (fmt arg) + (f *error-output* fmt arg)) + (x (expression thunk) + (e "~& ~S => " expression) + (let ((results (multiple-value-list (funcall thunk)))) + (e "~{~S~^ ~}~%" results) + (apply 'values results)))) + (map () #'z (list *standard-output* *error-output* *trace-output*)) + (e "~A~%" tag) + (loop :for (expression . thunk) :in expressions-thunks + :do (x expression thunk)) + (if last-thunk + (x last-expression last-thunk) + (values)))) + + +;;; Quick definitions for use at the REPL +(defun w (x) (format t "~&~S~%" x)) ; Write +(defun a (&optional x) (format t "~&~@[~A~]~%" x)) ; print Anything +(defun e (x) (cons x (ignore-errors (list (eval x))))) ; eValuate +(defmacro x (x) `(format t "~&~S => ~S~%" ',x ,x)) ; eXamine +(defmacro !a (&rest foo) ; define! Alias + `(progn ,@(loop :for (alias name) :on foo :by #'cddr + :collect (if (macro-function name) + `(defmacro ,alias (&rest x) `(,',name ,@x)) + `(defun ,alias (&rest x) (apply ',name x)))))) + +;;; common aliases +(!a + d describe + ap apropos + ! defparameter + m1 macroexpand-1) + +;;; SLIME integration +(when (find-package :swank) + (eval (read-from-string "(!a i swank:inspect-in-emacs)"))) diff --git a/driver.lisp b/driver.lisp index 5d525645a413cd2fcbc350087a4dbcd0314abee8..eb0fdfef4aa2bd9b2a7724cfbe199fdda7870e68 100644 --- a/driver.lisp +++ b/driver.lisp @@ -2,9 +2,13 @@ ;;;; Re-export all the functionality in asdf/driver (asdf/package:define-package :asdf/driver - (:use - :common-lisp :asdf/package :asdf/compatibility :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image :asdf/run-program :asdf/lisp-build) + (:use :common-lisp + :asdf/package :asdf/compatibility :asdf/utility + :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/run-program :asdf/lisp-build + :asdf/configuration) (:reexport :asdf/package :asdf/compatibility :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image :asdf/run-program :asdf/lisp-build)) + :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/run-program :asdf/lisp-build + :asdf/configuration)) diff --git a/find-system.lisp b/find-system.lisp index eddc75a367b46ff6773eeac69224167da160123d..6719843e7e6b1274c014432174c3cb97e37d4ead 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -20,7 +20,7 @@ #:initialize-source-registry #:sysdef-source-registry-search)) (in-package :asdf/find-system) -(declaim (ftype (function (&optional t) *) initialize-source-registry)) ; forward reference +(declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. @@ -84,7 +84,9 @@ of which is a system object.") (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) (unless (eq system (cdr (gethash name *defined-systems*))) (setf (gethash name *defined-systems*) - (cons (aif (ignore-errors (system-source-file system)) (safe-file-write-date it)) system))))) + (cons (if-bind (file (ignore-errors (system-source-file system))) + (safe-file-write-date file)) + system))))) (defun* clear-system (name) "Clear the entry for a system in the database of systems previously loaded. diff --git a/footer.lisp b/footer.lisp index 6cf5ae6fd36f692c1369f7352c29ff3e6befdbb6..08028cb70bae16084cb8fa5963f3e1aabfc3912f 100644 --- a/footer.lisp +++ b/footer.lisp @@ -57,7 +57,7 @@ #+allegro (eval-when (:compile-toplevel :execute) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) + (setf excl:*warn-on-nested-reader-conditionals* asdf/compatibility::*acl-warn-save*))) (dolist (f '(:asdf :asdf2 :asdf2.27)) (pushnew f *features*)) diff --git a/header.lisp b/header.lisp index daae007f4706d7286e16b9fc705292d0393e19b1..6116199274635f3b030f54240992f7b869cb470e 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.81: Another System Definition Facility. +;;; This is ASDF 2.26.82: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . diff --git a/image.lisp b/image.lisp index 3c71ce21c81e3fc3bfd57202f235b1749dfee8ea..0326e4807f0e885090601e32b8160c0200e7f9fa 100644 --- a/image.lisp +++ b/image.lisp @@ -7,7 +7,8 @@ (:export #:*arguments* #:*dumped* #:raw-command-line-arguments #:*command-line-arguments* #:*debugging* #:*post-image-restart* #:*entry-point* - #:quit #:die #:print-backtrace #:bork #:with-coded-exit #:shell-boolean + #: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 @@ -40,12 +41,11 @@ but before the entry point is called.") ;;; Exiting properly or im- -(defun quit (&optional (code 0) (finish-output t)) +(defun* quit (&optional (code 0) (finish-output t)) "Quits from the Lisp world, with the given exit status if provided. This is designed to abstract away the implementation specific quit forms." - (with-safe-io-syntax () - (when finish-output ;; essential, for ClozureCL, and for standard compliance. - (ignore-errors (finish-outputs)))) + (when finish-output ;; essential, for ClozureCL, and for standard compliance. + (finish-outputs)) #+(or abcl xcl) (ext:quit :status code) #+allegro (excl:exit code :quiet t) #+clisp (ext:quit code) @@ -54,7 +54,7 @@ This is designed to abstract away the implementation specific quit forms." #+(or cmu scl) (unix:unix-exit code) #+ecl (si:quit code) #+gcl (lisp:quit code) - #+genera (error "You probably don't want to Halt the Machine.") + #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) @@ -64,43 +64,85 @@ This is designed to abstract away the implementation specific quit forms." (exit `(,exit :code code :abort (not finish-output))) (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) - (error "xcvb driver: Quitting not implemented")) + (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) -(defun die (format &rest arguments) +(defun* die (code format &rest arguments) "Die in error with some error message" (with-safe-io-syntax () (ignore-errors - (format! *stderr* "~&") - (apply #'format! *stderr* format arguments) + (fresh-line *stderr*) + (apply #'format *stderr* format arguments) (format! *stderr* "~&"))) - (quit 99)) - -(defun print-backtrace (out) - "Print a backtrace (implementation-defined)" - (declare (ignorable out)) - #+clisp (system::print-backtrace) - #+clozure (let ((*debug-io* out)) - (ccl:print-call-history :count 100 :start-frame-number 1) - (finish-output out)) - #+ecl (si::tpl-backtrace) + (quit code)) + +(defun* raw-print-backtrace (&key (stream *debug-io*) count) + "Print a backtrace, directly accessing the implementation" + (declare (ignorable stream count)) + #+allegro + (let ((*terminal-io* stream) + (*standard-output* stream) + (tpl:*zoom-print-circle* *print-circle*) + (tpl:*zoom-print-level* *print-level*) + (tpl:*zoom-print-length* *print-length*)) + (tpl:do-command "zoom" + :from-read-eval-print-loop nil + :count t + :all t)) + #+clisp + (system::print-backtrace :out stream :limit count) + #+(or clozure mcl) + (let ((*debug-io* stream)) + (ccl:print-call-history :count count :start-frame-number 1) + (finish-output stream)) + #+(or cmucl scl) + (let ((debug:*debug-print-level* *print-level*) + (debug:*debug-print-length* *print-length*)) + (debug:backtrace most-positive-fixnum stream)) + #+ecl + (si::tpl-backtrace) + #+lispworks + (let ((dbg::*debugger-stack* + (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) + (*debug-io* stream) + (dbg:*debug-print-level* *print-level*) + (dbg:*debug-print-length* *print-length*)) + (dbg:bug-backtrace nil)) #+sbcl (sb-debug:backtrace - #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum) - out)) - -(defun bork (condition) + #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) + stream)) + +(defun* print-backtrace (&rest keys &key stream count) + (declare (ignore stream count)) + (with-safe-io-syntax (:package :cl) + (let ((*print-readably* nil) + (*print-circle* t) + (*print-miser-width* 75) + (*print-length* nil) + (*print-level* nil) + (*print-pretty* t)) + (ignore-errors (apply 'raw-print-backtrace keys))))) + +(defun* print-condition-backtrace (condition &key (stream *stderr*) count) + ;; We print the condition *after* the backtrace, + ;; for the sake of who sees the backtrace at a terminal. + ;; It is up to the caller to print the condition *before*, with some context. + (print-backtrace :stream stream :count count) + (when condition + (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" + condition))) + +(defun* bork (condition) "Depending on whether *DEBUGGING* is set, enter debugger or die" - (with-safe-io-syntax () - (ignore-errors (format! *stderr* "~&BORK:~%~A~%" condition))) + (safe-format! *stderr* "~&BORK:~%~A~%" condition) (cond (*debugging* (invoke-debugger condition)) (t - (with-safe-io-syntax () - (ignore-errors (print-backtrace *stderr*))) - (die "~A" condition)))) + (print-condition-backtrace condition :stream *stderr*) + (die 99 "~A" condition)))) -(defun call-with-coded-exit (thunk) +(defun* call-with-coded-exit (thunk) (handler-bind ((error 'bork)) (funcall thunk) (quit 0))) @@ -109,7 +151,7 @@ This is designed to abstract away the implementation specific quit forms." "Run BODY, BORKing on error and otherwise exiting with a success status" `(call-with-coded-exit #'(lambda () ,@body))) -(defun shell-boolean (x) +(defun* shell-boolean (x) "Quit with a return code that is 0 iff argument X is true" (quit (if x 0 1))) @@ -131,7 +173,7 @@ This is designed to abstract away the implementation specific quit forms." ;;; Build initialization -(defun initialize-asdf-utilities () +(defun* initialize-asdf-utilities () "Setup the XCVB environment with respect to debugging, profiling, performance" (setf *temporary-directory* (default-temporary-directory) *stderr* #-clozure *error-output* #+clozure ccl::*stderr*) @@ -140,7 +182,7 @@ This is designed to abstract away the implementation specific quit forms." ;;; Proper command-line arguments -(defun raw-command-line-arguments () +(defun* raw-command-line-arguments () "Find what the actual command line for this process was." #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! #+allegro (sys:command-line-arguments) ; default: :application t @@ -155,7 +197,7 @@ This is designed to abstract away the implementation specific quit forms." #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) -(defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) +(defun* command-line-arguments (&optional (arguments (raw-command-line-arguments))) "Extract user arguments from command-line invocation of current process. Assume the calling conventions of an XCVB-generated script if we are not called from a directly executable image dumped by XCVB." @@ -168,10 +210,10 @@ if we are not called from a directly executable image dumped by XCVB." (member "--" arguments :test 'string-equal)))) (rest arguments))) -(defun do-resume (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*)) +(defun* do-resume (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*)) (with-safe-io-syntax (:package :asdf) (let ((*read-eval* t)) - (when post-image-restart (load-string post-image-restart)))) + (when post-image-restart (eval-input post-image-restart)))) (with-coded-exit () (when entry-point (let ((ret (apply entry-point *arguments*))) @@ -179,21 +221,21 @@ if we are not called from a directly executable image dumped by XCVB." (quit ret) (quit 99)))))) -(defun resume () +(defun* resume () (setf *arguments* (command-line-arguments)) (do-resume)) ;;; Dumping an image -#-ecl -(defun dump-image (filename &key output-name executable pre-image-dump post-image-restart entry-point package) +#-(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 (load-string pre-image-dump)) - (setf *entry-point* (when entry-point (read-function entry-point))) + (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)))) #-(or clisp clozure cmu lispworks sbcl) (when executable @@ -241,5 +283,4 @@ if we are not called from a directly executable image dumped by XCVB." :executable t ;--- always include the runtime that goes with the core (when executable (list :toplevel #'resume :save-runtime-options t)))) ;--- only save runtime-options for standalone executables #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) - (die "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 this Lisp implementation.~%" filename)) diff --git a/interface.lisp b/interface.lisp index cec7dd77d587869e1822aed26f182b86feb27bf3..288a86e6b8db178536ee20647669c54e1fa75c25 100644 --- a/interface.lisp +++ b/interface.lisp @@ -11,11 +11,10 @@ #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function (:use :common-lisp - :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname - :asdf/stream :asdf/os :asdf/run-program :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/find-component - :asdf/operation :asdf/action :asdf/lisp-build :asdf/lisp-action - :asdf/configuration :asdf/output-translations :asdf/source-registry + :asdf/driver + :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-action + :asdf/output-translations :asdf/source-registry :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source :asdf/backward-interface) ;; TODO: automatically generate interface by merging select used packages? diff --git a/lisp-action.lisp b/lisp-action.lisp index 7c4a99a389db48b49bf811aabbd232fcd87e09d5..9d29f4fc5eb30d280ca0a03c7b0fb8c129ec378a 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -71,7 +71,7 @@ nil) (defmethod input-files ((o prepare-op) (s system)) (declare (ignorable o)) - (aif (system-source-file s) (list it))) + (if-bind (it (system-source-file s)) (list it))) ;;; compile-op (defmethod operation-description ((o compile-op) (c component)) @@ -93,10 +93,11 @@ (multiple-value-bind (output warnings-p failure-p) (call-with-around-compile-hook c #'(lambda (&rest flags) - (apply *compile-file-function* input-file - :output-file output-file - #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c) - (append flags (compile-op-flags o))))) + (with-controlled-compiler-conditions () + (apply *compile-file-function* input-file + :output-file output-file + :external-format (component-external-format c) + (append flags (compile-op-flags o)))))) (unless output (error 'compile-error :component c :operation o)) (when failure-p @@ -156,8 +157,9 @@ (format s "Recompile ~a and try loading it again" (component-name c))) (perform (find-operation o 'compile-op) c))))) -(defun perform-lisp-load-fasl (o c) - (load (first (input-files o c)))) +(defun* perform-lisp-load-fasl (o c) + (with-controlled-loader-conditions () + (load (first (input-files o c))))) (defmethod perform ((o load-op) (c cl-source-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-op) (c static-file)) @@ -185,7 +187,7 @@ nil) (defmethod input-files ((o prepare-source-op) (s system)) (declare (ignorable o)) - (aif (system-source-file s) (list it))) + (if-bind (it (system-source-file s)) (list it))) (defmethod perform ((o prepare-source-op) (c component)) (declare (ignorable o c)) nil) @@ -200,10 +202,13 @@ (defmethod component-depends-on ((o load-source-op) (c component)) (declare (ignorable o)) `((prepare-source-op ,c) ,@(call-next-method))) -(defun perform-lisp-load-source (o c) +(defun* perform-lisp-load-source (o c) (call-with-around-compile-hook - c #'(lambda () (load (first (input-files o c)) - #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c))))) + c #'(lambda () + (with-controlled-loader-conditions () + (load* (first (input-files o c)) + :external-format (component-external-format c)))))) + (defmethod perform ((o load-source-op) (c cl-source-file)) (perform-lisp-load-source o c)) (defmethod perform ((o load-source-op) (c static-file)) diff --git a/lisp-build.lisp b/lisp-build.lisp index fd9652d0fc232a38d2834526cd0cd83c9b6087db..7342f20a101df9ad35b57bafba57684be3036467 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -5,14 +5,24 @@ (:recycle :asdf/lisp-build :asdf) (:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/image) (:export + ;; Variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* - #:*compile-file-function* #:compile-file* #:compile-file-pathname* #:*output-translation-hook* - #:*optimization-settings* - #:*uninteresting-conditions* #:*uninteresting-load-conditions* - #:*fatal-conditions* #:*deferred-warnings* - #+(or ecl mkcl) #:compile-file-keeping-object + #:*compile-file-function* #:*output-translation-hook* + #:*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-asdf-compilation-unit #:with-asdf-compilation-unit #:lispize-pathname #:fasl-type #:call-around-hook - #:*output-translation-hook* + #:compile-file* #:compile-file-pathname* + #+(or ecl mkcl) #:compile-file-keeping-object + #:load* #:load-from-string #:combine-fasls)) (in-package :asdf/lisp-build) @@ -30,14 +40,12 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defvar *compile-file-function* 'compile-file* "Function used to compile lisp files.") -(defvar *output-translation-hook* 'identity) - ;;; Optimization settings (defvar *optimization-settings* nil) (defvar *previous-optimization-settings* nil) -(defun get-optimization-settings () +(defun* get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) #-(or clisp clozure cmu ecl sbcl scl) @@ -51,7 +59,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when #+(or cmu scl) (funcall f c::*default-cookie*) #+sbcl (cdr (assoc x sb-c::*policy*))) :when y :collect (list x y)))) -(defun proclaim-optimization-settings () +(defun* proclaim-optimization-settings () "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" (proclaim `(optimize ,@*optimization-settings*)) (let ((settings (get-optimization-settings))) @@ -61,45 +69,50 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ;;; Condition control -(defvar *uninteresting-conditions* +(defvar *uninteresting-conditions* nil + "Uninteresting conditions, as per MATCH-CONDITION-P") + +(defvar *uninteresting-compiler-conditions* (append #+sbcl '(sb-c::simple-compiler-note "&OPTIONAL and &KEY found in the same lambda list: ~S" sb-int:package-at-variance sb-kernel:uninteresting-redefinition - ;; the below four are controversial to include here; - ;; however there are issues with the asdf upgrade if they are not present - sb-kernel:redefinition-with-defun - sb-kernel:redefinition-with-defgeneric - sb-kernel:redefinition-with-defmethod - sb-kernel::redefinition-with-defmacro ; not exported by old SBCLs sb-kernel:undefined-alien-style-warning sb-ext:implicit-generic-function-warning sb-kernel:lexical-environment-too-complex - "Couldn't grovel for ~A (unknown to the C compiler).") + "Couldn't grovel for ~A (unknown to the C compiler)." + ;; BEWARE: the below four are controversial to include here. + sb-kernel:redefinition-with-defun + sb-kernel:redefinition-with-defgeneric + sb-kernel:redefinition-with-defmethod + sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs ;;#+clozure '(ccl:compiler-warning) - '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.") ;; from closer2mop - ) - "Conditions that may be skipped. type symbols, predicates or strings") + '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop + "Conditions that may be skipped while compiling") -(defvar *uninteresting-load-conditions* +(defvar *uninteresting-loader-conditions* (append '("Overwriting already existing readtable ~S." ;; from named-readtables #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers #+clisp '(clos::simple-gf-replacing-method-warning)) - "Additional conditions that may be skipped while loading. type symbols, predicates or strings") - -(defvar *fatal-conditions* - '(serious-condition) - "Conditions to be considered fatal during compilation.") + "Additional conditions that may be skipped while loading") (defvar *deferred-warnings* () "Warnings the handling of which is deferred until the end of the compilation unit") ;;;; ----- Filtering conditions while building ----- -(defun match-condition-p (x condition) +(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, @@ -109,53 +122,41 @@ or a string describing the format-control of a simple-condition." ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil))) (function (funcall x condition)) (string (and (typep condition 'simple-condition) - #+(or clozure cmu scl) ; Note: on SBCL, always bound, and testing triggers warning - (slot-boundp condition - #+clozure 'ccl::format-control - #+(or cmu scl) 'conditions::format-control) + #+(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) +(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) +(defun* uninteresting-condition-p (condition) "match CONDITION against any of the patterns of *UNINTERESTING-CONDITIONS*" (match-any-condition-p condition *uninteresting-conditions*)) -(defun fatal-condition-p (condition) - "match CONDITION against any of the patterns of *FATAL-CONDITIONS*" - (match-any-condition-p condition *fatal-conditions*)) - -(defun call-with-controlled-compiler-conditions (thunk) - (handler-bind - ((t - #'(lambda (condition) - ;; TODO: do something magic for undefined-function, - ;; save all of aside, and reconcile in the end of the virtual compilation-unit. - (cond - ((uninteresting-condition-p condition) - (muffle-warning condition)) - ((fatal-condition-p condition) - (bork condition)))))) - (funcall thunk))) - -(defmacro with-controlled-compiler-conditions ((&optional) &body body) - "Run BODY while suppressing conditions patterned after *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*)) +(defmacro with-controlled-compiler-conditions (() &body body) + "Run BODY where uninteresting compiler conditions are muffled" `(call-with-controlled-compiler-conditions #'(lambda () ,@body))) - -(defun call-with-controlled-loader-conditions (thunk) - (let ((*uninteresting-conditions* - (append - *uninteresting-load-conditions* - *uninteresting-conditions*))) - (call-with-controlled-compiler-conditions thunk))) - -(defmacro with-controlled-loader-conditions ((&optional) &body body) - "Run BODY while suppressing conditions patterned after *UNINTERESTING-CONDITIONS* plus a few others that don't matter at load-time." - `(call-with-controlled-loader-conditions #'(lambda () ,@body))) - -(defun save-forward-references (forward-references) +(defun* call-with-controlled-loader-conditions (thunk) + (call-with-muffled-uninteresting-conditions + thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*))) +(defmacro with-controlled-loader-conditions (() &body body) + "Run BODY where uninteresting compiler and additional loader conditions are muffled" + `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body))) + +(defun* save-forward-references (forward-references) + ;; TODO: replace with stuff in POIU "Save forward reference conditions so they may be issued at a latter time, possibly in a different process." #+sbcl @@ -190,7 +191,7 @@ possibly in a different process." (write *deferred-warnings* :stream s :pretty t :readably t) (terpri s)))) -(defun call-with-asdf-compilation-unit (thunk &key forward-references) +(defun* call-with-asdf-compilation-unit (thunk &key forward-references) (with-compilation-unit (:override t) (let ((*deferred-warnings* ()) #+sbcl (sb-c::*undefined-warnings* nil)) @@ -210,11 +211,17 @@ for processing later (possibly in a different process)." (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defun* fasl-type (&rest keys) + "pathname TYPE for lisp FASt Loading files" + (declare (ignorable keys)) + #-ecl (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+ecl (pathname-type (apply 'compile-file-pathname "foo.lisp" keys))) + (defun* call-around-hook (hook function) - (funcall (if hook (ensure-function hook) 'funcall) function)) + (call-function (or hook 'funcall) function)) (defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys) - (let* ((keywords (remove-keyword :compile-check keys)) + (let* ((keywords (remove-keys '(:compile-check #+gcl<2.7 :external-format) keys)) (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) (tmp-file (tmpize-pathname output-file)) (status :error)) @@ -242,12 +249,6 @@ for processing later (possibly in a different process)." (setf output-truename nil failure-p t))) (values output-truename warnings-p failure-p)))) -(defun* fasl-type (&rest keys) - "pathname TYPE for lisp FASt Loading files" - (declare (ignorable keys)) - #-ecl (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) - #+ecl (pathname-type (apply 'compile-file-pathname "foo.lisp" keys))) - (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (if (absolute-pathname-p output-file) ;; what cfp should be doing, w/ mp* instead of mp @@ -257,18 +258,33 @@ for processing later (possibly in a different process)." (merge-pathnames* output-file defaults)) (funcall *output-translation-hook* (apply 'compile-file-pathname input-file - (if output-file keys (remove-keyword :output-file keys)))))) - -;;; ECL and MKCL support for COMPILE-OP / LOAD-OP -;;; -;;; In ECL and MKCL, these operations produce both -;;; FASL files and the object files that they are built from. -;;; Having both of them allows us to later on reuse the object files -;;; for bundles, libraries, standalone executables, etc. -;;; -;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes -;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. -;;; + (remove-keys `(#+(and allegro (not (version>= 8 2))) :external-format + ,@(unless output-file '(:output-file))) keys))))) + +(defun* load* (x &rest keys &key external-format &allow-other-keys) + (declare (ignorable external-format)) + (etypecase x + ((or pathname string #-(or gcl-pre2.7 clozure allegro) stream) + (apply 'load x + #-gcl<2.7 keys #+gcl<2.7 (remove-keyword :external-format keys))) + #-(or gcl<2.7 clozure allegro) + ;; GCL 2.6 can't load from a string-input-stream + ;; ClozureCL 1.6 can only load from file input stream + ;; Allegro 5, I don't remember but it must have been broken when I tested. + (stream ;; make do this way + (let ((*load-pathname* nil) + (*load-truename* nil) + #+clozure (ccl::*default-external-format* external-format)) + (eval-input x))))) + +(defun* load-from-string (string) + "Portably read and evaluate forms from a STRING." + (with-input-from-string (s string) (load* s))) + +;;; In ECL and MKCL, compilation produces *both* +;; a loadable FASL file and the linkable object file that it was built from. +;; Having both of them allows us to later on reuse the object files +;; when linking bundles, libraries, standalone executables, etc. #+(or ecl mkcl) (progn (setf *compile-file-function* 'compile-file-keeping-object) @@ -288,11 +304,11 @@ for processing later (possibly in a different process)." flags1 flags2))))) +;;; Links FASLs together (defun* combine-fasls (inputs output) #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) - (declare (ignore inputs output)) - #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) - (error "~S is not supported on ~A" 'combine-fasls (implementation-type)) + (error "~A does not support ~S~%inputs ~S~%output ~S" + (implementation-type) 'combine-fasls inputs output) #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) #+lispworks diff --git a/operate.lisp b/operate.lisp index a96f6250f75780d3bc25e61b7ca75face01c32c4..9ca73eb4e8977d70cbcf66c175e6301ab0a0574d 100644 --- a/operate.lisp +++ b/operate.lisp @@ -8,7 +8,7 @@ :asdf/lisp-build :asdf/lisp-action #:asdf/plan :asdf/find-system :asdf/find-component) (:export - #:operate #:oos #:*systems-being-operated* + #:operate #:oos #:*systems-being-operated* #:*asdf-upgrade-already-attempted* #:load-system #:load-systems #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf #:component-loaded-p #:already-loaded-systems @@ -17,26 +17,6 @@ (defgeneric* operate (operation-class system &key &allow-other-keys)) -(defun* reset-asdf-systems () - (let ((asdf (symbol-call :asdf 'find-system :asdf))) - ;; Invalidate all systems but ASDF itself. - (setf *defined-systems* (make-defined-systems-table)) - (register-system asdf) - (symbol-call :asdf 'load-system :asdf))) ;; load ASDF a second time, the right way. - -(defun* restart-upgraded-asdf () - ;; If we're in the middle of something, restart it. - (when *systems-being-defined* - (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) - (clrhash *systems-being-defined*) - (dolist (s l) (find-system s nil))))) - -(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*) -(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*) - - -;;;; Operate itself - (defvar *systems-being-operated* nil "A boolean indicating that some systems are being operated on") @@ -45,6 +25,7 @@ (on-warnings *compile-file-warnings-behaviour*) (on-failure *compile-file-failure-behaviour*) &allow-other-keys) (declare (ignorable operation-class system)) + ;; Setup proper bindings around any operate call. (with-system-definitions () (let* ((*asdf-verbose* verbose) (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) @@ -81,25 +62,17 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))) (check-type system system) (setf (gethash (coerce-name system) *systems-being-operated*) system) - (flet ((upgrade () - ;; If we needed to upgrade ASDF to achieve our goal, - ;; then do it specially as the first thing, - ;; which will invalidate all existing systems; - ;; afterwards, try again with the new OPERATE function, - ;; which on some implementations may be a new symbol. - (unless (gethash "asdf" *systems-being-operated*) - (upgrade-asdf) - (return-from operate - (apply (find-symbol* 'operate :asdf) operation-class system args))))) - (when systems-being-operated ;; Upgrade if loading a system from another one. - (upgrade)) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((plan (apply 'traverse op system args))) - (when (plan-operates-on-p plan '("asdf")) - (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time. - (perform-plan plan) - (values op plan))))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + ;; Before we operate on any system, make sure ASDF is up-to-date, + ;; for if an upgrade is attempted at any later time, there may be trouble. + ;; If we upgraded, restart the OPERATE from scratch, + ;; for the function will have been redefined. + (if (upgrade-asdf) + (apply 'operate operation-class system args) + (let ((plan (apply 'traverse op system args))) + (perform-plan plan) + (values op plan))))) (defun* oos (operation-class system &rest args &key force force-not verbose version &allow-other-keys) @@ -116,7 +89,10 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (defvar *load-system-operation* 'load-op "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, -or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") +or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken. + +This may change in the future as we will implement component-based strategy +for how to load or compile stuff") (defun* load-system (system &rest keys &key force force-not verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." @@ -125,6 +101,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") t) (defun* load-systems (&rest systems) + "Loading multiple systems at once." (map () 'load-system systems)) (defun* compile-system (system &rest args &key force force-not verbose version &allow-other-keys) @@ -140,7 +117,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") t) -;;;; require-system, and hooking it into CL:REQUIRE when possible, +;;;; Define require-system, to be hooked into CL:REQUIRE when possible, ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL (defun* component-loaded-p (c) @@ -151,11 +128,10 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") (defun* require-system (s &rest keys &key &allow-other-keys) (apply 'load-system s :force-not (already-loaded-systems) keys)) - + (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) - #-genera (missing-component (constantly nil)) (error #'(lambda (e) (format *error-output* (compatfmt "~@~%") @@ -166,3 +142,22 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") (require-system system :verbose nil) t)))) + +;;;; Some upgrade magic + +(defun* reset-asdf-systems () + (let ((asdf (find-system :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + (load-system asdf))) ;; re-load ourselves the right way + +(defun* restart-upgraded-asdf () + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil))))) + +(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*) +(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*) diff --git a/os.lisp b/os.lisp index 8067e9acc789449b4f2fdf599f6011739cf054d4..3c1024504f63919e3f696262c8d900002f426d36 100644 --- a/os.lisp +++ b/os.lisp @@ -6,7 +6,7 @@ (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream) (:export #:featurep #:os-unix-p #:os-windows-p ;; features - #:getenv ;; environment variables, and parsing them + #:getenv #:getenvp ;; environment variables #:inter-directory-separator #:split-pathnames* #:getenv-pathname #:getenv-pathnames #:getenv-absolute-directory #:getenv-absolute-directories @@ -39,7 +39,7 @@ (defun* os-windows-p () (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) - (defun detect-os () + (defun* detect-os () (flet ((yes (yes) (pushnew yes *features*)) (no (no) (setf *features* (remove no *features*)))) (cond @@ -80,7 +80,7 @@ that is neither Unix, nor Windows.~%Now you port it."))))) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) -(defun getenvp (x) +(defun* getenvp (x) "Predicate that is true if the named variable is present in the libc environment, then returning the non-empty string value of the variable" (let ((g (getenv x))) (and (not (emptyp g)) g))) @@ -215,9 +215,9 @@ then returning the non-empty string value of the variable" #+clozure #p"ccl:" #+(or ecl mkcl) #p"SYS:" #+gcl system::*system-directory* - #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int nil) - (funcall it) - (getenv-pathname "SBCL_HOME" :want-directory t))))) + #+sbcl (if-bind (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :want-directory t))))) (if (and dir truename) (truename* dir) dir))) @@ -225,7 +225,7 @@ then returning the non-empty string value of the variable" ;;; Current directory -(defun getcwd () +(defun* getcwd () "Get the current working directory as per POSIX getcwd(3)" (or #+clisp (ext:default-directory) #+clozure (ccl:current-directory) @@ -236,7 +236,7 @@ then returning the non-empty string value of the variable" #+sbcl (sb-unix:posix-getcwd/) (error "getcwd not supported on your implementation"))) -(defun chdir (x) +(defun* chdir (x) "Change current directory, as per POSIX chdir(2)" #-(or clisp clozure) (when (pathnamep x) (setf x (native-namestring x))) (or #+clisp (ext:cd x) @@ -246,7 +246,7 @@ then returning the non-empty string value of the variable" #+sbcl (symbol-call :sb-posix :chdir x) (error "chdir not supported on your implementation"))) -(defun call-with-current-directory (dir thunk) +(defun* call-with-current-directory (dir thunk) (if dir (let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir)))) (*default-pathname-defaults* dir) @@ -274,10 +274,10 @@ then returning the non-empty string value of the variable" (defvar *temporary-directory* nil) -(defun temporary-directory () +(defun* temporary-directory () (or *temporary-directory* (default-temporary-directory))) -(defun call-with-temporary-file +(defun* call-with-temporary-file (thunk &key prefix keep (direction :io) (element-type *default-stream-element-type*) diff --git a/package.lisp b/package.lisp index e80277cc279b923821e60a762d05417c51fb19cc..8aa51f9b03db98300aed84e6211235ca3156b239 100644 --- a/package.lisp +++ b/package.lisp @@ -20,24 +20,6 @@ (in-package :asdf/package) -(defmacro DBG (tag &rest exprs) - "simple debug statement macro: -outputs a tag plus a list of variable and their values, returns the last value" - ;;"if not in debugging mode, just compute and return last value" - ;; #-DBGXXX (declare (ignore tag)) #-DBGXXX (car (last exprs)) #+DBGXXX - (let ((res (gensym))(f (gensym))) - `(let (,res (*print-readably* nil)) - (flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args))) - (fresh-line *standard-output*) (fresh-line *trace-output*) (fresh-line *error-output*) - (,f "~&~A~%" ,tag) - ,@(mapcan - #'(lambda (x) - `((,f "~& ~S => " ',x) - (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x))))) - exprs) - (apply 'values ,res))))) - - ;;;; General purpose package utilities (eval-when (:load-toplevel :compile-toplevel :execute) @@ -342,17 +324,22 @@ or when loading the package is optional." (export sym p)) (ensure-exported-to-user (name sym u) (multiple-value-bind (usym ustat) (find-symbol name u) - (unless (eq sym usym) - (let ((shadowing (member usym (package-shadowing-symbols u)))) - (block nil - (cond - ((not shadowing) - (unintern usym u)) - ((symbol-recycled-p usym) - (shadowing-import sym u)) - (t (return))) - (when (eq ustat :external) - (ensure-exported name sym u)))))))) + (unless (and ustat (eq sym usym)) + (let ((shadowed + (when ustat + (let ((shadowing (symbol-shadowing-p usym u)) + (recycled (symbol-recycled-p usym))) + (cond + ((and shadowing (not recycled)) + t) + ((or (eq ustat :inherited) shadowing) + (shadowing-import sym u) + nil) + (t + (unintern usym u) + nil)))))) + (when (and (not shadowed) (eq ustat :external)) + (ensure-exported name sym u))))))) #-gcl (setf (documentation package t) documentation) #+gcl documentation (loop :for p :in discarded :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) diff --git a/pathname.lisp b/pathname.lisp index 098eb8aa84ef926aac3e1dfdad22d24100d9dd83..4e09ea337d57c4e1c9947ebfa62f92825f90f40f 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -51,7 +51,10 @@ #:physical-pathname-p #:sane-physical-pathname ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian - #:parse-file-location-info #:parse-windows-shortcut)) + #:parse-file-location-info #:parse-windows-shortcut + ;; Output translations + #:*output-translation-hook*)) + (in-package :asdf/pathname) ;;; User-visible parameters @@ -114,12 +117,16 @@ Defaults to T.") :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) (defun* make-pathname* (&rest keys &key (directory nil directoryp) - host device name type version defaults #+scl &allow-other-keys) - (declare (ignore host device name type version defaults)) + host (device () devicep) name type version defaults + #+scl &allow-other-keys) + (declare (ignorable host device devicep name type version defaults)) (apply 'make-pathname - (append (when directoryp - `(:directory ,(denormalize-pathname-directory-component directory))) - keys))) + (append + #+(and allegro (version>= 9 0) unix) + (when (and devicep (null device)) `(:device :unspecific)) + (when directoryp + `(:directory ,(denormalize-pathname-directory-component directory))) + keys))) (defun* make-pathname-component-logical (x) "Make a pathname component suitable for use in a logical-pathname" @@ -234,7 +241,7 @@ actually-existing directory." (defparameter *wild* (or #+cormanlisp "*" :wild)) (defparameter *wild-file* (make-pathname :directory nil :name *wild* :type *wild* - :version (or #-(or abcl xcl) *wild*))) + :version (or #-(or allegro abcl xcl) *wild*))) (defparameter *wild-directory* (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "*" *wild*)) :name nil :type nil :version nil)) @@ -250,13 +257,13 @@ actually-existing directory." ;;; Probing the filesystem (defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) - (make-pathname :directory nil :name nil :type nil :version nil :device nil :host nil - :defaults defaults)) ;; shouldn't matter + (make-pathname* :directory nil :name nil :type nil :version nil :device nil :host nil + :defaults defaults)) ;; The defaults shouldn't matter (defmacro with-pathname-defaults ((&optional defaults) &body body) `(let ((*default-pathname-defaults* ,(or defaults (nil-pathname)))) ,@body)) -(defun truename* (p) +(defun* truename* (p) ;; avoids both logical-pathname merging and physical resolution issues (ignore-errors (with-pathname-defaults () (truename p)))) @@ -270,8 +277,8 @@ with given pathname and if it exists return its truename." (pathname (unless (wild-pathname-p p) #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol* '#:probe-pathname :ext nil) - `(ignore-errors (,it p))) + #+clisp (if-bind (it (find-symbol* '#:probe-pathname :ext nil)) + `(ignore-errors (,it p))) #+gcl<2.7 '(or (probe-file p) (and (directory-pathname-p p) @@ -510,9 +517,9 @@ Host, device and version components are taken from DEFAULTS." . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun* pathname-host-pathname (pathname) - (make-pathname :directory nil - :name nil :type nil :version nil :device nil - :defaults pathname ;; host device, and on scl, *some* + (make-pathname* :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) @@ -677,7 +684,7 @@ Host, device and version components are taken from DEFAULTS." ;;; Native vs Lisp syntax -(defun native-namestring (x) +(defun* native-namestring (x) "From a CL pathname, a namestring suitable for use by the OS shell" (let ((p (pathname x))) #+clozure (let ((*default-pathname-defaults* #p"")) (ccl:native-translated-namestring p)) ; see ccl bug 978 @@ -685,7 +692,7 @@ Host, device and version components are taken from DEFAULTS." #+sbcl (sb-ext:native-namestring p) #-(or clozure cmu sbcl scl) (namestring p))) -(defun parse-native-namestring (x) +(defun* parse-native-namestring (x) "From a native namestring suitable for use by the OS shell, a CL pathname" (check-type x string) #+clozure (ccl:native-to-pathname x) @@ -825,3 +832,6 @@ For the latter case, we ought pick random suffix and atomically open it." (end-of-file (c) (declare (ignore c)) nil))))) + +;;; Hook for output translations +(defvar *output-translation-hook* 'identity) diff --git a/plan.lisp b/plan.lisp index ce3ae40b0620ce3572b8345320b9a7b3862908c0..ad08a4fcd6d218a09e582abe21eabca35a0b6d51 100644 --- a/plan.lisp +++ b/plan.lisp @@ -104,7 +104,7 @@ the action of OPERATION on COMPONENT in the PLAN")) (:documentation "Is this action valid to include amongst dependencies?")) (defmethod action-valid-p (plan operation (c component)) (declare (ignorable plan operation)) - (aif (component-if-feature c) (featurep it) t)) + (if-bind (it (component-if-feature c)) (featurep it) t)) (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil) (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil) @@ -138,7 +138,8 @@ the action of OPERATION on COMPONENT in the PLAN")) (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) ;; In a distant future, safe-file-write-date and component-operation-time ;; shall also be parametrized by the plan, or by a second model object. - (let* ((stamp-lookup #'(lambda (o c) (aif (plan-action-status plan o c) (action-stamp it) t))) + (let* ((stamp-lookup #'(lambda (o c) + (if-bind (it (plan-action-status plan o c)) (action-stamp it) t))) (out-files (output-files o c)) (in-files (input-files o c)) ;; Three kinds of actions: diff --git a/run-program.lisp b/run-program.lisp index 6d861a168664e9ea318934f9e6b80f54a3588502..77e62f1424a9537e03f28797e0988f161ccc3d8d 100644 --- a/run-program.lisp +++ b/run-program.lisp @@ -18,7 +18,7 @@ ;;;; ----- Escaping strings for the shell ----- -(defun requires-escaping-p (token &key good-chars bad-chars) +(defun* requires-escaping-p (token &key good-chars bad-chars) "Does this token require escaping, given the specification of either good chars that don't need escaping or bad chars that do need escaping, as either a recognizing function or a sequence of characters." @@ -37,7 +37,7 @@ as either a recognizing function or a sequence of characters." (t (error "requires-escaping-p: no good-char criterion"))) token)) -(defun escape-token (token &key stream quote good-chars bad-chars escaper) +(defun* escape-token (token &key stream quote good-chars bad-chars escaper) "Call the ESCAPER function on TOKEN string if it needs escaping as per REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, using STREAM as output (or returning result as a string if NIL)" @@ -46,7 +46,7 @@ using STREAM as output (or returning result as a string if NIL)" (apply escaper token stream (when quote `(:quote ,quote)))) (output-string token stream))) -(defun escape-windows-token-within-double-quotes (x &optional s) +(defun* escape-windows-token-within-double-quotes (x &optional s) "Escape a string token X within double-quotes for use within a MS Windows command-line, outputing to S." (labels ((issue (c) (princ c s)) @@ -71,13 +71,13 @@ for use within a MS Windows command-line, outputing to S." (otherwise (issue (char x i)) (setf i i+1)))))) -(defun escape-windows-token (token &optional s) +(defun* escape-windows-token (token &optional s) "Escape a string TOKEN within double-quotes if needed for use within a MS Windows command-line, outputing to S." (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil :escaper 'escape-windows-token-within-double-quotes)) -(defun escape-sh-token-within-double-quotes (x s &key (quote t)) +(defun* escape-sh-token-within-double-quotes (x s &key (quote t)) "Escape a string TOKEN within double-quotes for use within a POSIX Bourne shell, outputing to S; omit the outer double-quotes if key argument :QUOTE is NIL" @@ -87,22 +87,22 @@ omit the outer double-quotes if key argument :QUOTE is NIL" (princ c s)) (when quote (princ #\" s))) -(defun easy-sh-character-p (x) +(defun* easy-sh-character-p (x) (or (alphanumericp x) (find x "+-_.,%@:/"))) -(defun escape-sh-token (token &optional s) +(defun* escape-sh-token (token &optional s) "Escape a string TOKEN within double-quotes if needed for use within a POSIX Bourne shell, outputing to S." (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p :escaper 'escape-sh-token-within-double-quotes)) -(defun escape-shell-token (token &optional s) +(defun* escape-shell-token (token &optional s) (cond ((os-unix-p) (escape-sh-token token s)) ((os-windows-p) (escape-windows-token token s)))) -(defun escape-command (command &optional s +(defun* escape-command (command &optional s (escaper 'escape-shell-token)) "Given a COMMAND as a list of tokens, return a string of the spaced, escaped tokens, using ESCAPER to escape." @@ -113,27 +113,26 @@ spaced, escaped tokens, using ESCAPER to escape." (unless first (princ #\space s)) (funcall escaper token s)))))) -(defun escape-windows-command (command &optional s) +(defun* escape-windows-command (command &optional s) "Escape a list of command-line arguments into a string suitable for parsing by CommandLineToArgv in MS Windows" ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx (escape-command command s 'escape-windows-token)) -(defun escape-sh-command (command &optional s) +(defun* escape-sh-command (command &optional s) "Escape a list of command-line arguments into a string suitable for parsing by /bin/sh in POSIX" (escape-command command s 'escape-sh-token)) -(defun escape-shell-command (command &optional stream) +(defun* escape-shell-command (command &optional stream) "Escape a command for the current operating system's shell" (escape-command command stream 'escape-shell-token)) -;;;; ----- Running an external program ----- -;;; Simple variant of run-program with no input, and capturing output -;;; On some implementations, may output to a temporary file... -(defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys)) +;;;; Slurping a stream, typically the output of another program + +(defgeneric* slurp-input-stream (processor input-stream &key &allow-other-keys)) (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) (funcall function input-stream)) @@ -166,6 +165,11 @@ by /bin/sh in POSIX" (declare (ignorable x)) (slurp-stream-forms stream)) + +;;;; ----- Running an external program ----- +;;; Simple variant of run-program with no input, and capturing output +;;; On some implementations, may output to a temporary file... + (define-condition subprocess-error (error) ((code :initform nil :initarg :code :reader subprocess-error-code) (command :initform nil :initarg :command :reader subprocess-error-command) @@ -176,7 +180,7 @@ by /bin/sh in POSIX" (subprocess-error-command condition) (subprocess-error-code condition))))) -(defun run-program/ (command +(defun* run-program/ (command &key output ignore-error-status force-shell (element-type *default-stream-element-type*) (external-format :default) diff --git a/source-registry.lisp b/source-registry.lisp index e2bdea1f5ca2779e203d4a152d74f0b0ab2f978f..41ad5ec8f5c611f43d2d75340fa2359e01d05881 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -288,6 +288,7 @@ with a different configuration, so the configuration would be re-read then." (defvar *source-registry-parameter* nil) (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) + (setf *asdf-upgrade-already-attempted* nil) ;; in case a new ASDF appears in the registry (setf *source-registry-parameter* parameter) (setf *source-registry* (make-hash-table :test 'equal)) (compute-source-registry parameter)) diff --git a/stream.lisp b/stream.lisp index e705d405085d90cb1f30ea13448956d4eabd06e1..6f428712d13a97ce3a2d62b86077782311e9e497 100644 --- a/stream.lisp +++ b/stream.lisp @@ -6,15 +6,16 @@ (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname) (:export #:*default-stream-element-type* #:*stderr* - #:finish-outputs #:format! - #:with-output #:output-string #:with-input #:call-with-input-file - #:with-safe-io-syntax #:read-function + #:with-safe-io-syntax #:call-with-safe-io-syntax + #:with-output #:output-string #:with-input + #:with-input-file #:call-with-input-file + #:finish-outputs #:format! #:safe-format! #:read-file-forms #:read-first-file-form #:copy-stream-to-stream #:concatenate-files #:copy-stream-to-stream-line-by-line #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-forms #:slurp-file-string - #:slurp-file-lines #:slurp-file-forms + #:read-file-lines #:read-file-forms #:eval-input #: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*)) @@ -27,21 +28,18 @@ "the original error output stream at startup") -;;; Ensure output buffers are flushed +;;; Safe syntax -(defun finish-outputs () - "Finish output on the main output streams. -Useful for portably flushing I/O before user input or program exit." - ;; CCL notably buffers its stream output by default. - (dolist (s (list *stderr* *error-output* *standard-output* *trace-output*)) - (ignore-errors (finish-output s))) - (values)) +(defmacro with-safe-io-syntax ((&key (package :cl)) &body body) + "Establish safe CL reader options around the evaluation of BODY" + `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) -(defun format! (stream format &rest args) - "Just like format, but call finish-outputs before and after the output." - (finish-outputs) - (apply 'format stream format args) - (finish-output stream)) +(defun* call-with-safe-io-syntax (thunk &key (package :cl)) + (with-standard-io-syntax () + (let ((*package* (find-package package)) + (*print-readably* nil) + (*read-eval* nil)) + (funcall thunk)))) ;;; Output to a stream or string, FORMAT-style @@ -80,7 +78,7 @@ Otherwise, signal an error.") as per FORMAT, and evaluate BODY within the scope of this binding." `(call-with-output ,value #'(lambda (,x) ,@body))) -(defun output-string (string &optional stream) +(defun* output-string (string &optional stream) (if stream (with-output (stream) (princ string stream)) string)) @@ -88,7 +86,29 @@ as per FORMAT, and evaluate BODY within the scope of this binding." ;;; Input helpers -(defun call-with-input-file (pathname thunk +(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. +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)))) + +(defmacro with-input ((x &optional (value x)) &body body) + `(call-with-input ,value #'(lambda (,x) ,@body))) + +(defun* call-with-input-file (pathname thunk &key (element-type *default-stream-element-type*) (external-format :default)) "Open FILE for input with given options, call THUNK with the resulting stream." @@ -102,35 +122,27 @@ as per FORMAT, and evaluate BODY within the scope of this binding." `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) -;;; Reading helpers - -(defmacro with-safe-io-syntax ((&key (package :cl)) &body body) - "Establish safe CL reader options around the evaluation of BODY" - `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) - -(defun call-with-safe-io-syntax (thunk &key (package :cl)) - (with-standard-io-syntax () - (let ((*package* (find-package package)) - (*print-readably* nil) - (*read-eval* nil)) - (funcall thunk)))) +;;; Ensure output buffers are flushed -(defun read-function (string) - "Read a form from a string in function context, return a function" - (eval `(function ,(read-from-string string)))) +(defun* finish-outputs (&rest streams) + "Finish output on the main output streams as well as any specified one. +Useful for portably flushing I/O before user input or program exit." + ;; CCL notably buffers its stream output by default. + (dolist (s (append streams + (list *stderr* *error-output* *standard-output* *trace-output* *debug-io*))) + (ignore-errors (finish-output s))) + (values)) -(defun* read-file-forms (file) - (with-open-file (in file) - (loop :with eof = (list nil) - :for form = (read in nil eof) - :until (eq form eof) - :collect form))) +(defun* format! (stream format &rest args) + "Just like format, but call finish-outputs before and after the output." + (finish-outputs stream) + (apply 'format stream format args) + (finish-output stream)) -(defun read-first-file-form (pathname &key (package :cl) eof-error-p eof-value) - "Reads the first form from the top of a file using a safe standardized syntax" - (with-safe-io-syntax (:package package) - (with-input-file (in pathname) - (read in eof-error-p eof-value)))) +(defun* safe-format! (stream format &rest args) + (with-safe-io-syntax () + (ignore-errors (apply 'format! stream format args)) + (finish-outputs stream))) ; just in case format failed ;;; Simple Whole-Stream processing @@ -154,7 +166,7 @@ using WRITE-SEQUENCE and a sensibly sized buffer." :direction :input :if-does-not-exist :error) (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) -(defun copy-stream-to-stream-line-by-line (input output &key prefix) +(defun* copy-stream-to-stream-line-by-line (input output &key prefix) "Copy the contents of the INPUT stream into the OUTPUT stream, reading contents line by line." (with-open-stream (input input) @@ -166,36 +178,59 @@ reading contents line by line." (finish-output output) (when eof (return))))) -(defun slurp-stream-string (input &key (element-type 'character)) +(defun* slurp-stream-string (input &key (element-type 'character)) "Read the contents of the INPUT stream as a string" (with-open-stream (input input) (with-output-to-string (output) (copy-stream-to-stream input output :element-type element-type)))) -(defun slurp-stream-lines (input) +(defun* slurp-stream-lines (input) "Read the contents of the INPUT stream as a list of lines" (with-open-stream (input input) (loop :for l = (read-line input nil nil) :while l :collect l))) -(defun slurp-stream-forms (input) - "Read the contents of the INPUT stream as a list of forms" +(defun* slurp-stream-forms (input) + "Read the contents of the INPUT stream as a list of forms. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (with-open-stream (input input) (loop :with eof = '#:eof :for form = (read input nil eof) :until (eq form eof) :collect form))) -(defun slurp-file-string (file &rest keys) +(defun* read-file-string (file &rest keys) "Open FILE with option KEYS, read its contents as a string" (apply 'call-with-input-file file 'slurp-stream-string keys)) -(defun slurp-file-lines (file &rest keys) - "Open FILE with option KEYS, read its contents as a list of lines" +(defun* read-file-lines (file &rest keys) + "Open FILE with option KEYS, read its contents as a list of lines +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file 'slurp-stream-lines keys)) -(defun slurp-file-forms (file &rest keys) - "Open FILE with option KEYS, read its contents as a list of forms" +(defun* read-file-forms (file &rest keys) + "Open FILE with option KEYS, read its contents as a list of forms. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file 'slurp-stream-forms keys)) +(defun* read-first-file-form (pathname &key eof-error-p eof-value) + "Reads the first form from the top of a file. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (with-input-file (in pathname) + (read in eof-error-p eof-value))) + +(defun* safe-read-first-file-form (pathname &key (package :cl) eof-error-p eof-value) + "Reads the first form from the top of a file using a safe standardized syntax" + (with-safe-io-syntax (:package package) + (read-first-file-form pathname :eof-error-p eof-error-p :eof-value eof-value))) + +(defun* eval-input (input) + "Portably read and evaluate forms from INPUT, return the last values." + (with-input (input) + (loop :with results :with eof ='#:eof + :for form = (read input nil eof) + :until (eq form eof) + :do (setf results (multiple-value-list (eval form))) + :finally (return (apply 'values results))))) + ;;; Encodings diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index 77c9acbb4a363e8b6781d41e625e3cfb2487a607..18b3f3cbd766ce5aacd09ee98e816530babdebb9 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -32,7 +32,7 @@ ;;; (:file "module1-1/file3.lisp") means #p"module1-1/file3.lisp.lisp" (assuming /) ;;; (:static-file "module1-1/file3.lisp") means #p"module1-1/file3.lisp" -(defun test-component-pathnames (&key (root (asdf::pathname-directory-pathname *asdf-fasl*)) +(defun test-component-pathnames (&key (root *build-directory*) (delete-host t) (support-string-pathnames nil) (support-absolute-string-pathnames nil)) @@ -310,7 +310,7 @@ (loop :for key :being :the :hash-keys :of table :using (:hash-value value) :collect (cons key value))) -(quit-on-error +(with-test () (asdf:initialize-source-registry) (format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*)) (asdf:initialize-output-translations) @@ -334,7 +334,7 @@ #-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6 (or (test-component-pathnames :delete-host t :support-string-pathnames nil) - (leave-lisp "test failed" 1))) + (leave-test "test failed" 1))) ;;; (load "LIBRARY:de;setf;utility;asdf;cp-test.lisp") ;;; (logical-pathname-translations "ASDFTEST") diff --git a/test/compile-asdf.lisp b/test/compile-asdf.lisp deleted file mode 100644 index 1d3817aa4114eeac7b0985f2342d20a9f2fbfc6d..0000000000000000000000000000000000000000 --- a/test/compile-asdf.lisp +++ /dev/null @@ -1,51 +0,0 @@ -(cl:in-package :common-lisp-user) - -(defun load-pathname () - #-gcl *load-pathname* - #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 - (symbol-value - (find-symbol - "*LOAD-PATHNAME*" - (if (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all - (and (= system::*gcl-major-version* 2) - (< system::*gcl-minor-version* 7))) - :system :cl)))) - -(load (make-pathname :name "script-support" :type "lisp" :defaults (load-pathname)) - #+gcl :print #+gcl t) - -(in-package :asdf-test) - -(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3) - #+(or cmu scl) (c::brevity 2))) -(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3) - #+(or cmu scl) (c::brevity 2))) - -(cond - ((not (probe-file *asdf-lisp*)) - (leave-lisp "Testsuite failed: unable to find ASDF source" 3)) - ((and (probe-file *asdf-fasl*) - (> (file-write-date *asdf-fasl*) (file-write-date *asdf-lisp*)) - (ignore-errors (load *asdf-fasl*))) - (leave-lisp "Reusing previously-compiled ASDF" 0)) - (t - (load-asdf-lisp) - (let ((tmp (make-pathname :name "asdf-tmp" :defaults *asdf-fasl*))) - (multiple-value-bind (result warnings-p errors-p) - (compile-asdf tmp) - (declare (ignore result)) - (cond - (errors-p - (leave-lisp "Testsuite failed: ASDF compiled with ERRORS" 2)) - #-(or cmu ecl scl xcl) - ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291. - ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?) - (warnings-p - (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1)) - (t - (when warnings-p - (format t "Your implementation raised warnings, but they were ignored~%")) - (when (probe-file *asdf-fasl*) - (delete-file *asdf-fasl*)) - (rename-file tmp *asdf-fasl*) - (leave-lisp "ASDF compiled cleanly" 0))))))) diff --git a/test/run-shell-command-test.script b/test/run-shell-command-test.script index 4183d7ebf72f1750e3f537cccb672cf0ec91c167..bbc2cf60aee21825b081bdabe16d25a635915531 100644 --- a/test/run-shell-command-test.script +++ b/test/run-shell-command-test.script @@ -3,7 +3,7 @@ (load-asdf) ;;; test asdf run-shell-command function -(quit-on-error +(with-test () #+asdf-unix (progn (assert (eql 1 (asdf:run-shell-command "false"))) diff --git a/test/run-tests.sh b/test/run-tests.sh index 81d9a440d751df3c3ac7a4c6c75f892d9bf90b13..64c0e566182614f66203dae2e1fa80370f52c3cc 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -15,10 +15,11 @@ usage () { echo " clisp, cmucl, ecl, gcl, gclcvs, sbcl, scl and xcl." echo "OPTIONS:" echo " -d -- debug mode" - echo " -u -h -- show this message." + echo " -h -- show this message." + echo " -u -- upgrade tests." } -unset DEBUG_ASDF_TEST +unset DEBUG_ASDF_TEST upgrade while getopts "duh" OPTION do @@ -27,8 +28,7 @@ do export DEBUG_ASDF_TEST=t ;; u) - usage - exit 1 + upgrade=t ;; h) usage @@ -57,7 +57,7 @@ DO () { ( set -x ; "$@" ); } do_tests() { command="$1" eval="$2" rm -f ~/.cache/common-lisp/"`pwd`"/* || true - ( cd .. && DO $command $eval '(load "test/compile-asdf.lisp")' ) + ( cd .. && DO $command $eval '(or #.(load "test/script-support.lisp") #.(asdf-test::compile-asdf-script))' ) if [ $? -ne 0 ] ; then echo "Compilation FAILED" >&2 else @@ -204,21 +204,85 @@ fi create_config () { mkdir -p ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d } - +upgrade_tags () { + if [ -n "$TEST_ASDF_TAGS" ] ; then + echo $TEST_ASDF_TAGS ; return + fi + # 1.37 is the last release by Daniel Barlow + # 1.97 is the last release before Gary King takes over + # 1.369 is the last release by Gary King + # 2.000 to 2.019 and 2.20 to 2.27 and beyond are Faré's "stable" releases + echo 1.37 1.97 1.369 + git tag -l '2.0??' + git tag -l '2.??' +} +extract_tagged_asdf () { + ver=$1 + file=build/asdf-${tag}.lisp ; + if [ ! -f $file ] ; then + case $ver in + 1.*|2.0*|2.2[0-6]) + git show ${tag}:asdf.lisp > $file ;; + *) + echo "Don't know how to extract asdf.lisp for version $tag" + exit 55 + ;; + esac + fi +} +run_upgrade_tests () { + su=test/script-support.lisp + lu="(load\"$su\")" + lv="$command $eval $lu $eval" ; + for tag in `upgrade_tags` ; do + for x in load-system load-lisp load-lisp-compile-load-fasl load-fasl just-load-fasl ; do + lo="(asdf-test::load-asdf-lisp \"${tag}\")" ; + echo "Testing upgrade from ASDF ${tag} using method $x" ; + extract_tagged_asdf $tag + case ${lisp}:$tag:$x in + abcl:2.0[01][1-9]:*|abcl:2.2[1-2]:*) + : Skip, because it is so damn slow ;; + ccl:1.*|ccl:2.0[01]*) + : Skip, because ccl broke old asdf ;; + cmucl:1.*|cmucl:2.00*|cmucl:2.01[0-4]:*) + : Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade ;; + ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) + : Skip, because of various ASDF issues ;; + gcl:1.*|gcl:2.0*|gcl:2.2[0-6]*) : Skip old versions that do not support GCL 2.6 ;; + mkcl:1.*|mkcl:2.0[01]*|mkcl:2.2[0-3]:*) + : Skip, because MKCL is only supported starting with 2.24 ;; + xcl:1.*|xcl:2.00*|xcl:2.01[0-4]:*|xcl:*) + : XCL support starts with ASDF 2.014.2 - It also hangs badly during upgrade. ;; + *) (set -x ; case $x in + load-system) l="$lo (asdf-test::load-asdf-system)" ;; + load-lisp) l="$lo (asdf-test::load-asdf-lisp)" ;; + load-lisp-compile-load-fasl) l="$lo (asdf-test::compile-load-asdf)" ;; + load-fasl) l="$lo (asdf-test::load-asdf-fasl)" ;; + just-load-fasl) l="(asdf-test::load-asdf-fasl)" ;; + *) echo "WTF?" ; exit 2 ;; esac ; + $lv "(asdf-test::test-asdf $l)" ) || + { echo "upgrade FAILED" ; exit 1 ;} ;; esac ; + done ; done 2>&1 | tee build/results/${lisp}-upgrade.text +} +run_tests () { + create_config + mkdir -p ../build/results + echo failure > ../build/results/status + thedate=`date "+%Y-%m-%d"` + do_tests "$command" "$eval" 2>&1 | \ + tee "../build/results/${lisp}.text" "../build/results/${lisp}-${thedate}.save" + read a < ../build/results/status + clean_up + [ success = "$a" ] ## exit code +} clean_up () { rm -rf ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d } if [ -z "$command" ] ; then echo "Error: cannot find or do not know how to run Lisp named $lisp" +elif [ -n "$upgrade" ] ; then + run_upgrade_tests else - create_config - mkdir -p ../build/results - echo failure > ../build/results/status - thedate=`date "+%Y-%m-%d"` - do_tests "$command" "$eval" 2>&1 | \ - tee "../build/results/${lisp}.text" "../build/results/${lisp}-${thedate}.save" - read a < ../build/results/status - clean_up - [ success = "$a" ] ## exit code + run_tests fi diff --git a/test/script-support.lisp b/test/script-support.lisp index 2a1a3794a3d6b833baebccad93ba49fc84bbd038..b36945cb3f602a3284707dc9aafe5a15315dfec4 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -1,193 +1,210 @@ +;;;;; Minimal life-support for testing ASDF from a blank Lisp image. +#| +Some constraints: +* We cannot rely on any test library that could be loaded by ASDF. + And we cannot even rely on ASDF being present until we load it. + But we *can* rely on ASDF being present *after* we load it. +* evaluating this file MUST NOT print anything, + because we use it in the forward-ref test to check that nothing is printed. +|# + (defpackage :asdf-test (:use :common-lisp) (:export + #:asym #:acall #:*test-directory* #:*asdf-directory* - #:load-asdf - #:register-directory #:asdf-load - #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:compile-load-asdf #:load-asdf-system - #:quit-on-error #:test-asdf + #:load-asdf #:maybe-compile-asdf + #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl + #:compile-load-asdf #:load-asdf-system + #:register-directory #:load-test-system + #:with-test #:test-asdf #:debug-asdf + #:assert-compare #:assert-equal - #:exit-lisp #:leave-lisp + #:leave-test #:quietly)) (in-package :asdf-test) -(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3))) -(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3))) +(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3) + #+(or cmu scl) (c::brevity 2))) +(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3) + #+(or cmu scl) (c::brevity 2))) + +(defvar *trace-symbols* + ;; IF YOU WANT TO TRACE SOME STUFF WHILE DEBUGGING, HERE'S A NICE PLACE TO SAY WHAT. + ;; TO BE INTERNED IN :ASDF AFTER IT IS LOADED. + '( :upgrade-asdf :operate :run-program/ + )) + +(defvar *debug-asdf* nil) + +;;; Minimal compatibility layer +(eval-when (:compile-toplevel :load-toplevel :execute) + #+allegro (setf excl:*warn-on-nested-reader-conditionals* nil) + + #+gcl + (when (or (< system::*gcl-major-version* 2) + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (shadowing-import 'system:*load-pathname* :asdf-test))) + +#+(or gcl genera) +(unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + #+genera (fs:create-directories-recursively (pathname path)) + #+gcl (lisp:system (format nil "mkdir -p ~S" (namestring (make-pathname :name nil :type nil :defaults path)))))) + + +;;; Survival utilities +(defun asym (name) + (find-symbol (string name) :asdf)) +(defun acall (name &rest args) + (apply (asym name) args)) + +(defun finish-outputs () + (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*) + :do (finish-output s))) +(defun redirect-outputs () + (finish-outputs) + (setf *error-output* *standard-output* + *trace-output* *standard-output*)) -;; NB: can't print anything because of forward-ref test. -;; (DBG "Evaluating asdf/test/script-support") +(redirect-outputs) ;; Put everything on standard output, for the sake of scripts -;; We can't use asdf::merge-pathnames* because ASDF isn't loaded yet. -;; We still want to work despite and host/device funkiness. +;;; First, some pathname madness. +;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet. +;; We still want to work despite and host/device funkiness, +;; so we do it the hard way. (defparameter *test-directory* - (make-pathname :name nil :type nil :version nil - :defaults (or #+gcl (truename system:*load-pathname*) - *load-truename* *compile-file-truename*))) -(defparameter *asdf-directory* (truename - (merge-pathnames - (make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*) - *test-directory*))) -(defparameter *asdf-lisp* - (merge-pathnames - (make-pathname :directory '(#-gcl :relative "build") :name "asdf" :type "lisp" :defaults *asdf-directory*) - *asdf-directory*)) -(defparameter *asdf-fasl* + (make-pathname :name nil :type nil :version nil + :defaults (or *load-pathname* *compile-file-pathname*)))) +(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys) + (merge-pathnames (apply 'make-pathname keys) defaults)) +(defun relative-dir (&rest dir) #-gcl (cons ':relative dir) #+gcl dir) +(defun back-dir () #-gcl :back #+gcl :parent) +(defparameter *asdf-directory* + (truename (make-sub-pathname :directory (relative-dir (back-dir)) :defaults *test-directory*))) +(defparameter *build-directory* + (make-sub-pathname :directory (relative-dir "build") :defaults *asdf-directory*)) +(defparameter *implementation* + (or #+allegro + (ecase excl:*current-case-mode* + (:case-sensitive-lower :mlisp) + (:case-insensitive-upper :alisp)) + #+armedbear :abcl + #+clisp :clisp + #+clozure :ccl + #+cmu :cmucl + #+corman :cormanlisp + #+digitool :mcl + #+ecl :ecl + #+gcl :gcl + #+lispworks :lispworks + #+mkcl :mkcl + #+sbcl :sbcl + #+scl :scl + #+xcl :xcl)) +(defparameter *early-fasl-directory* + (make-sub-pathname :directory (relative-dir "fasls" (string-downcase *implementation*)) + :defaults *build-directory*)) + +(defun asdf-name (&optional tag) + (format nil "asdf~@[-~A~]" tag)) +(defun asdf-lisp (&optional tag) + (make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*)) +(defun debug-lisp () + (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *asdf-directory*)) +(defun early-compile-file-pathname (file) (compile-file-pathname - (let ((impl (string-downcase - (or #+allegro - (ecase excl:*current-case-mode* - (:case-sensitive-lower :mlisp) - (:case-insensitive-upper :alisp)) - #+armedbear :abcl - #+clisp :clisp - #+clozure :ccl - #+cmu :cmucl - #+corman :cormanlisp - #+digitool :mcl - #+ecl :ecl - #+gcl :gcl - #+lispworks :lispworks - #+mkcl :mkcl - #+sbcl :sbcl - #+scl :scl - #+xcl :xcl)))) - (merge-pathnames - (make-pathname :directory `(#-gcl :relative "fasls" ,impl) - :name "asdf" ;; otherwise LispWorks borks, because it fills in :UNSPECIFIC rather than NIL. - :defaults *asdf-directory*) - *asdf-lisp*)))) - -(defun load-old-asdf (tag) - (let ((old-asdf - (merge-pathnames - (make-pathname :directory `(#-gcl :relative "build") - :name (format nil "asdf-~A" tag) :type "lisp" - :defaults *asdf-directory*) - *asdf-directory*))) - (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) - (load old-asdf)))) - -(defvar *debug-symbols* - '( #|:COMPILE-FILE* :perform-lisp-compilation|# )) + (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*))) +(defun asdf-fasl (&optional tag) + (early-compile-file-pathname (asdf-lisp tag))) -(defun configure-asdf () - (eval `(trace ,@(loop :for s :in *debug-symbols* :collect (find-symbol (string s) :asdf)))) - (funcall (find-symbol (string :initialize-source-registry) :asdf) - `(:source-registry :ignore-inherited-configuration)) - (funcall (find-symbol (string :initialize-output-translations) :asdf) - `(:output-translations - (,*test-directory* (,*asdf-directory* "build/fasls" :implementation "test")) - (t (,*asdf-directory* "build/fasls" :implementation "root")) - :ignore-inherited-configuration)) - (let ((registry (find-symbol (string :*central-registry*) :asdf))) - (set registry `(,*asdf-directory* ,*test-directory*)))) + +;;; Test helper functions + +(defmacro assert-compare (expr) + (destructuring-bind (op x y) expr + `(assert-compare-helper ',op ',x ',y ,x ,y))) + +(defun assert-compare-helper (op qx qy x y) + (unless (funcall op x y) + (error "These two expressions fail comparison with ~S:~%~ + ~S evaluates to ~S~% ~S evaluates to ~S~%" + op qx x qy y))) + +(defmacro assert-equal (x y) + `(assert-compare (equal ,x ,y))) (defun touch-file (file &key (offset 0) timestamp) (let ((timestamp (or timestamp (+ offset (get-universal-time))))) (multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp) - (funcall (find-symbol (string :run-shell-command) :asdf) - "touch -t ~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D ~S" - year month day hr min sec (namestring file))))) - -(defun load-asdf () - (load *asdf-fasl*) - (use-package :asdf :asdf-test) - (import 'DBG :asdf) - (configure-asdf) - (setf *package* (find-package :asdf-test))) + (acall :run-shell-command + "touch -t ~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D ~S" + year month day hr min sec (namestring file))))) (defun hash-table->alist (table) (loop :for key :being :the :hash-keys :of table :using (:hash-value value) :collect (cons key value))) -(defun common-lisp-user::load-asdf () - (load-asdf)) -#+allegro -(setf excl:*warn-on-nested-reader-conditionals* nil) - -;;; code adapted from cl-launch http://www.cliki.net/cl-launch -(defun exit-lisp (return) - #+allegro - (excl:exit return) - #+clisp - (ext:quit return) - #+(or cmu scl) - (unix:unix-exit return) - #+ecl - (si:quit return) - #+gcl - (lisp:quit return) - #+lispworks - (lispworks:quit :status return :confirm nil :return nil :ignore-errors-p t) - #+(or openmcl mcl) - (ccl::quit return) - #+mkcl - (mk-ext:quit :exit-code return) +(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit + (finish-outputs) + #+(or abcl xcl) (ext:quit :status code) + #+allegro (excl:exit code :quiet t) + #+clisp (ext:quit code) + #+clozure (ccl:quit code) + #+cormanlisp (win32:exitprocess code) + #+(or cmu scl) (unix:unix-exit code) + #+ecl (si:quit code) + #+gcl (lisp:quit code) + #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) + #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) + #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? + #+mkcl (mk-ext:quit :exit-code code) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) - (quit (find-symbol "QUIT" :sb-ext))) - (cond - (exit `(,exit :code return :abort t)) - (quit `(,quit :unix-status return :recklessly-p t)))) - #+(or abcl xcl) - (ext:quit :status return) - (error "Don't know how to quit Lisp; wanting to use exit code ~a" return)) - -(defun finish-outputs () - (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*) - :do (finish-output s))) + (quit (find-symbol "QUIT" :sb-ext))) + (cond + (exit `(,exit :code code :abort t)) + (quit `(,quit :unix-status code :recklessly-p t)))) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) -(defun redirect-outputs () - (finish-outputs) - (setf *error-output* *standard-output* - *trace-output* *standard-output*)) -(defun leave-lisp (message return) +(defun leave-test (message return) (finish-outputs) (fresh-line *error-output*) (when message (format *error-output* message) - (terpri *error-output*)) + (fresh-line *error-output*)) (finish-outputs) - (exit-lisp return)) - -(defmacro assert-equal (x y) - `(assert (equal ,x ,y) () "These two expressions are not equal:~% ~S evaluates to ~S~% ~S evaluates to ~S~%" - ',x ,x ',y ,y)) + (throw :asdf-test-done return)) -(defmacro quit-on-error (&body body) - `(call-quitting-on-error (lambda () ,@body))) +(defmacro with-test (() &body body) + `(call-with-test (lambda () ,@body))) -(defun call-quitting-on-error (thunk) +(defun call-with-test (thunk) "Unless the environment variable DEBUG_ASDF_TEST is bound, write a message and exit on an error. If *asdf-test-debug* is true, enter the debugger." (redirect-outputs) - (handler-bind - ((error (lambda (c) - (format *error-output* "~&~a~&" c) - (cond - ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) - (break)) - (t - (finish-output *standard-output*) - (finish-output *trace-output*) - (format *error-output* "~&ABORTING:~% ~A~%" c) - (finish-output *error-output*) - #+sbcl (sb-debug:backtrace 69) - #+clozure (ccl:print-call-history :count 69 :start-frame-number 1) - #+clisp (system::print-backtrace) - #+ecl (si::tpl-backtrace) - (format *error-output* "~&ABORTING:~% ~A~%" c) - (finish-output *error-output*) - (finish-output *standard-output*) - (finish-output *trace-output*) - (leave-lisp "Script failed" 1)))))) - (funcall thunk) - (leave-lisp "Script succeeded" 0))) - + (let ((result + (catch :asdf-test-done + (handler-bind + ((error (lambda (c) + (format *error-output* "~&TEST ABORTED: ~A~&" c) + (finish-outputs) + (cond + (*debug-asdf* (break)) + (t + (acall :print-condition-backtrace + c :count 69 :stream *error-output*) + (leave-test "Script failed" 1)))))) + (funcall thunk) + (leave-test "Script succeeded" 0))))) + (unless *debug-asdf* + (exit-lisp result)))) ;;; These are used by the upgrade tests @@ -198,92 +215,153 @@ is bound, write a message and exit on an error. If (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (funcall thunk))) -(defun load-asdf-lisp () - (load *asdf-lisp*)) - -#+(or gcl genera) -(unless (fboundp 'ensure-directories-exist) - (defun ensure-directories-exist (path) - #+genera (fs:create-directories-recursively (pathname path)) - #+gcl (lisp:system (format nil "mkdir -p ~S" (namestring (make-pathname :name nil :type nil :defaults path)))))) +(defun load-asdf-lisp (&optional tag) + (quietly (load (asdf-lisp tag)))) -(defun compile-asdf (&optional (output *asdf-fasl*)) - (ensure-directories-exist *asdf-fasl*) - ;; style warnings shouldn't abort the compilation [2010/02/03:rpg] - (handler-bind (#+sbcl ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) #'muffle-warning) - #+(and ecl (not ecl-bytecmp)) - ((or c:compiler-note c::compiler-debug-note - c:compiler-warning) ;; ECL emits more serious warnings than it should. - #'muffle-warning) - #+mkcl - ((or compiler:compiler-note) - #'muffle-warning) - #-(or cmu scl) - (style-warning - #'(lambda (w) - ;; escalate style-warnings to warnings - we don't want them. - (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A" - (type-of w) w) - (muffle-warning w)))) - (compile-file *asdf-lisp* :output-file output #-gcl :verbose #-gcl t :print t))) - -(defun load-asdf-fasl () - (load *asdf-fasl*)) - -(defun compile-load-asdf () - ;; emulate the way asdf upgrades itself: load source, compile, load fasl. - (load-asdf-lisp) - (compile-asdf) - (load-asdf-fasl)) +(defun load-asdf-fasl (&optional tag) + (quietly (load (asdf-fasl tag)))) (defun register-directory (dir) - (pushnew dir (symbol-value (find-symbol (string :*central-registry*) :asdf)))) - -(defun asdf-load (x &key verbose) - (let ((xoos (find-symbol (string :oos) :asdf)) - (xload-op (find-symbol (string :load-op) :asdf)) - (*load-print* verbose) - (*load-verbose* verbose)) - (funcall xoos xload-op x :verbose verbose))) + (pushnew dir (symbol-value (asym :*central-registry*)))) (defun load-asdf-system (&rest keys) (quietly (register-directory *asdf-directory*) - (apply 'asdf-load :asdf keys))) + (apply (asym :oos) (asym :load-op) :asdf keys))) + +(defun compile-asdf (&optional tag verbose) + (let* ((alisp (asdf-lisp tag)) + (afasl (asdf-fasl tag)) + (tmp (make-pathname :name "asdf-tmp" :defaults afasl))) + (ensure-directories-exist afasl) + (multiple-value-bind (result warnings-p errors-p) + (handler-bind (#+sbcl + ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) + #'muffle-warning) + #+(and ecl (not ecl-bytecmp)) + ((or c:compiler-note c::compiler-debug-note + c:compiler-warning) ;; ECL emits more serious warnings than it should. + #'muffle-warning) + #+mkcl + ((or compiler:compiler-note) #'muffle-warning) + #-(or cmu scl) + ;; style warnings shouldn't abort the compilation [2010/02/03:rpg] + (style-warning + #'(lambda (w) + ;; escalate style-warnings to warnings - we don't want them. + (when verbose + (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A" + (type-of w) w)) + (muffle-warning w)))) + (compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose)) + (flet ((bad (key) + (when result (ignore-errors (delete-file result))) + key) + (good (key) + (when (probe-file afasl) (delete-file afasl)) + (rename-file tmp afasl) + key)) + (cond + (errors-p (bad :errors)) + (warnings-p + (or + ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291. + ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?) + #+(or cmu ecl scl xcl) (good :expected-warnings) + (bad :unexpected-warnings))) + (t (good :success))))))) + +(defun maybe-compile-asdf (&optional tag) + (let ((alisp (asdf-lisp tag)) + (afasl (asdf-fasl tag))) + (cond + ((not (probe-file alisp)) + :not-found) + ((and (probe-file afasl) + (> (file-write-date afasl) (file-write-date alisp)) + (ignore-errors (load-asdf-fasl tag))) + :previously-compiled) + (t + (load-asdf-lisp tag) + (compile-asdf tag))))) + +(defun compile-asdf-script () + (with-test () + (ecase (maybe-compile-asdf) + (:not-found + (leave-test "Testsuite failed: unable to find ASDF source" 3)) + (:previously-compiled + (leave-test "Reusing previously-compiled ASDF" 0)) + (:errors + (leave-test "Testsuite failed: ASDF compiled with ERRORS" 2)) + (:unexpected-warnings + (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1)) + (:expected-warnings + (leave-test "ASDF compiled with warnings, ignored for your implementation" 0)) + (:success + (leave-test "ASDF compiled cleanly" 0))))) + +(defun compile-load-asdf (&optional tag) + ;; emulate the way asdf upgrades itself: load source, compile, load fasl. + (load-asdf-lisp tag) + (ecase (compile-asdf tag) + ((:errors :unexpected-warnings) (leave-test "failed to compile ASDF" 1)) + ((:expected-warnings :success) + (load-asdf-fasl tag)))) + +;;; Now, functions to compile and load ASDF. + +(defun load-test-system (x &key verbose) + (let ((*load-print* verbose) + (*load-verbose* verbose)) + (register-directory *test-directory*) + (acall :oos (asym :load-op) x :verbose verbose))) (defun testing-asdf (thunk) - (quit-on-error - (quietly + (with-test () (funcall thunk) (register-directory *test-directory*) - (asdf-load :test-module-depend)))) + (load-test-system :test-module-depend))) -(defmacro test-asdf (&body body) +(defmacro test-asdf (&body body) ;; used by test-upgrade `(testing-asdf #'(lambda () ,@body))) -(defmacro DBG (tag &rest exprs) - "simple debug statement macro: -outputs a tag plus a list of variable and their values, returns the last value" - ;"if not in debugging mode, just compute and return last value" - ; #-do-test (declare (ignore tag)) #-do-test (car (last exprs)) #+do-test - (let ((res (gensym))(f (gensym))) - `(let (,res (*print-readably* nil)) - (flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args))) - (,f "~&~A~%" ,tag) - ,@(mapcan - #'(lambda (x) - `((,f "~& ~S => " ',x) - (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x))))) - exprs) - (apply 'values ,res))))) - -(pushnew :DBG *features*) - -#+gcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (DBG :script-support *package* *test-directory* *asdf-directory* *asdf-lisp* *asdf-fasl* - )) +(defun configure-asdf () + (untrace) + (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))) + (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))) + (acall :initialize-source-registry + `(:source-registry :ignore-inherited-configuration)) + (acall :initialize-output-translations + `(:output-translations + (,*test-directory* (,*asdf-directory* "build/fasls" :implementation "test")) + (t (,*asdf-directory* "build/fasls" :implementation "root")) + :ignore-inherited-configuration)) + (set (asym :*central-registry*) `(,*test-directory*)) + (set (asym :*verbose-out*) *standard-output*) + (set (asym :*asdf-verbose*) t)) + +(defun load-asdf (&optional tag) + (setf *package* (find-package :asdf-test)) + (load (debug-lisp)) + (load-asdf-fasl tag) + (use-package :asdf :asdf-test) + (configure-asdf) + (setf *package* (find-package :asdf-test))) -#| -(DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)) +(defun debug-asdf () + (setf *debug-asdf* t) + (setf *package* (find-package :asdf-test))) + +(defun common-lisp-user::load-asdf () + (load-asdf)) +(defun common-lisp-user::debug-asdf () + (debug-asdf)) + +(trace load compile-file) + +#| The following form is sometimes useful to insert in compute-action-stamp to find out what's happening. +It depends on the DBG macro in contrib/debug.lisp, that you should load in your ASDF. + +#+DBG-ASDF (DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)) |# diff --git a/test/test-around-compile.script b/test/test-around-compile.script index 885ac8a589708d91a598b9ab12c9768cf0999b6b..6f240bc9d4fbacd3454fb806d3dc08915d3518e3 100644 --- a/test/test-around-compile.script +++ b/test/test-around-compile.script @@ -6,7 +6,7 @@ (let ((*read-base* 2)) (funcall thunk))) -(quit-on-error +(with-test () (defsystem test-around-compile :around-compile call-in-base-2 ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. diff --git a/test/test-builtin-source-file-type.script b/test/test-builtin-source-file-type.script index f3d2cca6af5743e42387a22add865da0c93dd095..a31ce7dc9dedad59833b1ee3de015afccadf8367 100644 --- a/test/test-builtin-source-file-type.script +++ b/test/test-builtin-source-file-type.script @@ -4,7 +4,7 @@ ;;(trace source-file-type) -(quit-on-error +(with-test () (format t "~D~%" (asdf:asdf-version)) (defsystem test-builtin-source-file-type-1 diff --git a/test/test-bundle.script b/test/test-bundle.script index 9fe49617d20f578be6703c99eb73717a0cdd5c6a..b6c8988bc5cdc6ebd239bca15f17caa1ac9898c2 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -7,7 +7,7 @@ ;;;--------------------------------------------------------------------------- -(quit-on-error +(with-test () (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (asdf:clear-system :test-bundle-1) (asdf:clear-system :test-bundle-2) diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script index 85792e852cf632e032ca7e0a7a54174032a65e34..668fd8f7068e2c16d58353eec5acdf8c407a233d 100644 --- a/test/test-compile-file-failure.script +++ b/test/test-compile-file-failure.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () #-gcl<2.7 (assert (handler-case (let ((asdf:*compile-file-failure-behaviour* :warn)) diff --git a/test/test-concatenate-source.script b/test/test-concatenate-source.script index e7774fe15b1f1f5b0b2fc3992230d0623eddce73..4c8d7911ae85eb98d6f02b265414c37b83f66b6b 100644 --- a/test/test-concatenate-source.script +++ b/test/test-concatenate-source.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (defsystem :test-concatenate-source :depends-on (:file3-only) :components diff --git a/test/test-configuration.script b/test/test-configuration.script index ea30fe71ce01f57fc51852d263f23bf1c49ee89e..6b0f7f8c04500fbdb5171808462ce77996d609ee 100644 --- a/test/test-configuration.script +++ b/test/test-configuration.script @@ -63,7 +63,7 @@ :if-does-not-exist :create) (format s "(defsystem :foo~D)~%" i)))) -(quit-on-error +(with-test () (assert-equal (asdf::parse-output-translations-string "/foo:/bar::/baz:/quux") '(:output-translations ("/foo" "/bar") :inherit-configuration ("/baz" "/quux"))) diff --git a/test/test-encodings.script b/test/test-encodings.script index 79e8ed6a032420bfb1309a71dfe69c4d61814e51..600f7cc6b3cb685f5b2b1f394dfdec40298bbad8 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -21,7 +21,7 @@ #+sbcl sb-impl::*default-external-format* #-(or clozure sbcl) (error "can't determine default external-format"))))) -(defmacro with-test ((encoding &key (op 'asdf:load-source-op) (path "lambda")) defsystem &body body) +(defmacro with-encoding-test ((encoding &key (op 'asdf:load-source-op) (path "lambda")) defsystem &body body) (let ((sys (second defsystem))) `(progn (format t "~&Test ~A: should be ~A~%" ',sys ',encoding) @@ -37,9 +37,9 @@ (eval `(assert-equal (string-char-codes ,*lambda-string*) (expected-char-codes ',',encoding)))))) -(quit-on-error +(with-test () - (with-test (:utf-8) + (with-encoding-test (:utf-8) (defsystem :test-encoding-explicit-u8 :components ((:file "lambda" :encoding :utf-8)))) @@ -49,10 +49,10 @@ (progn #+clozure (setf ccl:*default-external-format* :latin3) #+sbcl (setf sb-impl::*default-external-format* :latin-3) - (with-test (:default) + (with-encoding-test (:default) (defsystem :test-encoding-explicit-default :components ((:file "lambda" :encoding :default)))) - (with-test (:default) + (with-encoding-test (:default) (defsystem :test-encoding-implicit-default :components ((:file "lambda"))))) @@ -62,46 +62,46 @@ (pushnew (asdf::subpathname *asdf-directory* "../asdf-encodings/") asdf:*central-registry*) (asdf:load-system :asdf-encodings) #-lispworks - (with-test (:latin-2) + (with-encoding-test (:latin-2) (defsystem :test-encoding-implicit-autodetect :components ((:file "lambda")))) #+sbcl - (with-test (:koi8-r) + (with-encoding-test (:koi8-r) (defsystem :test-encoding-explicit-koi8-r :components ((:file "lambda" :encoding :koi8-r))))) - (with-test (:utf-8) + (with-encoding-test (:utf-8) (defsystem :test-file-encoding-u8 :encoding :latin-1 :components ((:file "lambda" :encoding :utf-8)))) - (with-test (:latin-1) + (with-encoding-test (:latin-1) (defsystem :test-file-encoding-l1 :encoding :utf-8 :components ((:file "lambda" :encoding :latin-1)))) - (with-test (:utf-8 :op asdf:load-source-op) + (with-encoding-test (:utf-8 :op asdf:load-source-op) (defsystem :test-system-encoding-u8 :encoding :utf-8 :components ((:file "lambda")))) - (with-test (:utf-8 :op asdf:load-op) + (with-encoding-test (:utf-8 :op asdf:load-op) (defsystem :test-system-encoding-u8-load-op :encoding :utf-8 :components ((:file "lambda")))) - (with-test (:latin-1) + (with-encoding-test (:latin-1) (defsystem :test-system-encoding-l1 :encoding :latin-1 :components ((:file "lambda")))) #-ecl-bytecmp - (with-test (:latin-1 :op asdf:load-op) + (with-encoding-test (:latin-1 :op asdf:load-op) (defsystem :test-system-encoding-l1-load-op :encoding :latin-1 :components ((:file "lambda")))) - (with-test (:utf-8 :path ("foo" "lambda")) + (with-encoding-test (:utf-8 :path ("foo" "lambda")) (defsystem :test-module-encoding-u8 :encoding :latin-1 :components ((:module "foo" :pathname "" :encoding :utf-8 :components ((:file "lambda")))))) - (with-test (:latin-1 :path ("foo" "lambda")) + (with-encoding-test (:latin-1 :path ("foo" "lambda")) (defsystem :test-module-encoding-l1 :encoding :utf-8 :components diff --git a/test/test-force.script b/test/test-force.script index 88fd9bbaf412ab87d038891d7cacfb8f3a768ebe..5fdb32092e97111e52f7f9479553e68ab2afc07d 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:operate 'asdf:load-op 'test-force) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index bc3eced42782a8c96a0869c3e9d084e1cb00a3e6..963bfb158709b46d30d0deac65458c5b1736548c 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -13,7 +13,7 @@ `(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf") :wilden t)))) -(quit-on-error +(with-test () (format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd")) (format t "~S~%" (truename "ASDF:test;test-force.asd")) diff --git a/test/test-missing-lisp-file.script b/test/test-missing-lisp-file.script index 41067190d07e987e26f46773fc0e5a69adc08428..99cbe67dc3f3ef7edc32a076797c4411a3405bf7 100644 --- a/test/test-missing-lisp-file.script +++ b/test/test-missing-lisp-file.script @@ -9,7 +9,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (asdf:defsystem test-missing-lisp-file :components ((:file "file2" :in-order-to ((compile-op (load-op "fileMissing")) (load-op (load-op "fileMissing")))) diff --git a/test/test-module-depend.script b/test/test-module-depend.script index 36f90fabcc8b20c4f5a95153e2f9d80aea5c3678..ab05ca20a97798f571d6acf1c2bdbb643ba8336e 100644 --- a/test/test-module-depend.script +++ b/test/test-module-depend.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-module-depend) diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script index ad8136e64e2be52b57b89c3956ca85e06d823a4b..fe6a5e43d8edb160aebd40a8748bbbbbaf8df6a2 100644 --- a/test/test-module-excessive-depend.script +++ b/test/test-module-excessive-depend.script @@ -14,74 +14,75 @@ ;;; and reloading of "file2," but /not/ of system Y. ;;;--------------------------------------------------------------------------- -(quit-on-error +(with-test () - (defsystem :test-module-excessive-depend + (defsystem :test-module-excessive-depend :components ((:file "file1") (:module "quux" :pathname "" :depends-on ("file1") :components ((:file "file2"))))) - (defun find-quux () - (find-component :test-module-excessive-depend "quux")) + (defun find-quux () + (find-component :test-module-excessive-depend "quux")) - (defun find-file2 () - (find-component (find-quux) "file2")) + (defun find-file2 () + (find-component (find-quux) "file2")) - (defmethod component-depends-on ((op load-op) - (c (eql (find-file2)))) - (cons `(load-op ,(find-system "file3-only")) - (call-next-method))) + (defmethod component-depends-on ((op load-op) + (c (eql (find-file2)))) + (cons `(load-op ,(find-system "file3-only")) + (call-next-method))) - (defmethod component-depends-on ((op compile-op) - (c (eql (find-file2)))) - (cons `(load-op ,(find-system "file3-only")) - (call-next-method))) + (defmethod component-depends-on ((op compile-op) + (c (eql (find-file2)))) + (cons `(load-op ,(find-system "file3-only")) + (call-next-method))) - (asdf:operate 'asdf:load-op 'test-module-excessive-depend) + (DBG "loading test-module-excessive-depend" + (operate 'load-op 'test-module-excessive-depend)) - ;; test that it compiled - (let* ((file1 (asdf:compile-file-pathname* "file1")) - (file2 (asdf:compile-file-pathname* "file2")) - (file3 (asdf:compile-file-pathname* "file3")) - (file1-date (file-write-date file1)) - (file2-date (file-write-date file2)) - (file3-date (file-write-date file3))) - (unless (and file1-date file2-date file3-date) - (error "Failed to compile one of the three files ~ + ;; test that it compiled + (let* ((file1 (compile-file-pathname* "file1")) + (file2 (compile-file-pathname* "file2")) + (file3 (compile-file-pathname* "file3")) + (file1-date (file-write-date file1)) + (file2-date (file-write-date file2)) + (file3-date (file-write-date file3))) + (unless (and file1-date file2-date file3-date) + (error "Failed to compile one of the three files ~ that should be compiled for this test: ~{~a~}" - (mapcar #'cdr - (remove-if #'car - (pairlis (list file1-date file2-date file3-date) - '("file1" "file2" "file3")))))) + (mapcar #'cdr + (remove-if #'car + (pairlis (list file1-date file2-date file3-date) + '("file1" "file2" "file3")))))) - ;; and loaded - (assert (eval (intern (symbol-name '#:*file1*) :test-package))) - (assert (eval (intern (symbol-name '#:*file3*) :test-package))) + ;; and loaded + (assert (eval (asdf::find-symbol* '#:*file1* :test-package))) + (assert (eval (asdf::find-symbol* '#:*file3* :test-package))) - ;; now touch file1 and check that file2 _is_ also recompiled - ;; but that file3 is _not_ recompiled. - ;; this will only work if the cross-module (intra-system) - ;; dependency bug is fixed and the excessive compilation bug is fixed. + ;; now touch file1 and check that file2 _is_ also recompiled + ;; but that file3 is _not_ recompiled. + ;; this will only work if the cross-module (intra-system) + ;; dependency bug is fixed and the excessive compilation bug is fixed. - (let ((before file3-date)) - (touch-file "file1.lisp" :timestamp (- before 60)) - (touch-file file1 :timestamp (- before 90)) - (touch-file "file2.lisp" :timestamp (- before 30)) - (touch-file file2 :timestamp (- before 15)) + (let ((before file3-date)) + (touch-file "file1.lisp" :timestamp (- before 60)) + (touch-file file1 :timestamp (- before 90)) + (touch-file "file2.lisp" :timestamp (- before 30)) + (touch-file file2 :timestamp (- before 15)) - (let ((plan (asdf::traverse - (make-instance 'asdf:load-op) - (asdf:find-system 'test-module-excessive-depend))) - (file3 (asdf:find-component :file3-only "file3"))) - #|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|# - (when (loop :for (o . c) :in plan :thereis (and (eq c file3) (typep o 'asdf:compile-op))) - (error "Excessive operations on file3-only system. Bad propagation of dependencies."))) - (asdf:operate 'asdf:load-op 'test-module-excessive-depend) - (assert (>= (file-write-date file1) before)) - (assert (>= (file-write-date file2) before))) - (unless (= (file-write-date file3) - file3-date) - (error "Excessive compilation of file3.lisp: traverse bug.")))) + (let ((plan (asdf::traverse + (make-instance 'asdf:load-op) + (asdf:find-system 'test-module-excessive-depend))) + (file3 (asdf:find-component :file3-only "file3"))) + #|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|# + (when (loop :for (o . c) :in plan :thereis (and (eq c file3) (typep o 'asdf:compile-op))) + (error "Excessive operations on file3-only system. Bad propagation of dependencies."))) + (asdf:operate 'asdf:load-op 'test-module-excessive-depend) + (assert (>= (file-write-date file1) before)) + (assert (>= (file-write-date file2) before))) + (unless (= (file-write-date file3) + file3-date) + (error "Excessive compilation of file3.lisp: traverse bug.")))) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index 8d23240e6577b14a7b49eb6fff6fb8470e2aeb38..e3aedb703314817de9d125ecfa3910f55c31fb7b 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (asdf:load-system 'test-module-pathnames) (flet ((pathname-foo (x) (list (or (asdf::normalize-pathname-directory-component (pathname-directory x)) '(:relative)) diff --git a/test/test-multiple.script b/test/test-multiple.script index 11bc283ab4fb21cbae93c2cdf865d9f3113ea23b..0436def4a8ed15e6f594f2e2b7e735b3a1b88791 100644 --- a/test/test-multiple.script +++ b/test/test-multiple.script @@ -5,17 +5,17 @@ (in-package :asdf) (use-package :asdf-test) -(quit-on-error +(with-test () (let* ((asd (subpathname *test-directory* "test-multiple.asd")) (tmp (subpathname *test-directory* "../build/")) (asd2 (subpathname tmp "test-multiple-too.asd")) (file4 (compile-file-pathname* "file4"))) (setf *central-registry* `(,*test-directory* ,tmp)) - (assert (= 0 (run-shell-command - (format nil "/bin/ln -sf ~A ~A" - (native-namestring asd) - (native-namestring asd2))))) + (run-shell-command + (format nil "/bin/ln -sf ~A ~A 2>&1" + (native-namestring asd) + (native-namestring asd2))) (oos 'load-source-op 'test-multiple-too) - (assert (symbol-value (find-symbol (string :*file3*) :test-package))) + (assert (symbol-value (asdf::find-symbol* :*file3* :test-package))) (load-system 'test-multiple-free) (assert (asdf::probe-file* file4)))) diff --git a/test/test-nested-components.script b/test/test-nested-components.script index c1baa50c02f41052f066e27255b5911f4bfd58c0..7783099378401d0898ed5cb4bc94511dd318674f 100644 --- a/test/test-nested-components.script +++ b/test/test-nested-components.script @@ -5,7 +5,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* nil) (load (merge-pathnames "test-nested-components-1.asd")) (print diff --git a/test/test-package.script b/test/test-package.script index 33d693886475c0c25de274cbba4d3b11a7450fd1..4ea06b6a49d694351db825ea4c3ca985062c9781 100644 --- a/test/test-package.script +++ b/test/test-package.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) (in-package :cl-user) -(asdf-test::quit-on-error +(asdf-test::with-test () (defun module () 1) (load "test-package.asd") (defclass module () ()) diff --git a/test/test-redundant-recompile.script b/test/test-redundant-recompile.script index e2038eaffeff86283f8c207797f43df031de2b9b..499d7ac05881759cd9db5038f12af11595da0ba7 100644 --- a/test/test-redundant-recompile.script +++ b/test/test-redundant-recompile.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:operate 'asdf:load-op 'test-redundant-recompile) ;; test that it compiled diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index f3145e27111f9a058b0e9a02b5aa506565dcedd0..66e81f1ba9c56a0cc301c2659d47605c121db6a1 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -5,7 +5,7 @@ (load "script-support.lisp") (load-asdf) (defvar *caught-error* nil) -(quit-on-error +(with-test () (DBG "trlc1 1") (asdf::delete-file-if-exists "try-reloading-dependency.asd") (setf asdf::*defined-systems* (asdf::make-defined-systems-table)) diff --git a/test/test-samedir-modules.script b/test/test-samedir-modules.script index 243d5c6dc3bdfb061c490f3391040af35fb412c0..3abaf9c92f9a21ea90c6a6dff9e33b920ac693d4 100644 --- a/test/test-samedir-modules.script +++ b/test/test-samedir-modules.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (DBG "loading test-samedir-modules") (asdf:operate 'asdf:load-op 'test-samedir-modules) diff --git a/test/test-source-file-type.script b/test/test-source-file-type.script index 57f17276e65bcc474c9c49d983518c3be219ccbb..494afc66116aa4e5b3ceb11d511ee5c9d58e6926 100644 --- a/test/test-source-file-type.script +++ b/test/test-source-file-type.script @@ -4,7 +4,7 @@ ;;(trace asdf::source-file-type asdf::source-file-explicit-type) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-source-file-type-1 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index 97d7221e6b43a993ebfd70cede97a7aa28d8cb82..b39596a982ba1a5898d06a12d7293dec4f50205a 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -6,7 +6,7 @@ #+gcl (trace coerce-pathname) -(quit-on-error +(with-test () (format t "dpd: ~S~%f1: ~S~%" *default-pathname-defaults* (asdf::merge-pathnames* "file1")) (setf asdf:*central-registry* '(*default-pathname-defaults*)) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index b2411888cb01a93f9ed1689e1804262a9583f06b..59f4174c4ae179eb1a5f85d5d84c4ac61c83ecba 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (asdf:load-system :asdf) (asdf:initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) :ignore-inherited-configuration)) diff --git a/test/test-system-pathnames.script b/test/test-system-pathnames.script index 4d661814db5a8ec69145b5fc516ba25afef68b07..3ba40d71792fab19e339f699420d18c2c15e1fea 100644 --- a/test/test-system-pathnames.script +++ b/test/test-system-pathnames.script @@ -2,7 +2,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (asdf:load-system 'test-system-pathnames) (assert (find-package :test-package) () "package test-package not found") diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index 518f16a3855466b4711d446235270251e6974502..5c9ec5cb985becd2bc88a51fe0444d3f22060c80 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -5,7 +5,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (flet ((system-load-time (name) (let ((data (asdf::system-registered-p name))) (when data diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 6e5ac5eced73f09c5401d24ae00bc755a5cc1a0d..3694802512124a50cdc8e2bea3ec0c4944bf819c 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -5,7 +5,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (flet ((system-load-time (name) (let ((data (asdf::system-registered-p name))) (when data diff --git a/test/test-try-recompiling-1.script b/test/test-try-recompiling-1.script index 0b15456b14273dad5c7f778eb77c957f549f5f44..e1c669301f34bc6b55cd14b4b5f49d15b27bb453 100644 --- a/test/test-try-recompiling-1.script +++ b/test/test-try-recompiling-1.script @@ -6,7 +6,7 @@ (load-asdf) (defvar *caught-error* nil) -(quit-on-error +(with-test () (asdf::delete-file-if-exists (compile-file-pathname "try-recompiling-1")) #-gcl (handler-bind ((error (lambda (c) diff --git a/test/test-urls-1.script b/test/test-urls-1.script index a630e74381532d141071517a684b15203fc7797c..1b120b87889d9e4d17b0722a181817f25670d026 100644 --- a/test/test-urls-1.script +++ b/test/test-urls-1.script @@ -4,7 +4,7 @@ #+scl (require :http-library) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) ;; Compare the source files with local versions before loading them. #+(and (or abcl scl) trust-the-net) diff --git a/test/test-urls-2.script b/test/test-urls-2.script index ad99143bda7e7539ef0eb91b13ae7142824c1166..46237b1eda93dcdaf167ae9ec4e660c986f9b4cd 100644 --- a/test/test-urls-2.script +++ b/test/test-urls-2.script @@ -4,7 +4,7 @@ #+scl (require :http-library) -(quit-on-error +(with-test () (setf asdf:*central-registry* '("http://www.scieneer.com/files/")) ;; Compare the source files with local versions before loading them. #+(and (or abcl scl) trust-the-net) diff --git a/test/test-utilities.script b/test/test-utilities.script index 0def8b241138c1b54c1fd002147b1a6371a0080e..420297539bcf39f39a34b9caafad252014958606 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -5,7 +5,7 @@ (in-package :asdf) (use-package :asdf-test) -(quit-on-error +(with-test () (assert (every #'directory-pathname-p diff --git a/test/test-version.script b/test/test-version.script index 57b81d7209cbe75a994102a8ecb634fab4e0183c..6cf95d99f87c0de4342c0ef962575e3809aa9888 100644 --- a/test/test-version.script +++ b/test/test-version.script @@ -4,7 +4,7 @@ (setf *central-registry* '(*default-pathname-defaults*)) -(quit-on-error +(with-test () (defsystem :versioned-system-1 :pathname #.*default-pathname-defaults* :version "1.0") diff --git a/test/test-weakly-depends-on-present.script b/test/test-weakly-depends-on-present.script index b55c3863785c81502a064c612d676caa698fbcf8..992ae48c58449aff4771f0cf11e953e67f53ec93 100644 --- a/test/test-weakly-depends-on-present.script +++ b/test/test-weakly-depends-on-present.script @@ -8,7 +8,7 @@ ;;;--------------------------------------------------------------------------- -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-weakly-depends-on-present) ;; The weakly-depended-on system, file3-only, should be loaded... diff --git a/test/test-weakly-depends-on-unpresent.script b/test/test-weakly-depends-on-unpresent.script index 1bebe63ad3aa2aab5f17be4ad796486d00b33ad2..ffab4cd180484cafaeba8804bd251949e8d5f19e 100644 --- a/test/test-weakly-depends-on-unpresent.script +++ b/test/test-weakly-depends-on-unpresent.script @@ -9,7 +9,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-weakly-depends-on-unpresent) ;; test that it compiled diff --git a/test/test-xach-update-bug.script b/test/test-xach-update-bug.script index eb40cba7e8151210436164430a633615c5daa3d0..7bc7cffd62520c95ef8e6c511f858b90558a9f36 100644 --- a/test/test-xach-update-bug.script +++ b/test/test-xach-update-bug.script @@ -3,7 +3,7 @@ (load-asdf) #+gcl (trace load compile-file asdf:perform asdf::perform-plan) -(quit-on-error +(with-test () (setf asdf:*central-registry* (list (asdf::subpathname *test-directory* "xach-foo-1/"))) (asdf:load-system "foo") (assert (symbol-value (find-symbol (string :loaded) :first-version))) diff --git a/test/test1.script b/test/test1.script index 1f1ae519d181bcce49500ed08936afbdc64685e1..9b764db73a28e3dec4f8352709f6fae8d3752c1c 100644 --- a/test/test1.script +++ b/test/test1.script @@ -6,7 +6,7 @@ (touch-file "file1.lisp" :offset -3500) (touch-file "file2.lisp" :offset -3400) -(quit-on-error +(with-test () (DBG "loading test1") (asdf:load-system 'test1) (let* ((file1 (asdf:compile-file-pathname* "file1")) diff --git a/test/test2.script b/test/test2.script index 641d43d6d968924136a1bf03f3b3c6e82154abcf..6a6fbafb7f5bcac2ad12ef54a0d52357fe9df9e2 100644 --- a/test/test2.script +++ b/test/test2.script @@ -1,7 +1,7 @@ ;;; -*- Lisp -*- (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (DBG "test2: loading test2b1") (asdf:load-system 'test2b1) diff --git a/test/test3.script b/test/test3.script index ceb240dce780571a2c79d6acb89ffc4cc83e5d61..fc6b234cc683ca2cc8ed71c87d772cc7db952671 100644 --- a/test/test3.script +++ b/test/test3.script @@ -1,7 +1,7 @@ ;;; -*- Lisp -*- (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (let* ((fasl1 (asdf:compile-file-pathname* (truename "file1.lisp"))) (fasl2 (asdf:compile-file-pathname* (truename "file2.lisp"))) (ns1 (asdf::native-namestring fasl1)) diff --git a/test/test8.script b/test/test8.script index caebad04704a72ee1472eb00fac8038930ef5a18..6719d1778835e8e5eec3d7853cc85d6ebabb3bb4 100644 --- a/test/test8.script +++ b/test/test8.script @@ -6,7 +6,7 @@ (load-asdf) (in-package :asdf-test) -(quit-on-error +(with-test () (setf asdf:*central-registry* '(*default-pathname-defaults*)) (handler-case (asdf:oos 'asdf:load-op 'system-does-not-exist) diff --git a/test/test9.script b/test/test9.script index 32180ca90c84082f3c653ba7c6c58cceda27296f..fb2e358fe974d7389539186c13380f512bdbbb55 100644 --- a/test/test9.script +++ b/test/test9.script @@ -5,7 +5,7 @@ (load "script-support.lisp") (load-asdf) -(quit-on-error +(with-test () (setf asdf:*central-registry* nil) (load (merge-pathnames "test9-1.asd")) (load (merge-pathnames "test9-2.asd")) diff --git a/test/wild-module.script b/test/wild-module.script index f2a0f3526e9a1fd1b3acb0f7cf561bcad0f76ea4..e6dd5ead0d5ab967702951b78b9aff206b0102c1 100644 --- a/test/wild-module.script +++ b/test/wild-module.script @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- (load "script-support.lisp") (load-asdf) -(quit-on-error - (load (asdf:system-relative-pathname :asdf "contrib/wild-modules.lisp")) +(with-test () + (load (asdf::subpathname *asdf-directory* "contrib/wild-modules.lisp")) (asdf:defsystem :wild-module :version "0.0" :components ((:wild-module "systems" :pathname #p"*.asd"))) diff --git a/upgrade.lisp b/upgrade.lisp index 14c2746306271b4dbb9fd26cb7f3f5d4401e51da..63a47ab242308ff88b62b138f09368fc56176f56 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -7,6 +7,7 @@ (:use :common-lisp :asdf/package :asdf/compatibility :asdf/utility) (:export #:upgrade-asdf #:asdf-upgrade-error #:when-upgrade + #:*asdf-upgrade-already-attempted* #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf #:asdf-version #:*upgraded-p* #:asdf-message #:*asdf-verbose* #:*verbose-out*)) @@ -19,7 +20,7 @@ (defvar *upgraded-p* nil) (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. (defvar *verbose-out* nil) - (defun asdf-message (format-string &rest format-args) + (defun* asdf-message (format-string &rest format-args) (apply 'format *verbose-out* format-string format-args))) (eval-when (:load-toplevel :compile-toplevel :execute) @@ -31,7 +32,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.81") + (asdf-version "2.26.82") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -67,6 +68,8 @@ You can compare this string with e.g.: ;;; Self-upgrade functions +(defvar *asdf-upgrade-already-attempted* nil) + (defvar *post-upgrade-cleanup-hook* ()) (defvar *post-upgrade-restart-hook* ()) @@ -92,8 +95,9 @@ You can compare this string with e.g.: (defun* upgrade-asdf () "Try to upgrade of ASDF. If a different version was used, return T. We need do that before we operate on anything that depends on ASDF." - (let ((version (asdf-version))) - (handler-bind (((or style-warning warning) #'muffle-warning)) - (symbol-call :asdf :load-system :asdf :verbose nil)) - (cleanup-upgraded-asdf version))) - + (unless *asdf-upgrade-already-attempted* + (setf *asdf-upgrade-already-attempted* t) + (let ((version (asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (symbol-call :asdf :load-system :asdf :verbose nil)) + (cleanup-upgraded-asdf version)))) diff --git a/utility.lisp b/utility.lisp index 9f15dd743ae74328d0ed16abf68ceaf6cbc18918..678da26128484cef24e1a8b191ad5d452437975e 100644 --- a/utility.lisp +++ b/utility.lisp @@ -4,13 +4,13 @@ (asdf/package:define-package :asdf/utility (:recycle :asdf/utility :asdf) (:use :common-lisp :asdf/package :asdf/compatibility) - (:import-from :asdf/package #:DBG) (:export - #:find-symbol* ;;#:DBG ;; reexport from asdf/package + #:find-symbol* ;; reexport from asdf/package + #:asdf-debug #:load-asdf-debug-utility ;; magic helper to define debugging functions #:strcat #:compatfmt ;; reexport from asdf/compatibility #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; defining macros - #:aif #:it ;; basic flow control + #:if-bind ;; basic flow control #:while-collecting #:appendf #:length=n-p ;; lists #:remove-keys #:remove-keyword ;; keyword argument lists #:emptyp ;; sequences @@ -25,10 +25,11 @@ #:parse-version #:version-compatible-p)) ;; version (in-package :asdf/utility) -;;; *-defining macros - -;;; Functions - +;;;; Defining functions in a way compatible with hot-upgrade: +;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, +;; thus replacing the function without warning or error +;; even if the signature and/or generic-ness of the function has changed. +;; For a generic function, this invalidates any previous DEFMETHOD. (eval-when (:load-toplevel :compile-toplevel :execute) (defun undefine-function (function-spec) (cond @@ -46,16 +47,37 @@ `(progn (undefine-function ',name) #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( - ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl - `(declaim (notinline ,name))) + ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `((declaim (notinline ,name)))) (,',def ,name ,formals ,@rest))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) + +;;; Magic debugging help. See contrib/debug.lisp +(defvar *asdf-debug-utility* + '(symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp") + "form that evaluates to the pathname to your favorite debugging utilities") + +(defmacro asdf-debug (&optional package utility-file) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (load-asdf-debug-utility ',package ',utility-file))) + +(defun* load-asdf-debug-utility (&optional package utility-file) + (let* ((*package* (if package (find-package package) *package*)) + (keyword (read-from-string + (format nil ":DBG-~:@(~A~)" (package-name *package*))))) + (unless (member keyword *features*) + (let* ((utility-file (or utility-file *asdf-debug-utility*)) + (file (ignore-errors (probe-file (eval utility-file))))) + (if file (load file) + (error "Failed to locate debug utility file: ~S" utility-file)))))) + + ;;; Flow control -(defmacro aif (test then &optional else) - "Anaphoric version of IF, On Lisp style" - `(let ((it ,test)) (if it ,then ,else))) +(defmacro if-bind ((var test) then &optional else) + `(let ((,var ,test)) (if ,var ,then ,else))) + ;;; List manipulation (defmacro while-collecting ((&rest collectors) &body body) @@ -101,7 +123,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." :append (list k v))) ;;; Sequences -(defun emptyp (x) +(defun* emptyp (x) "Predicate that is true for an empty sequence" (or (null x) (and (vectorp x) (zerop (length x))))) @@ -133,7 +155,7 @@ starting the separation from the end, e.g. when called with arguments (incf words) (setf end start)))))) -(defun string-prefix-p (prefix string) +(defun* string-prefix-p (prefix string) "Does STRING begin with PREFIX?" (let* ((x (string prefix)) (y (string string)) @@ -141,7 +163,7 @@ starting the separation from the end, e.g. when called with arguments (ly (length y))) (and (<= lx ly) (string= x y :end2 lx)))) -(defun string-suffix-p (string suffix) +(defun* string-suffix-p (string suffix) "Does STRING end with SUFFIX?" (let* ((x (string string)) (y (string suffix)) @@ -149,7 +171,7 @@ starting the separation from the end, e.g. when called with arguments (ly (length y))) (and (<= ly lx) (string= x y :start1 (- lx ly))))) -(defun string-enclosed-p (prefix string suffix) +(defun* string-enclosed-p (prefix string suffix) "Does STRING begin with PREFIX and end with SUFFIX?" (and (string-prefix-p prefix string) (string-suffix-p string suffix))) @@ -162,7 +184,9 @@ starting the separation from the end, e.g. when called with arguments #+gcl<2.7 (keyword nil) (symbol (find-class x errorp environment)))) -;;; stamps: real or boolean where NIL=-infinity, T=+infinity + +;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity +(deftype stamp () '(or real boolean)) (defun* stamp< (x y) (etypecase x (null (and y t)) @@ -182,11 +206,17 @@ starting the separation from the end, e.g. when called with arguments (defun* latest-stamp (&rest list) (stamps-latest list)) (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp) + ;;; Hash-tables (defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) (dolist (x list h) (setf (gethash x h) t))) + ;;; Code execution +(defun* eval-string (string) + "Evaluate a form read from a string." + (eval (read-from-string string))) + (defun* ensure-function (fun &key (package :asdf)) (etypecase fun ((or boolean keyword character number pathname) (constantly fun)) @@ -194,37 +224,14 @@ starting the separation from the end, e.g. when called with arguments (cons (eval `(function ,fun))) (string (eval `(function ,(with-standard-io-syntax (let ((*package* (find-package package))) - (read-from-string fun)))))))) + (eval-string fun)))))))) -(defun* call-function (function-spec) - (funcall (ensure-function function-spec))) +(defun* call-function (function-spec &rest arguments) + (apply (ensure-function function-spec) arguments)) (defun* call-functions (function-specs) (map () 'call-hook-function function-specs)) -(defun eval-string (string) - "Evaluate a form read from a string" - (eval (read-from-string string))) - -(defun do-load (x &key external-format print) - (apply 'load x :print print (when external-format `(:external-format ,external-format)))) - -(defun load-stream (&optional (stream *standard-input*)) - "Portably read and evaluate forms from a STREAM." - ;; GCL 2.6 can't load from a string-input-stream - ;; ClozureCL 1.6 can only load from file input - ;; Allegro 5, I don't remember but it must have been broken when I tested. - #+(or gcl-pre2.7 clozure allegro) - (with-controlled-loader-conditions () - (do ((eof '#:eof) (x t (read stream nil eof))) ((eq x eof)) (eval x))) - #-(or gcl-pre2.7 clozure allegro) - (do-load stream)) - -(defun load-string (string) - "Portably read and evaluate forms from a STRING." - (with-input-from-string (s string) (load-stream s))) - - ;;; Version handling (defun* parse-version (string &optional on-error)