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
${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 \
......
......@@ -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
......
......@@ -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"))))
......@@ -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))))
......
......@@ -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"
......
......@@ -277,7 +277,7 @@
nil)
(defmethod perform ((o load-fasl-op) (c system))
(aif (first (input-files o c)) (load it)))
(if-bind (it (first (input-files o c))) (load it)))
(defmethod mark-operation-done :after ((o load-fasl-op) (c system))
(mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components?
......
......@@ -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
......
......@@ -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)))
......
......@@ -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*))
;;;;; 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 @@
;;;; 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))
......@@ -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.
......
......@@ -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*))
......
;; -*- 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>.
......
......@@ -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))
......@@ -11,11 +11,10 @@
#:loaded-systems ; makes for annoying SLIME completion
#:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
(:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility :asdf/pathname
:asdf/stream :asdf/os :asdf/run-program :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-build :asdf/lisp-action
:asdf/configuration :asdf/output-translations :asdf/source-registry
:asdf/driver
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry
:asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source
:asdf/backward-interface)
;; TODO: automatically generate interface by merging select used packages?
......
......@@ -71,7 +71,7 @@
nil)
(defmethod input-files ((o prepare-op) (s system))
(declare (ignorable o))
(aif (system-source-file s) (list it)))
(if-bind (it (system-source-file s)) (list it)))
;;; compile-op
(defmethod operation-description ((o compile-op) (c component))
......@@ -93,10 +93,11 @@
(multiple-value-bind (output warnings-p failure-p)
(call-with-around-compile-hook
c #'(lambda (&rest flags)
(apply *compile-file-function* input-file
:output-file output-file
#-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c)
(append flags (compile-op-flags o)))))
(with-controlled-compiler-conditions ()
(apply *compile-file-function* input-file
:output-file output-file
:external-format (component-external-format c)
(append flags (compile-op-flags o))))))
(unless output
(error 'compile-error :component c :operation o))
(when failure-p
......@@ -156,8 +157,9 @@
(format s "Recompile ~a and try loading it again"
(component-name c)))
(perform (find-operation o 'compile-op) c)))))
(defun perform-lisp-load-fasl (o c)
(load (first (input-files o c))))
(defun* perform-lisp-load-fasl (o c)
(with-controlled-loader-conditions ()
(load (first (input-files o c)))))
(defmethod perform ((o load-op) (c cl-source-file))
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
......@@ -185,7 +187,7 @@
nil)
(defmethod input-files ((o prepare-source-op) (s system))
(declare (ignorable o))
(aif (system-source-file s) (list it)))
(if-bind (it (system-source-file s)) (list it)))
(defmethod perform ((o prepare-source-op) (c component))
(declare (ignorable o c))
nil)
......@@ -200,10 +202,13 @@
(defmethod component-depends-on ((o load-source-op) (c component))
(declare (ignorable o))
`((prepare-source-op ,c) ,@(call-next-method)))
(defun perform-lisp-load-source (o c)
(defun* perform-lisp-load-source (o c)
(call-with-around-compile-hook
c #'(lambda () (load (first (input-files o c))
#-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c)))))
c #'(lambda ()
(with-controlled-loader-conditions ()
(load* (first (input-files o c))
:external-format (component-external-format c))))))
(defmethod perform ((o load-source-op) (c cl-source-file))
(perform-lisp-load-source o c))
(defmethod perform ((o load-source-op) (c static-file))
......
This diff is collapsed.
......@@ -8,7 +8,7 @@
:asdf/lisp-build :asdf/lisp-action #:asdf/plan
:asdf/find-system :asdf/find-component)
(:export
#:operate #:oos #:*systems-being-operated*
#:operate #:oos #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
#:load-system #:load-systems #:compile-system #:test-system #:require-system
#:*load-system-operation* #:module-provide-asdf
#:component-loaded-p #:already-loaded-systems
......@@ -17,26 +17,6 @@
(defgeneric* operate (operation-class system &key &allow-other-keys))
(defun* reset-asdf-systems ()
(let ((asdf (symbol-call :asdf 'find-system :asdf)))
;; Invalidate all systems but ASDF itself.
(setf *defined-systems* (make-defined-systems-table))
(register-system asdf)
(symbol-call :asdf 'load-system :asdf))) ;; load ASDF a second time, the right way.
(defun* restart-upgraded-asdf ()
;; If we're in the middle of something, restart it.
(when *systems-being-defined*
(let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
(clrhash *systems-being-defined*)
(dolist (s l) (find-system s nil)))))
(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*)
(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)
;;;; Operate itself
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
......@@ -45,6 +25,7 @@
(on-warnings *compile-file-warnings-behaviour*)