2.26.82: much cleanups and fixes on the driver.
authorFrancois-Rene Rideau <tunes@google.com>
Sun, 13 Jan 2013 04:47:16 +0000 (23:47 -0500)
committerFrancois-Rene Rideau <tunes@google.com>
Sun, 13 Jan 2013 04:47:16 +0000 (23:47 -0500)
Tests: SBCL passes test-lisp and test-upgrade
Also:
* big refactoring of test infrastructure
* contrib/debug.lisp and (asdf/driver:asdf-debug) for debugging.
* remove aif and it, use the cleaner if-bind.
* backtrace support, with improvements from trivial-backtrace.
* integration of asdf-condition-control (originally from xcvb-driver)
* simplify the upgrade heuristic: always tries to upgrade once.
  The previous heuristic was too complex with too many failure cases.
  You are thus assumed to want a given version asdf
  if and only if it is in your source-registry.

72 files changed:
Makefile
action.lisp
asdf-driver.asd
asdf.asd
backward-internals.lisp
bundle.lisp
compatibility.lisp
component.lisp
configuration.lisp
contrib/debug.lisp [new file with mode: 0644]
driver.lisp
find-system.lisp
footer.lisp
header.lisp
image.lisp
interface.lisp
lisp-action.lisp
lisp-build.lisp
operate.lisp
os.lisp
package.lisp
pathname.lisp
plan.lisp
run-program.lisp
source-registry.lisp
stream.lisp
test/asdf-pathname-test.script
test/compile-asdf.lisp [deleted file]
test/run-shell-command-test.script
test/run-tests.sh
test/script-support.lisp
test/test-around-compile.script
test/test-builtin-source-file-type.script
test/test-bundle.script
test/test-compile-file-failure.script
test/test-concatenate-source.script
test/test-configuration.script
test/test-encodings.script
test/test-force.script
test/test-logical-pathname.script
test/test-missing-lisp-file.script
test/test-module-depend.script
test/test-module-excessive-depend.script
test/test-module-pathnames.script
test/test-multiple.script
test/test-nested-components.script
test/test-package.script
test/test-redundant-recompile.script
test/test-retry-loading-component-1.script
test/test-samedir-modules.script
test/test-source-file-type.script
test/test-static-and-serial.script
test/test-sysdef-asdf.script
test/test-system-pathnames.script
test/test-touch-system-1.script
test/test-touch-system-2.script
test/test-try-recompiling-1.script
test/test-urls-1.script
test/test-urls-2.script
test/test-utilities.script
test/test-version.script
test/test-weakly-depends-on-present.script
test/test-weakly-depends-on-unpresent.script
test/test-xach-update-bug.script
test/test1.script
test/test2.script
test/test3.script
test/test8.script
test/test9.script
test/wild-module.script
upgrade.lisp
utility.lisp

index 4cc30a7..57e064a 100644 (file)
--- 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 \
index c8d79fa..485979a 100644 (file)
@@ -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
index 83d9c7c..29ed2a5 100644 (file)
@@ -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"))))
index 6beb555..36c1c4e 100644 (file)
--- 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))))
index 7503817..a46c541 100644 (file)
@@ -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"
index 0cd3e24..4bc8f6e 100644 (file)
   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?
index f86053b..f8ef8fe 100644 (file)
@@ -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
index 9aa7055..bc62441 100644 (file)
@@ -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)))
index 4906c44..36ec828 100644 (file)
@@ -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 (file)
index 0000000..9df2cd5
--- /dev/null
@@ -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)")))
index 5d52564..eb0fdfe 100644 (file)
@@ -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))
index eddc75a..6719843 100644 (file)
@@ -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.
index 6cf5ae6..08028cb 100644 (file)
@@ -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*))
 
index daae007..6116199 100644 (file)
@@ -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 <asdf-devel@common-lisp.net>.
index 3c71ce2..0326e48 100644 (file)
@@ -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))
index cec7dd7..288a86e 100644 (file)
    #: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?
index 7c4a99a..9d29f4f 100644 (file)
@@ -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))
     (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
                   (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))
   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)
 (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))
index fd9652d..7342f20 100644 (file)
@@ -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
index a96f625..9ca73eb 100644 (file)
@@ -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
 
 (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 "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
@@ -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 8067e9a..3c10245 100644 (file)
--- 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*)
index e80277c..8aa51f9 100644 (file)
 
 (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))
