Commit 21594070 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.82: much cleanups and fixes on the driver.

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.
parent 74c38c6d
...@@ -51,7 +51,7 @@ archive-copy: archive build/asdf.lisp ...@@ -51,7 +51,7 @@ archive-copy: archive build/asdf.lisp
${MAKE} push ${MAKE} push
git checkout master 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 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) build/asdf.lisp: $(wildcard *.lisp)
...@@ -101,67 +101,15 @@ mrproper: clean ...@@ -101,67 +101,15 @@ mrproper: clean
rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap
test-upgrade: build/asdf.lisp test-upgrade: build/asdf.lisp
# 1.37 is the last release by Daniel Barlow ./test/run-tests.sh -u ${lisp}
# 1.97 is the last release before Gary King takes over
# 1.369 is the last release by Gary King test-compile: build/asdf.lisp
# 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
${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 ${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 test-lisp: build/asdf.lisp
@cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob} @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: test-all-lisps:
@for lisp in ${lisps} ; do \ @for lisp in ${lisps} ; do \
......
...@@ -95,7 +95,7 @@ You can put together sentences using this phrase.")) ...@@ -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 ;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that. ;; so we must guard against this case. ASDF3: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component)) (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 ;;;; Inputs, Outputs, and invisible dependencies
......
...@@ -16,5 +16,5 @@ that you can't portably construct a complete program without using them." ...@@ -16,5 +16,5 @@ that you can't portably construct a complete program without using them."
(:file "image" :depends-on ("os")) (:file "image" :depends-on ("os"))
(:file "run-program" :depends-on ("os")) (:file "run-program" :depends-on ("os"))
(:file "lisp-build" :depends-on ("image")) (: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"))))
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.81" ;; to be automatically updated by bin/bump-revision :version "2.26.82" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -50,7 +50,7 @@ ...@@ -50,7 +50,7 @@
;; This won't recurse into dependencies to accumulate feature conditions. ;; This won't recurse into dependencies to accumulate feature conditions.
;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL ;; 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. ;; (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-message "The system definition for ~S uses deprecated ~
ASDF option :IF-COMPONENT-DEP-DAILS. ~ ASDF option :IF-COMPONENT-DEP-DAILS. ~
Starting with ASDF 2.27, please use :IF-FEATURE instead" Starting with ASDF 2.27, please use :IF-FEATURE instead"
......
...@@ -277,7 +277,7 @@ ...@@ -277,7 +277,7 @@
nil) nil)
(defmethod perform ((o load-fasl-op) (c system)) (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)) (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? (mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components?
......
...@@ -7,6 +7,7 @@ ...@@ -7,6 +7,7 @@
(asdf/package:define-package :asdf/compatibility (asdf/package:define-package :asdf/compatibility
(:use :common-lisp :asdf/package) (:use :common-lisp :asdf/package)
(:recycle :asdf/compatibility :asdf) (:recycle :asdf/compatibility :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp #+cormanlisp
(:export (:export
#:logical-pathname #:translate-logical-pathname #:logical-pathname #:translate-logical-pathname
......
...@@ -106,9 +106,9 @@ another pathname in a degenerate way.")) ...@@ -106,9 +106,9 @@ another pathname in a degenerate way."))
(format stream "~{~S~^ ~}" (component-find-path c)))) (format stream "~{~S~^ ~}" (component-find-path c))))
(defmethod component-system ((component component)) (defmethod component-system ((component component))
(aif (component-parent component) (if-bind (system (component-parent component))
(component-system it) (component-system system)
component)) component))
;;;; component pathnames ;;;; component pathnames
...@@ -137,7 +137,8 @@ another pathname in a degenerate way.")) ...@@ -137,7 +137,8 @@ another pathname in a degenerate way."))
(defmethod component-relative-pathname ((component component)) (defmethod component-relative-pathname ((component component))
(coerce-pathname (coerce-pathname
(or (slot-value component 'relative-pathname) (or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname))
(component-name component)) (component-name component))
:type (source-file-type component (component-system component)) ;; backward-compatibility :type (source-file-type component (component-system component)) ;; backward-compatibility
:defaults (component-parent-pathname component))) :defaults (component-parent-pathname component)))
......
...@@ -56,8 +56,8 @@ ...@@ -56,8 +56,8 @@
(cond (cond
((os-unix-p) '(#p"/etc/common-lisp/")) ((os-unix-p) '(#p"/etc/common-lisp/"))
((os-windows-p) ((os-windows-p)
(aif (subpathname* (get-folder-path :common-appdata) "common-lisp/config/") (if-bind (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
(list it))))) (list it)))))
(defun* in-first-directory (dirs x &key (direction :input)) (defun* in-first-directory (dirs x &key (direction :input))
(loop :with fun = (ecase direction (loop :with fun = (ecase direction
...@@ -274,9 +274,8 @@ Please remove it from your ASDF configuration")) ...@@ -274,9 +274,8 @@ Please remove it from your ASDF configuration"))
(eq (caadr x) 'lambda) (eq (caadr x) 'lambda)
(length=n-p (cadadr x) 2))))) (length=n-p (cadadr x) 2)))))
(defvar *clear-configuration-hook* '()) (defvar *clear-configuration-hook* '())
(defun* clear-configuration () (defun* clear-configuration ()
(map () #'funcall *clear-configuration-hook*)) (call-functions *clear-configuration-hook*))
;;;;; 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)")))
...@@ -2,9 +2,13 @@ ...@@ -2,9 +2,13 @@
;;;; Re-export all the functionality in asdf/driver ;;;; Re-export all the functionality in asdf/driver
(asdf/package:define-package :asdf/driver (asdf/package:define-package :asdf/driver
(:use (:use :common-lisp
:common-lisp :asdf/package :asdf/compatibility :asdf/utility :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)
(:reexport (:reexport
:asdf/package :asdf/compatibility :asdf/utility :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))
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
#:initialize-source-registry #:sysdef-source-registry-search)) #:initialize-source-registry #:sysdef-source-registry-search))
(in-package :asdf/find-system) (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) () (define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not. ;; [this use of :report should be redundant, but unfortunately it's not.
...@@ -84,7 +84,9 @@ of which is a system object.") ...@@ -84,7 +84,9 @@ of which is a system object.")
(asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
(unless (eq system (cdr (gethash name *defined-systems*))) (unless (eq system (cdr (gethash name *defined-systems*)))
(setf (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) (defun* clear-system (name)
"Clear the entry for a system in the database of systems previously loaded. "Clear the entry for a system in the database of systems previously loaded.
......
...@@ -57,7 +57,7 @@ ...@@ -57,7 +57,7 @@
#+allegro #+allegro
(eval-when (:compile-toplevel :execute) (eval-when (:compile-toplevel :execute)
(when (boundp 'excl:*warn-on-nested-reader-conditionals*) (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*)) (dolist (f '(:asdf :asdf2 :asdf2.27)) (pushnew f *features*))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.81: Another System Definition Facility. ;;; This is ASDF 2.26.82: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -7,7 +7,8 @@ ...@@ -7,7 +7,8 @@
(:export (:export
#:*arguments* #:*dumped* #:raw-command-line-arguments #:*command-line-arguments* #:*arguments* #:*dumped* #:raw-command-line-arguments #:*command-line-arguments*
#:*debugging* #:*post-image-restart* #:*entry-point* #:*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 #:register-image-resume-hook #:register-image-dump-hook
#:call-image-resume-hook #:call-image-dump-hook #:call-image-resume-hook #:call-image-dump-hook
#:initialize-asdf-utilities #:initialize-asdf-utilities
...@@ -40,12 +41,11 @@ but before the entry point is called.") ...@@ -40,12 +41,11 @@ but before the entry point is called.")
;;; Exiting properly or im- ;;; 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. "Quits from the Lisp world, with the given exit status if provided.
This is designed to abstract away the implementation specific quit forms." 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.
(when finish-output ;; essential, for ClozureCL, and for standard compliance. (finish-outputs))
(ignore-errors (finish-outputs))))
#+(or abcl xcl) (ext:quit :status code) #+(or abcl xcl) (ext:quit :status code)
#+allegro (excl:exit code :quiet t) #+allegro (excl:exit code :quiet t)
#+clisp (ext:quit code) #+clisp (ext:quit code)
...@@ -54,7 +54,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -54,7 +54,7 @@ This is designed to abstract away the implementation specific quit forms."
#+(or cmu scl) (unix:unix-exit code) #+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code) #+ecl (si:quit code)
#+gcl (lisp: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) #+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) ? #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code) #+mkcl (mk-ext:quit :exit-code code)
...@@ -64,43 +64,85 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -64,43 +64,85 @@ This is designed to abstract away the implementation specific quit forms."
(exit `(,exit :code code :abort (not finish-output))) (exit `(,exit :code code :abort (not finish-output)))
(quit `(,quit :unix-status code :recklessly-p (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) #-(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" "Die in error with some error message"
(with-safe-io-syntax () (with-safe-io-syntax ()
(ignore-errors (ignore-errors
(format! *stderr* "~&") (fresh-line *stderr*)
(apply #'format! *stderr* format arguments) (apply #'format *stderr* format arguments)
(format! *stderr* "~&"))) (format! *stderr* "~&")))
(quit 99)) (quit code))
(defun print-backtrace (out) (defun* raw-print-backtrace (&key (stream *debug-io*) count)
"Print a backtrace (implementation-defined)" "Print a backtrace, directly accessing the implementation"
(declare (ignorable out)) (declare (ignorable stream count))
#+clisp (system::print-backtrace) #+allegro
#+clozure (let ((*debug-io* out)) (let ((*terminal-io* stream)
(ccl:print-call-history :count 100 :start-frame-number 1) (*standard-output* stream)
(finish-output out)) (tpl:*zoom-print-circle* *print-circle*)
#+ecl (si::tpl-backtrace) (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 #+sbcl
(sb-debug:backtrace (sb-debug:backtrace
#.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum) #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
out)) stream))
(defun bork (condition) (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" "Depending on whether *DEBUGGING* is set, enter debugger or die"
(with-safe-io-syntax () (safe-format! *stderr* "~&BORK:~%~A~%" condition)
(ignore-errors (format! *stderr* "~&BORK:~%~A~%" condition)))
(cond (cond
(*debugging* (*debugging*
(invoke-debugger condition)) (invoke-debugger condition))
(t (t
(with-safe-io-syntax () (print-condition-backtrace condition :stream *stderr*)
(ignore-errors (print-backtrace *stderr*))) (die 99 "~A" condition))))
(die "~A" condition))))
(defun call-with-coded-exit (thunk) (defun* call-with-coded-exit (thunk)
(handler-bind ((error 'bork)) (handler-bind ((error 'bork))
(funcall thunk) (funcall thunk)
(quit 0))) (quit 0)))
...@@ -109,7 +151,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -109,7 +151,7 @@ This is designed to abstract away the implementation specific quit forms."