diff --git a/Makefile b/Makefile index bbabf056f66cd33ce34c704bf4304881bbb5ab3f..8ba0d4c5577fee37c2a965390b96c07d07474600 100644 --- a/Makefile +++ b/Makefile @@ -11,6 +11,7 @@ lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks alleg endif export ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/tmp/fasls" :implementation)) :ignore-inherited-configuration) +export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration) ## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but upstream fails to compile. ## NOT SUPPORTED BY OUR TESTS: cormancl genera lispworks-personal-edition mkcl rmcl. Manually tested once in a while. @@ -29,6 +30,7 @@ SCL ?= scl ALLEGRO ?= alisp ALLEGROMODERN ?= mlisp LISPWORKS ?= lispworks +GCL ?= gcl # website, tag, install @@ -98,6 +100,7 @@ test-upgrade: 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="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" ; } ; \ diff --git a/asdf.asd b/asdf.asd index 4627647a6b033da4797250fcc9edf9b28f998b30..75811dd29f7bc1bf5f5cd72b9c743039f48307f3 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.47" ;; to be automatically updated by bin/bump-revision + :version "2.26.48" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/asdf.lisp b/asdf.lisp index c59ad3aaca5ceb30ec773b2065dd268244c082c3..d92e96604d5437b4d53955ad82f71914a865f71a 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.47: Another System Definition Facility. +;;; This is ASDF 2.26.48: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -57,8 +57,6 @@ ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See these two eval-when forms, and more near the end of the file. -#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this - (eval-when (:load-toplevel :compile-toplevel :execute) ;;; Before we do anything, some implementation-dependent tweaks ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. @@ -70,7 +68,8 @@ (when (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))) - (pushnew :gcl-pre2.7 *features*)) + (pushnew 'ignorable pcl::*variable-declarations-without-argument*) + (pushnew :gcl<2.7 *features*)) #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) clozure lispworks (and sbcl sb-unicode) scl) (pushnew :asdf-unicode *features*) @@ -79,6 +78,9 @@ (unless (find-package :asdf) (make-package :asdf :use '(:common-lisp)))) +#+gcl (defpackage :asdf (:use :cl) ;; GCL treats defpackage magically and needs this + #+gcl<2.7 (:shadowing-import-from :system :*load-pathname*)) + (in-package :asdf) (eval-when (:load-toplevel :compile-toplevel :execute) @@ -100,12 +102,11 @@ (defun strcat (&rest strings) (apply 'concatenate 'string strings)) (defmacro compatfmt (format) - #-(or gcl genera) format #+(or gcl genera) (loop :for (unsupported . replacement) :in (append '(("~3i~_" . "")) - #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do + #+(or genera gcl<2.7) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do (setf format (strcat (subseq format 0 found) replacement (subseq format (+ found (length unsupported))))))) @@ -118,7 +119,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.47") + (asdf-version "2.26.48") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -233,18 +234,17 @@ :use (:common-lisp) :redefined-functions (#:perform #:explain #:output-files #:operation-done-p #:do-traverse - #:visit-action #:compute-action-stamp #:component-load-dependencies #:traverse-action + #:compute-action-stamp #:component-load-dependencies #:traverse-action #:component-depends-on #:perform-plan #:mark-operation-done #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname* #:resolve-location - #:system-relative-pathname #:source-file-type - #:component-visited-p #:builtin-system-p + #:system-relative-pathname #:source-file-type #:builtin-system-p #:inherit-source-registry #:process-source-registry #:process-source-registry-directive #:compile-file* #:source-file-type #:trivial-system-p) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector #:do-dep #:do-one-dep + #:split #:make-collector #:do-dep #:do-one-dep #:visit-action #:component-visited-p #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function :export @@ -455,7 +455,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") condition-format condition-location coerce-name) (ftype (function (&optional t) (values)) initialize-source-registry) - #-(or cormanlisp gcl-pre2.7) + #-(or cormanlisp gcl<2.7) (ftype (function (t t) t) (setf component-children-by-name))) ;;;; ------------------------------------------------------------------------- @@ -488,14 +488,58 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) (ccl::%path-from-fsref fsref is-dir))))))")) +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + +#+gcl<2.7 +(progn + (deftype logical-pathname () nil) + (defun wild-pathname-p (path) (declare (ignore path)) nil) + (defun translate-logical-pathname (x) x) + (defvar *compile-file-pathname* nil) + (defun pathname-match-p (in-pathname wild-pathname) + (declare (ignore in-wildname wild-wildname)) nil) + (defun translate-pathname (source from-wildname to-wildname &key) + (declare (ignore from-wildname to-wildname)) source) + (defun %print-unreadable-object (object stream type identity thunk) + (format stream "<~@[~S ~] " (when type (class-name (class-of object)))) + (funcall thunk) + (format stream "~@[ ~X~]>" (when identity (system:address object)))) + (defmacro with-compilation-unit (options &body body) + (declare (ignore options)) `(progn ,@body)) + (defmacro print-unreadable-object ((object stream &key type identity) &body body) + `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body))) + (defun ensure-directories-exist (path) + (run-shell-command "mkdir -p ~S" (namestring (pathname-directory-pathname path))))) + ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities +(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))))) + (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) `(progn - #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) + #+(or ecl gcl) + ,(when (and #+gcl<2.7 (symbolp name)) + `(fmakunbound ',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))) @@ -535,10 +579,13 @@ and NIL NAME, TYPE and VERSION components" "Given a pathname directory component, return an equivalent form that is a list" (cond #-(or cmu sbcl scl) ;; these implementations already normalize directory components. - ((stringp directory) `(:absolute ,directory) directory) - #+gcl + ((stringp directory) `(:absolute ,directory)) + #+gcl<2.7 ((and (consp directory) (stringp (first directory))) - `(:absolute ,@directory)) + `(:relative ,@directory)) + #+gcl<2.7 + ((and (consp directory) (eq :root (first directory))) + `(:absolute ,@(rest directory))) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) @@ -576,10 +623,27 @@ and NIL NAME, TYPE and VERSION components" #+clisp (cons (mapcar 'make-pathname-component-logical x)) (t x))) +(defun* denormalize-pathname-directory-component (directory) + #-gcl<2.7 directory + #+gcl<2.7 + (cond + ((and (consp directory) (eq :relative (first directory))) + (rest directory)) + ((and (consp directory) (eq :absolute (first directory))) + `(:root ,@(rest directory))) + (t + directory))) + +(defun* make-pathname* (&key host device directory name type version defaults) + (make-pathname + :defaults defaults :host host :device device + :directory (denormalize-pathname-directory-component directory) + :name name :type type :version version)) + (defun* make-pathname-logical (pathname host) "Take a PATHNAME's directory, name, type and version components, and make a new pathname with corresponding components and specified logical HOST" - (make-pathname + (make-pathname* :host host :directory (make-pathname-component-logical (pathname-directory pathname)) :name (make-pathname-component-logical (pathname-name pathname)) @@ -618,19 +682,19 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (pathname-device defaults) (merge-pathname-directory-components directory (pathname-directory defaults)) (unspecific-handler defaults)))) - (make-pathname :host host :device device :directory directory - :name (funcall unspecific-handler name) - :type (funcall unspecific-handler type) - :version (funcall unspecific-handler version)))))) + (make-pathname* :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) (defun* pathname-parent-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" (when pathname - (make-pathname :name nil :type nil :version nil - :directory (merge-pathname-directory-components - '(:relative :back) (pathname-directory pathname)) - :defaults pathname))) + (make-pathname* :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) (define-modify-macro appendf (&rest args) append "Append onto list") ;; only to be used on short lists. @@ -646,7 +710,7 @@ and NIL NAME, TYPE and VERSION components" (defun* asdf-message (format-string &rest format-args) - (declare (dynamic-extent format-args)) + #-gcl<2.7 (declare (dynamic-extent format-args)) (apply 'format *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) @@ -791,20 +855,16 @@ actually-existing directory." ((directory-pathname-p pathspec) pathspec) (t - (make-pathname :directory (append (or (pathname-directory pathspec) - (list :relative)) - (list (file-namestring pathspec))) - :name nil :type nil :version nil - :defaults pathspec)))) - -#+genera -(unless (fboundp 'ensure-directories-exist) - (defun* ensure-directories-exist (path) - (fs:create-directories-recursively (pathname path)))) + (make-pathname* :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil :defaults pathspec)))) (defun* absolute-pathname-p (pathspec) (and (typep pathspec '(or pathname string)) - (eq :absolute (car (pathname-directory (pathname pathspec)))))) + (eq :absolute (car (normalize-pathname-directory-component + (pathname-directory (pathname pathspec))))))) (defun* coerce-pathname (name &key type defaults) "coerce NAME into a PATHNAME. @@ -839,7 +899,7 @@ Host, device and version components are taken from DEFAULTS." (values filename type)) (t (split-name-type filename))) - (apply 'make-pathname :directory (cons relative path) :name name :type type + (apply 'make-pathname* :directory (cons relative path) :name name :type type (when defaults `(:defaults ,defaults)))))))) (defun* merge-component-name-type (name &key type defaults) @@ -880,11 +940,11 @@ Host, device and version components are taken from DEFAULTS." :collect form))) (defun* pathname-root (pathname) - (make-pathname :directory '(:absolute) - :name nil :type nil :version 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)))) + (make-pathname* :directory '(:absolute) + :name nil :type nil :version 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)))) (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory @@ -897,6 +957,12 @@ with given pathname and if it exists return its truename." '(probe-file p) #+clisp (aif (find-symbol* '#:probe-pathname :ext) `(ignore-errors (,it p))) + #+gcl<2.7 + '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename (subpathname (ensure-directory-pathname p) ".")))))) '(ignore-errors (truename p))))))) (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) @@ -916,11 +982,11 @@ with given pathname and if it exists return its truename." (unless sofar (return p)) (flet ((solution (directories) (merge-pathnames* - (make-pathname :host nil :device nil - :directory `(:relative ,@directories) - :name (pathname-name p) - :type (pathname-type p) - :version (pathname-version p)) + (make-pathname* :host nil :device nil + :directory `(:relative ,@directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) sofar))) (loop :with directory = (normalize-pathname-directory-component (pathname-directory p)) @@ -928,7 +994,7 @@ with given pathname and if it exists return its truename." :for rest :on (cdr directory) :for more = (probe-file* (merge-pathnames* - (make-pathname :directory `(:relative ,component)) + (make-pathname* :directory `(:relative ,component)) sofar)) :do (if more (setf sofar more) @@ -962,14 +1028,16 @@ with given pathname and if it exists return its truename." (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) -(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") +(defparameter *wild* (or #+cormanlisp "*" :wild)) (defparameter *wild-file* - (make-pathname :name *wild* :type *wild* - :version (or #-(or abcl xcl) *wild*) :directory nil)) + (make-pathname* :directory nil :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*))) (defparameter *wild-directory* - (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) + (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "*" *wild*)) + :name nil :type nil :version nil)) (defparameter *wild-inferiors* - (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) + (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "**" :wild-inferiors)) + :name nil :type nil :version nil)) (defparameter *wild-path* (merge-pathnames *wild-file* *wild-inferiors*)) @@ -978,7 +1046,7 @@ with given pathname and if it exists return its truename." #-scl (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) - (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl @@ -997,8 +1065,7 @@ with given pathname and if it exists return its truename." (component-name-to-pathname-components root-string :force-directory t) (declare (ignore relative filename)) (let ((new-base - (make-pathname :defaults root - :directory `(:absolute ,@path)))) + (make-pathname* :defaults root :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) #+scl @@ -1020,8 +1087,8 @@ with given pathname and if it exists return its truename." (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) + (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) pathname))) (defun* add-pathname-suffix (pathname suffix) @@ -1125,13 +1192,15 @@ another pathname in a degenerate way.")) (defgeneric* component-property (component property)) +#-gcl<2.7 (defgeneric* (setf component-property) (new-value component property)) (defgeneric* component-external-format (component)) (defgeneric* component-encoding (component)) -(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) +#-gcl<2.7 +(eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric* (setf component-children-by-name) (new-value parent))) (defgeneric* version-satisfies (component version)) @@ -1664,7 +1733,8 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" (buffer (make-array length))) (read-sequence buffer s) (map 'string #'code-char buffer))))))) - (end-of-file () + (end-of-file (c) + (declare (ignore c)) nil))))) ;;;; ------------------------------------------------------------------------- @@ -1888,7 +1958,7 @@ Going forward, we recommend new users should be using the source-registry. (external-format (encoding-external-format (detect-encoding pathname)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) - (load pathname :external-format external-format))) + (load pathname #-gcl<2.7 :external-format #-gcl<2.7 external-format))) (delete-package package))))) (defun* locate-system (name) @@ -2096,9 +2166,9 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) - (print-unreadable-object (o stream :type t :identity t) + (print-unreadable-object (o stream :type t :identity nil) (ignore-errors - (prin1 (operation-original-initargs o) stream)))) + (format stream "~{~S~^ ~}" (operation-original-initargs o))))) (defun* node-for (o c) (cons (class-name (class-of o)) c)) @@ -2226,13 +2296,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (latest-stamp-f stamp (funcall fun dep-o dep-c)))) stamp) -(defgeneric needed-in-image-p (operation component) - (:method ((o operation) (c component)) - ;; We presume that actions that modify the filesystem don't need be run - ;; in the current image if they have already been done in another, - ;; and can be run in another process (e.g. a fork), - ;; whereas those that don't are meant to side-effect the current image and can't. - (not (output-files o c)))) +(defgeneric* needed-in-image-p (operation component)) +(defmethod needed-in-image-p ((o operation) (c component)) + ;; We presume that actions that modify the filesystem don't need be run + ;; in the current image if they have already been done in another, + ;; and can be run in another process (e.g. a fork), + ;; whereas those that don't are meant to side-effect the current image and can't. + (not (output-files o c))) (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes @@ -2286,6 +2356,11 @@ in some previous image, or T if it needs to be done.") :documentation "generalized boolean, true iff the action was already done (before any plan).")) (:documentation "Status of an action")) +(defmethod print-object ((status action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) + (defclass planned-action-status (action-status) ((planned-p :initarg :planned-p :reader action-planned-p @@ -2293,11 +2368,13 @@ in some previous image, or T if it needs to be done.") If true, an integer indexing the action in the list of actions planned.")) (:documentation "Status of an action in a plan")) +(defmethod print-object ((status planned-action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p planned-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p)))) + (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) - (prog1 - (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status) - (when (action-done-p new-status) - (mark-operation-done o c)))) + (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) (values (gethash (node-for o c) (plan-visited-actions plan)))) @@ -2355,10 +2432,11 @@ If true, an integer indexing the action in the list of actions planned.")) ;; either our model is wrong or some other process is messing with our files. (when (and just-done (not all-present)) (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ - ~:[~; or~] ~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" + ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" (operation-description o c) missing-in (length missing-in) (and missing-in missing-out) missing-out (length missing-out))) +;;(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)) ;; Note that we use stamp<= instead of stamp< to play nice with generated files. ;; Any race condition is intrinsic to the limited timestamp resolution. (if (or just-done ;; The done-stamp is valid: if we're just done, or @@ -2392,7 +2470,7 @@ If true, an integer indexing the action in the list of actions planned.")) (defmacro while-visiting-action ((p o c) &body body) `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))) -(defgeneric* traverse-action (operation component needed-in-image-p collect)) +(defgeneric* traverse-action (plan operation component needed-in-image-p)) (defmethod (setf plan-action-status) :after (new-status (p sequential-plan) (o operation) (c component)) @@ -2401,58 +2479,40 @@ If true, an integer indexing the action in the list of actions planned.")) (defmethod plan-record-dependency ((plan sequential-plan) (operation operation) (component component)) - (declare (ignore plan operation component)) + (declare (ignorable plan operation component)) (values)) (defmethod traverse-action (plan operation component needed-in-image-p) (block nil + ;;(DBG :ta operation component needed-in-image-p (plan-visiting-action-list plan)) (unless (action-valid-p operation component) (return nil)) - (let* ((niip (needed-in-image-p operation component)) - (eniip (and niip needed-in-image-p)) + (plan-record-dependency plan operation component) + (let* ((aniip (needed-in-image-p operation component)) + (eniip (and aniip needed-in-image-p)) (status (plan-action-status plan operation component))) - (plan-record-dependency plan operation component) (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) - ;; Already visited with sufficient level of need-in-image: just return the stamp. + ;; Already visited with sufficient need-in-image level: just return the stamp. + ;;(DBG :ad status eniip aniip) (return (action-stamp status))) - (labels ((visit-action (o c plan recurse fun) - (visit-dependencies o c recurse) + (labels ((visit-action (niip) + (visit-dependencies operation component + #'(lambda (o c) (traverse-action plan o c niip))) (multiple-value-bind (stamp done-p) - (compute-action-stamp o c :plan plan) - (funcall fun done-p stamp))) - (recurse (niip) - #'(lambda (o c) (traverse-action plan o c niip))) - (mark-visited (o c &key stamp planned-p done-p) - (setf (plan-action-status plan o c) - (make-instance 'planned-action-status - :stamp stamp - :done-p done-p - :planned-p (and planned-p (incf (plan-action-count plan))))) - stamp) - (revisit-harder () - (visit-action - operation component plan (recurse t) - #'(lambda (done-p stamp) - (assert (not done-p)) - (mark-visited operation component :stamp stamp :planned-p (not done-p)))))) - (while-visiting-action (plan operation component) - (cond - (status - ;; Already visited, it had all its input up-to-date, - ;; wasn't previously need in image but now is. - (revisit-harder)) - (t - ;; Not visited yet. - (visit-action - operation component plan (recurse niip) - #'(lambda (done-p stamp) - (let ((add-to-plan-p (and (not done-p) (or niip (eql stamp t))))) - (cond - ((and add-to-plan-p (not niip)) - (revisit-harder)) - (t - (mark-visited - operation component - :stamp stamp :done-p done-p :planned-p add-to-plan-p))))))))))))) + (compute-action-stamp operation component :plan plan) + (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) + ;;(DBG :va operation component needed-in-image-p niip aniip eniip done-p stamp add-to-plan-p) + (cond + ((and add-to-plan-p (not niip)) ;; if we need to do it, + (visit-action t)) ;; then we need to do it in the image! + (t + (setf (plan-action-status plan operation component) + (make-instance 'planned-action-status + :stamp stamp + :done-p (and done-p (not add-to-plan-p)) + :planned-p (and add-to-plan-p (incf (plan-action-count plan))))) + stamp)))))) + (while-visiting-action (plan operation component) ; maintain context, handle circularity. + (visit-action eniip)))))) (defmethod traverse ((o operation) (c component)) (let ((plan (make-instance 'sequential-plan))) @@ -2555,7 +2615,7 @@ If true, an integer indexing the action in the list of actions planned.")) c #'(lambda (&rest flags) (apply *compile-op-compile-file-function* source-file :output-file output-file - :external-format (component-external-format c) + #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c) (append flags (compile-op-flags o))))) (unless output (error 'compile-error :component c :operation o)) @@ -2911,6 +2971,7 @@ T to force the inside of the specified system to be rebuilt (resp. not), (defun* find-class* (x &optional (errorp t) environment) (etypecase x ((or standard-class built-in-class) x) + #+gcl<2.7 (keyword nil) (symbol (find-class x errorp environment)))) (defun* class-for-type (parent type) @@ -2918,10 +2979,10 @@ T to force the inside of the specified system to be rebuilt (resp. not), type (find-symbol* type *package*) (find-symbol* type :asdf)) - :for class = (and symbol (find-class symbol nil)) + :for class = (and symbol (find-class* symbol nil)) :when (and class (#-cormanlisp subtypep #+cormanlisp cl::subclassp - class (find-class 'component))) + class (find-class* 'component))) :return class) (and (eq type :file) (find-class* @@ -2930,32 +2991,6 @@ T to force the inside of the specified system to be rebuilt (resp. not), *default-component-class*) nil)) (sysdef-error "don't recognize component type ~A" type))) -(defun* maybe-add-tree (tree op1 op2 c) - "Add the node C at /OP1/OP2 in TREE, unless it's there already. -Returns the new tree (which probably shares structure with the old one)" - (let ((first-op-tree (assoc op1 tree))) - (if first-op-tree - (progn - (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it) :test #'equal) - nil - (setf (cdr it) (cons c (cdr it)))) - (setf (cdr first-op-tree) - (acons op2 (list c) (cdr first-op-tree)))) - tree) - (acons op1 (list (list op2 c)) tree)))) - -(defun* union-of-dependencies (&rest deps) - (let ((new-tree nil)) - (dolist (dep deps) - (dolist (op-tree dep) - (dolist (op (cdr op-tree)) - (dolist (c (cdr op)) - (setf new-tree - (maybe-add-tree new-tree (car op-tree) (car op) c)))))) - new-tree)) - - (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) @@ -2988,7 +3023,7 @@ Returns the new tree (which probably shares structure with the old one)" (remove-method (symbol-function name) m)) (component-inline-methods component))) ;; clear methods, then add the new ones - (setf (component-inline-methods component) nil)) + (component-inline-methods component) nil) (defun* %define-component-inline-methods (ret rest) (dolist (name +asdf-methods+) @@ -3302,17 +3337,18 @@ located." (pathname-directory-pathname (system-source-file system-designator))) (defun* relativize-directory (directory) - (cond - ((stringp directory) - (list :relative directory)) - ((eq (car directory) :absolute) - (cons :relative (cdr directory))) - (t - directory))) + (let ((directory (normalize-pathname-directory-component directory))) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory)))) (defun* relativize-pathname-directory (pathspec) (let ((p (pathname pathspec))) - (make-pathname + (make-pathname* :directory (relativize-directory (pathname-directory p)) :defaults p))) @@ -3616,7 +3652,7 @@ and the order is by decreasing length of namestring of the source pathname.") (defun* output-translations () (car *output-translations*)) -(defun* (setf output-translations) (new-value) +(defun* set-output-translations (new-value) (setf *output-translations* (list (stable-sort (copy-list new-value) #'> @@ -3627,6 +3663,7 @@ and the order is by decreasing length of namestring of the source pathname.") (let ((directory (pathname-directory (car x)))) (if (listp directory) (length directory) 0)))))))) new-value) +(defsetf output-translations set-output-translations) ; works with gcl 2.6 (defun* output-translations-initialized-p () (and *output-translations* t)) @@ -3697,7 +3734,7 @@ directive.") ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location-component - (let ((p (make-pathname :directory '(:relative)))) + (let ((p (make-pathname* :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) ((eql :here) @@ -3880,7 +3917,7 @@ Please remove it from your ASDF configuration")) (inherit *default-output-translations*) collect) (process-output-translations (funcall x) :inherit inherit :collect collect)) -(defmethod process-output-translations ((pathname pathname) &key inherit collect) +(defmethod process-output-translations ((pathname #-gcl<2.7 pathname #+gcl<2.7 t) &key inherit collect) (cond ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) @@ -4171,7 +4208,7 @@ with a different configuration, so the configuration would be re-read then." (values)) (defparameter *wild-asd* - (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) + (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) (defun* filter-logical-directory-results (directory entries merger) (if (typep directory 'logical-pathname) @@ -4395,7 +4432,7 @@ with a different configuration, so the configuration would be re-read then." (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) -(defmethod process-source-registry ((pathname pathname) &key inherit register) +(defmethod process-source-registry ((pathname #-gcl<2.7 pathname #+gcl<2.7 t) &key inherit register) (cond ((directory-pathname-p pathname) (let ((*here-directory* (truenamize pathname))) @@ -5058,14 +5095,14 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver (defclass precompiled-system (system) ((fasl :initarg :fasl :reader %system-fasl))) -(defgeneric* system-fasl (system) - (:method ((system precompiled-system)) - (let* ((f (%system-fasl system)) - (p (etypecase f - ((or pathname string) f) - (function (funcall f)) - (cons (eval f))))) - (pathname p)))) +(defgeneric* system-fasl (system)) +(defmethod system-fasl ((system precompiled-system)) + (let* ((f (%system-fasl system)) + (p (etypecase f + ((or pathname string) f) + (function (funcall f)) + (cons (eval f))))) + (pathname p))) (defmethod input-files ((o load-op) (s precompiled-system)) (declare (ignorable o)) diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index d7450f956410c636077b22d93773fc38ee3875cf..77c9acbb4a363e8b6781d41e625e3cfb2487a607 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -56,6 +56,7 @@ (cons "asdf-src" path))) (bin-dir (&rest path) (append (or (pathname-directory root) (list :relative)) (cons "asdf-bin" path)))) + #-gcl<2.7 (setf (logical-pathname-translations "ASDFTEST") `((,(format nil "**;*.~a" bin-type) ,(make-pathname :directory (bin-dir :wild-inferiors) @@ -316,7 +317,7 @@ (format t "output translations: ~S~%" (asdf::output-translations)) #+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*))) - #-xcl ;;---*** pathnames are known to be massively broken on XCL + #-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6 (flet ((same (s1 s2 p1 p2) (unless (equal (namestring p1) (namestring p2)) (describe p1) (describe p2) @@ -331,7 +332,7 @@ #-gcl (x (asdf::resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*"))) - #-xcl ;;---*** pathnames are known to be massively broken on XCL + #-(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))) diff --git a/test/compile-asdf.lisp b/test/compile-asdf.lisp index 76f0f2bdc94a71ea182e22ac195dacd7f9773671..1d3817aa4114eeac7b0985f2342d20a9f2fbfc6d 100644 --- a/test/compile-asdf.lisp +++ b/test/compile-asdf.lisp @@ -1,17 +1,26 @@ -(in-package #:common-lisp-user) +(cl:in-package :common-lisp-user) -(load (make-pathname :name "script-support" :defaults *load-pathname*)) +(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)))) -(in-package #:asdf-test) +(load (make-pathname :name "script-support" :type "lisp" :defaults (load-pathname)) + #+gcl :print #+gcl t) -(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3) +(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) #-allegro (debug 3) +(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3) #+(or cmu scl) (c::brevity 2))) -(defun my-compile-file (&rest args) (apply 'compile-file args)) -#+ecl (trace my-compile-file) - (cond ((not (probe-file *asdf-lisp*)) (leave-lisp "Testsuite failed: unable to find ASDF source" 3)) @@ -20,27 +29,10 @@ (ignore-errors (load *asdf-fasl*))) (leave-lisp "Reusing previously-compiled ASDF" 0)) (t - #+clisp (load-asdf-lisp) + (load-asdf-lisp) (let ((tmp (make-pathname :name "asdf-tmp" :defaults *asdf-fasl*))) - (ensure-directories-exist *asdf-fasl*) (multiple-value-bind (result warnings-p errors-p) - ;; style warnings shouldn't abort the compilation [2010/02/03:rpg] - (handler-bind (#+sbcl (sb-c::simple-compiler-note #'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)))) - (my-compile-file *asdf-lisp* :output-file tmp :print t :verbose t)) + (compile-asdf tmp) (declare (ignore result)) (cond (errors-p diff --git a/test/run-tests.sh b/test/run-tests.sh index 1bbeff918ccf256c436bf9349e3e00a507976889..fc86f5fbcc03c588a551366a2b7ff176e0addffe 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -12,7 +12,7 @@ usage () { echo " - quit with exit status >0 if an unhandled error occurs" echo " you need to supply the .script in the second argument" echo " lisps include abcl, allegro, allegromodern, ccl (clozure)," - echo " clisp, cmucl, ecl, gclcvs, sbcl, and scl." + echo " clisp, cmucl, ecl, gcl, gclcvs, sbcl, scl and xcl." echo "OPTIONS:" echo " -d -- debug mode" echo " -u -h -- show this message." @@ -143,9 +143,14 @@ case "$lisp" in command="${ECL:-ecl}" flags="-norc -eval (ext::install-bytecodes-compiler)" eval="-eval" ;; + gcl) + export GCL_ANSI=t + command="${GCL:-gcl}" + flags="-batch" + eval="-eval" ;; gclcvs) export GCL_ANSI=t - command="${GCL:-gclcvs}" + command="${GCLCVS:-gclcvs}" flags="-batch" eval="-eval" ;; lispworks) diff --git a/test/script-support.lisp b/test/script-support.lisp index d83403bbcb4a9fcf3aec67da26c874be54ac110a..84b4356436b1494045cda2f7a68c93969a0be9d9 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -3,17 +3,17 @@ (:export #:*test-directory* #:*asdf-directory* #:load-asdf - #:register-directory #:asdf-load + #:register-directory #:asdf-load #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:compile-load-asdf #:load-asdf-system #:quit-on-error #:test-asdf #:native-namestring #:exit-lisp #:leave-lisp #:quietly)) -(in-package #:asdf-test) +(in-package :asdf-test) -(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3))) -(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3))) +(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3))) +(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3))) ;;(format t "Evaluating asdf/test/script-support~%") @@ -21,11 +21,13 @@ ;; We still want to work despite and host/device funkiness. (defparameter *test-directory* (make-pathname :name nil :type nil :version nil - :defaults (or *load-truename* *compile-file-truename*))) + :defaults (or #+gcl (truename system:*load-pathname*) + *load-truename* *compile-file-truename*))) (defparameter *asdf-directory* - (merge-pathnames - (make-pathname :directory '(:relative :back) :defaults *test-directory*) - *test-directory*)) + (truename + (merge-pathnames + (make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*) + *test-directory*))) (defparameter *asdf-lisp* (make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*)) (defparameter *asdf-fasl* @@ -49,26 +51,37 @@ #+scl :scl #+xcl :xcl)))) (merge-pathnames - (make-pathname :directory `(:relative "tmp" "fasls" ,impl) + (make-pathname :directory `(#-gcl :relative "tmp" "fasls" ,impl) :defaults *asdf-directory*) *asdf-lisp*)))) (defun load-old-asdf (tag) (let ((old-asdf (merge-pathnames - (make-pathname :directory `(:relative "tmp") + (make-pathname :directory `(#-gcl :relative "tmp") :name (format nil "asdf-~A" tag) :defaults *asdf-directory*) *asdf-lisp*))) (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (load old-asdf)))) +(defun configure-asdf () + (funcall (find-symbol (string :initialize-source-registry) :asdf) + `(:source-registry :ignore-inherited-configuration)) + (let ((registry (find-symbol (string :*central-registry*) :asdf))) + (set registry `(,*asdf-directory* ,*test-directory*)))) + (defun load-asdf () (load *asdf-fasl*) (use-package :asdf :asdf-test) - (import 'DBG :asdf) + ;;(import 'DBG :asdf) + (configure-asdf) (setf *package* (find-package :asdf-test))) +(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)) @@ -164,9 +177,31 @@ is bound, write a message and exit on an error. If (defun load-asdf-lisp () (load *asdf-lisp*)) -(defun compile-asdf () +#+(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 compile-asdf (&optional (output *asdf-fasl*)) (ensure-directories-exist *asdf-fasl*) - (compile-file *asdf-lisp* :output-file *asdf-fasl* :verbose t :print t)) + ;; style warnings shouldn't abort the compilation [2010/02/03:rpg] + (handler-bind (#+sbcl (sb-c::simple-compiler-note #'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*)) @@ -220,6 +255,12 @@ outputs a tag plus a list of variable and their values, returns the last value" (pushnew :DBG *features*) +#+gcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (DBG :script-support *package* *test-directory* *asdf-directory* *asdf-lisp* *asdf-fasl* + )) + + #| -#+DBG (DBG :cas o c just-done base-stamp stamp-lookup out-files in-files file-op null-op op-time op-stamp dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in done-stamp (stamp<= latest-in earliest-out) (operation-done-p o c)) +(DBG :cas o c just-done base-stamp stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)) |# diff --git a/test/test-builtin-source-file-type.script b/test/test-builtin-source-file-type.script index 481c67fcf35ed829a25737f2d16345b902b4ded7..505495b4431e79055962a1732ce5ddd0bdcc02f7 100644 --- a/test/test-builtin-source-file-type.script +++ b/test/test-builtin-source-file-type.script @@ -6,8 +6,7 @@ (quit-on-error (format t "~D~%" (asdf:asdf-version)) - (setf asdf:*central-registry* '(*default-pathname-defaults*)) - (asdf:load-system 'test-builtin-source-file-type-1 :verbose t) + (load-system 'test-builtin-source-file-type-1 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (assert-equal (mapcar #'pathname-type @@ -24,5 +23,4 @@ '("lisp" "cl")) (delete-package :test-package) (asdf:load-system 'test-builtin-source-file-type-4 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) - ) + (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index 7441e7276913191156878eb802655df096b768f2..0853adc75e660f9e469ed212c72afeee0163124c 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -2,6 +2,7 @@ (load "script-support.lisp") (load-asdf) +#-gcl<2.7 (setf (logical-pathname-translations "ASDF") #+(or allegro clisp) `(("**;*.*.*" ,(asdf::wilden *asdf-directory*))) @@ -16,14 +17,14 @@ (format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd")) (format t "~S~%" (truename "ASDF:test;test-force.asd")) - #-xcl + #-(or xcl gcl<2.7) (progn (format t "Test logical pathnames in central registry~%") (setf *central-registry* '(#p"ASDF:test;")) (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (load-system :test-logical-pathname :force t)) - #-xcl + #-(or xcl gcl<2.7) (progn (format t "Test logical pathnames in source-registry, non-recursive~%") (clear-system :test-logical-pathname) @@ -32,7 +33,7 @@ '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration)) (load-system :test-logical-pathname :force t)) - #-xcl + #-(or xcl gcl<2.7) (progn (format t "Test logical pathnames in source-registry, recursive~%") (clear-system :test-logical-pathname) diff --git a/test/test-nested-1.lisp b/test/test-nested-1.lisp index bcee43e8834ed542b89e211153a7c771cf5d8bd0..5bbe01d9132c96156a3fabd5872db24e6339d5de 100644 --- a/test/test-nested-1.lisp +++ b/test/test-nested-1.lisp @@ -1 +1 @@ -(in-package #:asdf-test) +(in-package :asdf-test) diff --git a/test/test-nested-components-1.asd b/test/test-nested-components-1.asd index cb27c953f54d063455126dced118ab3b6a309275..79a8df3e32003b79a8de6f0578c42e4741fd1f05 100644 --- a/test/test-nested-components-1.asd +++ b/test/test-nested-components-1.asd @@ -1,11 +1,11 @@ ;;; -*- Mode: common-lisp; Syntax: Common-Lisp; -*- -(in-package #:common-lisp-user) +(in-package :common-lisp-user) (defpackage #:test-nested-components.system (:use #:common-lisp #:asdf)) -(in-package #:test-nested-components.system) +(in-package :test-nested-components.system) (defsystem test-nested-components-a :components diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index 0e2c9ca38c12d3a0a05db606d0de18bb9d912a5a..8ec9180cf5a1ac48db538b32b183501f8741e84d 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -4,35 +4,27 @@ (load "script-support.lisp") (load-asdf) -;(trace asdf::find-component) -;(trace asdf:run-shell-command asdf:oos asdf:perform asdf:operate) -;#+allegro -;(trace excl.osi:command-output) (defvar *caught-error* nil) (quit-on-error - ;;(format t "trlc1 1~%") - (when (probe-file "try-reloading-dependency.asd") - (asdf:run-shell-command "rm -f ~A" - (namestring "try-reloading-dependency.asd"))) - (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (DBG "trlc1 1") + (asdf::delete-file-if-exists "try-reloading-dependency.asd") (setf asdf::*defined-systems* (asdf::make-defined-systems-table)) - ;;(format t "trlc1 2~%") + (DBG "trlc1 2") (handler-bind ((error (lambda (c) (format t "~&Caught error ~s" c) (setf *caught-error* t) (asdf:run-shell-command "cp try-reloading-dependency.hidden try-reloading-dependency.asd") - ;;(format t "trlc1 5~%") + (DBG "trlc1 5") (multiple-value-bind (name mode) (find-symbol (symbol-name 'retry) :asdf) + (DBG "trlc1 6" name mode) (assert (eq mode :external) nil "Mode of ~s was not external" name) - ;;(format t "trlc1 6~%") (let ((restart (find-restart name c))) - ;;(format t "trlc1 7~%") + (DBG "trlc1 7" restart) (assert restart) - (format t "~&restart: ~S~&" restart) (when restart (invoke-restart restart))))))) - ;;(format t "trlc1 3~%") + (DBG "trlc1 3") (asdf:oos 'asdf:load-op 'try-reloading-1)) - ;;(format t "trlc1 4~%") + (DBG "trlc1 4") (assert *caught-error*)) diff --git a/test/test-tmp.cl b/test/test-tmp.cl index 7e8dd8594e9a76189926b11d1fd2641ee0744aa9..c92fb1c8ee04e89a78ac9054e38acccbd34a02cb 100644 --- a/test/test-tmp.cl +++ b/test/test-tmp.cl @@ -1,6 +1,6 @@ ;; part of the test-module-pathnames test -(in-package #:test-package) +(in-package :test-package) (defparameter *test-tmp-cl* t) diff --git a/test/test-tmp.lsp b/test/test-tmp.lsp index 9792546537c2724feade035a2cfa35e9779d52ec..efa485c01c2f044c1ed0bde1c65778dbd53c0b14 100644 --- a/test/test-tmp.lsp +++ b/test/test-tmp.lsp @@ -1,6 +1,6 @@ ;; part of the test-module-pathnames test -(in-package #:test-package) +(in-package :test-package) (defparameter *test-tmp-cl* t) diff --git a/test/test-utilities.script b/test/test-utilities.script index 8cf58624d47600547d9f6f1077394e3bab7e5e0c..0def8b241138c1b54c1fd002147b1a6371a0080e 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -10,9 +10,9 @@ (assert (every #'directory-pathname-p (list - (make-pathname :name nil :type "" :directory '(:absolute "tmp")) - (make-pathname :name "" :directory '(:absolute "tmp")) - (make-pathname :type "" :directory '(:absolute "tmp")) + (make-pathname* :name nil :type "" :directory '(:absolute "tmp")) + (make-pathname* :name "" :directory '(:absolute "tmp")) + (make-pathname* :type "" :directory '(:absolute "tmp")) ;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here, ;; and some implementations will enforce it. ;; (make-pathname :type :unspecific :directory '(:absolute "tmp")) @@ -22,11 +22,11 @@ (assert (every (complement #'directory-pathname-p) (list - (make-pathname :name "foo" :type nil :directory '(:absolute "tmp")) - (make-pathname :name nil :type "bar" :directory '(:absolute "tmp"))))) + (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp")) + (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp"))))) ;; These are funky and non portable. Omit from tests. -;; (make-pathname :name "." :type nil :directory '(:absolute "tmp")) -;; (make-pathname :name "." :type "" :directory '(:absolute "tmp")) +;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp")) +;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp")) (assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory t)) '(:relative nil nil))) (assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory nil)) diff --git a/test/test1.preferences b/test/test1.preferences index d2d1bca648fe0f3d1ad6b20eda7a1379e5ff3eac..2d6bfa639efaed8a30c486a9411cbecd880f82a9 100644 --- a/test/test1.preferences +++ b/test/test1.preferences @@ -1,3 +1,3 @@ -(in-package #:asdf-test) +(in-package :asdf-test) (setf *test6* :yes) diff --git a/test/test8.script b/test/test8.script index 537de449298b343b6d559ac85339a4473f50fff4..caebad04704a72ee1472eb00fac8038930ef5a18 100644 --- a/test/test8.script +++ b/test/test8.script @@ -4,7 +4,7 @@ (load "script-support.lisp") (load-asdf) -(in-package #:asdf-test) +(in-package :asdf-test) (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) diff --git a/test/try-recompiling-1.lisp b/test/try-recompiling-1.lisp index e60bc4fabf3e02debc59e1adef694df741ef7144..723999c8f13fae43b619f6b7d6292725885e6820 100644 --- a/test/try-recompiling-1.lisp +++ b/test/try-recompiling-1.lisp @@ -1,4 +1,4 @@ -(in-package #:asdf-test) +(in-package :asdf-test) #+clisp (eval-when (:compile-toplevel) (fmakunbound 'try-recompiling-1)) diff --git a/test/wild-module.script b/test/wild-module.script index 2e8feb714faec97d86f2b2dfaa4e5fcaa0da9350..3f38ac4a734bc3d6a0f9d58dd4996113396edaec 100644 --- a/test/wild-module.script +++ b/test/wild-module.script @@ -2,6 +2,5 @@ (load "script-support.lisp") (load-asdf) (quit-on-error - (load "../wild-modules.lisp") - (setf *central-registry* '(*default-pathname-defaults*)) + (load (asdf:system-relative-pathname :asdf "wild-modules.lisp")) (load-system :wild-module))