index 098eb8a..4e09ea3 100644 (file)
    #: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)
index ce3ae40..ad08a4f 100644 (file)
--- 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:
index 6d861a1..77e62f1 100644 (file)
@@ -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)
index e2bdea1..41ad5ec 100644 (file)
@@ -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))
index e705d40..6f42871 100644 (file)
@@ -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*))
   "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
 
index 77c9acb..18b3f3c 100644 (file)
@@ -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))
   (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)
 
  #-(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 (file)
index 1d3817a..0000000
+++ /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)))))))
index 4183d7e..bbc2cf6 100644 (file)
@@ -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")))
index 81d9a44..64c0e56 100755 (executable)
@@ -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
index 2a1a379..b36945c 100644 (file)
+;;;;; 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))
 |#
index 885ac8a..6f240bc 100644 (file)
@@ -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.
index f3d2cca..a31ce7d 100644 (file)
@@ -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
index 9fe4961..b6c8988 100644 (file)
@@ -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)
index 85792e8..668fd8f 100644 (file)
@@ -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))
index e7774fe..4c8d791 100644 (file)
@@ -2,7 +2,7 @@
 (load "script-support.lisp")
 (load-asdf)
 
-(quit-on-error
+(with-test ()
   (defsystem :test-concatenate-source
     :depends-on (:file3-only)
     :components
index ea30fe7..6b0f7f8 100644 (file)
@@ -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")))
index 79e8ed6..600f7cc 100644 (file)
@@ -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))))
 
   (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")))))
 
     (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
index 88fd9bb..5fdb320 100644 (file)
@@ -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)
 
index bc3eced..963bfb1 100644 (file)
@@ -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"))
 
index 4106719..99cbe67 100644 (file)
@@ -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"))))
index 36f90fa..ab05ca2 100644 (file)
@@ -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)
 
index ad8136e..fe6a5e4 100644 (file)
 ;;; 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."))))
index 8d23240..e3aedb7 100644 (file)
@@ -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))
index 11bc283..0436def 100644 (file)
@@ -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))))
index c1baa50..7783099 100644 (file)
@@ -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
index 33d6938..4ea06b6 100644 (file)
@@ -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 () ())
index e2038ea..499d7ac 100644 (file)
@@ -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
index f3145e2..66e81f1 100644 (file)
@@ -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))
index 243d5c6..3abaf9c 100644 (file)
@@ -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)
index 57f1727..494afc6 100644 (file)
@@ -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*")))
index 97d7221..b39596a 100644 (file)
@@ -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*))
index b241188..59f4174 100644 (file)
@@ -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))
index 4d66181..3ba40d7 100644 (file)
@@ -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")
index 518f16a..5c9ec5c 100644 (file)
@@ -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
index 6e5ac5e..3694802 100644 (file)
@@ -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
index 0b15456..e1c6693 100644 (file)
@@ -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)
index a630e74..1b120b8 100644 (file)
@@ -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)
index ad99143..46237b1 100644 (file)
@@ -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)
index 0def8b2..4202975 100644 (file)
@@ -5,7 +5,7 @@
 (in-package :asdf)
 (use-package :asdf-test)
 
-(quit-on-error
+(with-test ()
 
 (assert
  (every #'directory-pathname-p
index 57b81d7..6cf95d9 100644 (file)
@@ -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")
index b55c386..992ae48 100644 (file)
@@ -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...
index 1bebe63..ffab4cd 100644 (file)
@@ -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
index eb40cba..7bc7cff 100644 (file)
@@ -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)))
index 1f1ae51..9b764db 100644 (file)
@@ -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"))
index 641d43d..6a6fbaf 100644 (file)
@@ -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)
index ceb240d..fc6b234 100644 (file)
@@ -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))
index caebad0..6719d17 100644 (file)
@@ -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)
index 32180ca..fb2e358 100644 (file)
@@ -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"))
index f2a0f35..e6dd5ea 100644 (file)
@@ -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")))
index 14c2746..63a47ab 100644 (file)
@@ -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))))
index 9f15dd7..678da26 100644 (file)
@@ -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
    #: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
           `(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)