${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)
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 \
;; 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
(: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"))))
: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))))
;; 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"
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?
(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
(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
(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)))
(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
(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*))
--- /dev/null
+;;;;; 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)")))
;;;; 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))
#: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.
(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.
#+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>.
(: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
;;; 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)
#+(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)
(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)))
"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)))
;;; 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*)
;;; 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
#-(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."
(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*)))
(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
: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))
#: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?
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))
(: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)
(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)
#+(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)))
;;; 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,
((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
(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))
(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))
(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
(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)
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
: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")
(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)))
(*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)
(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."
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)
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)
(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.~@:>~%")
(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*)
(: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
(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
#-(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)))
#+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)))
;;; 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)
#+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)
#+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)
(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*)
(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)
(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))
#: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
: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"
(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))
;;; 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))))
(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)
. #.(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))))
;;; 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
#+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)
(end-of-file (c)
(declare (ignore c))
nil)))))
+
+;;; Hook for output translations
+(defvar *output-translation-hook* 'identity)
(: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)
(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:
;;;; ----- 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."
(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)"
(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))
(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"
(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."
(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))
(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)
(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)
(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))
(: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
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))
;;; 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."
`(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
: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)
(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
;;; (: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")
+++ /dev/null
-(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)))))))
(load-asdf)
;;; test asdf run-shell-command function
-(quit-on-error
+(with-test ()
#+asdf-unix
(progn
(assert (eql 1 (asdf:run-shell-command "false")))
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
export DEBUG_ASDF_TEST=t
;;
u)
- usage
- exit 1
+ upgrade=t
;;
h)
usage
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
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
+;;;;; 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
(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))
|#
(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.
;;(trace source-file-type)
-(quit-on-error
+(with-test ()
(format t "~D~%" (asdf:asdf-version))
(defsystem test-builtin-source-file-type-1
;;;---------------------------------------------------------------------------
-(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)
(load "script-support.lisp")
(load-asdf)
-(quit-on-error
+(with-test ()
#-gcl<2.7
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :warn))
(load "script-support.lisp")
(load-asdf)
-(quit-on-error
+(with-test ()
(defsystem :test-concatenate-source
:depends-on (:file3-only)
:components
: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")))
#+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)
(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
(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)
`(,*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"))
(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"))))
(load "script-support.lisp")
(load-asdf)
-(quit-on-error
+(with-test ()
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-module-depend)
;;; 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."))))
(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))
(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))))
(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
(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 () ())
(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
(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))
(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)
;;(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*")))
#+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*))
(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))
(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")
(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
(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
(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)
#+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)
#+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)
(in-package :asdf)
(use-package :asdf-test)
-(quit-on-error
+(with-test ()
(assert
(every #'directory-pathname-p
(setf *central-registry* '(*default-pathname-defaults*))
-(quit-on-error
+(with-test ()
(defsystem :versioned-system-1
:pathname #.*default-pathname-defaults*
:version "1.0")
;;;---------------------------------------------------------------------------
-(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...
(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
(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)))
(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"))
;;; -*- 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)
;;; -*- 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))
(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)
(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"))
;;; -*- 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")))
(: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*))
(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)
;; "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)))
;;; Self-upgrade functions
+(defvar *asdf-upgrade-already-attempted* nil)
+
(defvar *post-upgrade-cleanup-hook* ())
(defvar *post-upgrade-restart-hook* ())
(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))))
(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)
: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)))))
(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))
(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))
(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)))
#+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))
(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))
(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)
common-lisp.net / projects/asdf/asdf.git / commitdiff
