From ff9e3cb3f5ac725be40e7c957e10f56c8ebe6b97 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Wed, 2 Jan 2013 22:50:01 -0500 Subject: [PATCH] 2.26.49: Debug GCL 2.6 support, fix tests to work with its limitations. Remove debugging code from previous commit. --- asdf.asd | 2 +- asdf.lisp | 61 +++++++++-------------- test/script-support.lisp | 8 ++-- test/test-bundle.script | 2 +- test/test-compile-file-failure.script | 4 +- test/test-configuration.script | 7 +-- test/test-module-pathnames.script | 69 +++++++++++---------------- test/test-multiple.script | 11 ++--- test/test-system-pathnames.script | 54 +++++++-------------- test/test-try-recompiling-1.script | 6 +-- test/test-xach-update-bug.script | 21 ++++---- test/xach-foo-1/a.lisp | 4 +- test/xach-foo-2/a.lisp | 4 +- test/xach-foo-2/b.lisp | 2 +- 14 files changed, 97 insertions(+), 158 deletions(-) diff --git a/asdf.asd b/asdf.asd index 75811dd2..dcedcc7a 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.48" ;; to be automatically updated by bin/bump-revision + :version "2.26.49" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/asdf.lisp b/asdf.lisp index d92e9660..fddcd9a9 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.48: Another System Definition Facility. +;;; This is ASDF 2.26.49: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -79,7 +79,8 @@ (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*)) + #+gcl<2.7 (:shadowing-import-from :system :*load-pathname*) ;; GCL 2.6 sucks + #+gcl<2.7 (:shadow :type-of)) (in-package :asdf) @@ -119,7 +120,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.48") + (asdf-version "2.26.49") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -494,7 +495,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") (fs:create-directories-recursively (pathname path)))) #+gcl<2.7 -(progn +(progn ;; Doesn't support either logical-pathnames or output-translations. (deftype logical-pathname () nil) (defun wild-pathname-p (path) (declare (ignore path)) nil) (defun translate-logical-pathname (x) x) @@ -503,8 +504,9 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") (declare (ignore in-wildname wild-wildname)) nil) (defun translate-pathname (source from-wildname to-wildname &key) (declare (ignore from-wildname to-wildname)) source) + (defun type-of (x) (class-name (class-of x))) (defun %print-unreadable-object (object stream type identity thunk) - (format stream "<~@[~S ~] " (when type (class-name (class-of object)))) + (format stream "#<~@[~S ~]" (when type (type-of object))) (funcall thunk) (format stream "~@[ ~X~]>" (when identity (system:address object)))) (defmacro with-compilation-unit (options &body body) @@ -517,22 +519,6 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") ;;;; ------------------------------------------------------------------------- ;;;; 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) @@ -577,18 +563,19 @@ and NIL NAME, TYPE and VERSION components" (defun* normalize-pathname-directory-component (directory) "Given a pathname directory component, return an equivalent form that is a list" + #+gcl<2.7 (setf directory (substitute :back :parent directory)) (cond #-(or cmu sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) #+gcl<2.7 - ((and (consp directory) (stringp (first 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) + #+gcl<2.7 + ((consp directory) + `(:relative ,@directory)) (t (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) @@ -623,16 +610,15 @@ 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 +(defun* denormalize-pathname-directory-component (directory-component) + #-gcl<2.7 directory-component #+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))) + (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) + directory-component))) + (cond + ((and (consp d) (eq :relative (first d))) (rest d)) + ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) + (t d)))) (defun* make-pathname* (&key host device directory name type version defaults) (make-pathname @@ -2171,7 +2157,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (format stream "~{~S~^ ~}" (operation-original-initargs o))))) (defun* node-for (o c) - (cons (class-name (class-of o)) c)) + (cons (type-of o) c)) (defmethod operation-ancestor ((o operation)) (aif (operation-parent o) @@ -2436,7 +2422,6 @@ If true, an integer indexing the action in the list of actions planned.")) (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 @@ -2484,7 +2469,6 @@ If true, an integer indexing the action in the list of actions planned.")) (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)) (plan-record-dependency plan operation component) (let* ((aniip (needed-in-image-p operation component)) @@ -2492,7 +2476,6 @@ If true, an integer indexing the action in the list of actions planned.")) (status (plan-action-status plan operation component))) (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) ;; Already visited with sufficient need-in-image level: just return the stamp. - ;;(DBG :ad status eniip aniip) (return (action-stamp status))) (labels ((visit-action (niip) (visit-dependencies operation component @@ -2500,7 +2483,6 @@ If true, an integer indexing the action in the list of actions planned.")) (multiple-value-bind (stamp done-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! @@ -2745,7 +2727,8 @@ If true, an integer indexing the action in the list of actions planned.")) (defmethod perform ((o load-source-op) (c cl-source-file)) (declare (ignorable o)) (call-with-around-compile-hook - c #'(lambda () (load (component-pathname c) :external-format (component-external-format c))))) + c #'(lambda () (load (component-pathname c) + #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c))))) (defmethod perform ((o load-source-op) (c static-file)) (declare (ignorable o c)) diff --git a/test/script-support.lisp b/test/script-support.lisp index 84b43564..1a3fc447 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -51,14 +51,14 @@ #+scl :scl #+xcl :xcl)))) (merge-pathnames - (make-pathname :directory `(#-gcl :relative "tmp" "fasls" ,impl) + (make-pathname :directory `(#-gcl<2.7 :relative "tmp" "fasls" ,impl) :defaults *asdf-directory*) *asdf-lisp*)))) (defun load-old-asdf (tag) (let ((old-asdf (merge-pathnames - (make-pathname :directory `(#-gcl :relative "tmp") + (make-pathname :directory `(#-gcl<2.7 :relative "tmp") :name (format nil "asdf-~A" tag) :defaults *asdf-directory*) *asdf-lisp*))) @@ -74,7 +74,7 @@ (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))) @@ -262,5 +262,5 @@ outputs a tag plus a list of variable and their values, returns the last value" #| -(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)) +(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)) |# diff --git a/test/test-bundle.script b/test/test-bundle.script index 3637e541..9fe49617 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -14,7 +14,7 @@ (when (find-package :test-package) (delete-package :test-package)) (asdf:defsystem :test-bundle-1 :components ((:file "file1") (:file "file3"))) (asdf:defsystem :test-bundle-2 :depends-on (:test-bundle-1) :components ((:file "file2"))) - #-(or abcl (and ecl ecl-bytecmp)) + #-(or abcl (and ecl ecl-bytecmp) gcl) (let* ((op (make-instance 'asdf::fasl-op)) (bundle-1 (asdf:output-file op (find-system :test-bundle-1))) (bundle-2 (asdf:output-file op (find-system :test-bundle-2)))) diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script index 91a74415..85792e85 100644 --- a/test/test-compile-file-failure.script +++ b/test/test-compile-file-failure.script @@ -1,15 +1,15 @@ ;;; -*- Lisp -*- - (load "script-support.lisp") (load-asdf) (quit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) + #-gcl<2.7 (assert (handler-case (let ((asdf:*compile-file-failure-behaviour* :warn)) (asdf:load-system 'test-compile-file-failure :force t) t) (asdf:compile-error () nil))) + #-gcl<2.7 (assert (handler-case (let ((asdf:*compile-file-failure-behaviour* :error)) (asdf:load-system 'test-compile-file-failure :force t) diff --git a/test/test-configuration.script b/test/test-configuration.script index 90421e01..9654d35a 100644 --- a/test/test-configuration.script +++ b/test/test-configuration.script @@ -3,14 +3,11 @@ (load-asdf) (in-package :asdf) - (use-package :asdf-test) - -(defparameter *test-directory* - (merge-pathnames* (coerce-pathname "tmp/") *asdf-directory*)) +#+gcl<2.7 (defmacro with-standard-io-syntax (&body body) `(progn ,@body)) (defun under-test-directory (designator &optional (defaults *test-directory*)) - (namestring (merge-pathnames* (coerce-pathname designator) defaults))) + (namestring (subpathname defaults designator))) (defun create-conf-files (&optional (path *test-directory*)) (let ((v `(("conf.d/conf1.conf" diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index af5e93cb..8d23240e 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -3,25 +3,16 @@ (load-asdf) (quit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-module-pathnames) - (flet ((submodule (module name) - (find name (asdf:module-components module) - :key #'asdf:component-name :test #'equal)) - (pathname-foo (x) - (list (pathname-directory x) (pathname-name x) (pathname-type x)))) - (let* ((system (asdf:find-system "test-module-pathnames")) - (level1 (submodule system "sources/level1")) - (static (submodule level1 "level2/static.file")) - (test-tmp (submodule level1 "test-tmp.cl"))) - (assert (member (pathname-foo (asdf:component-relative-pathname test-tmp)) - '(((:relative) "test-tmp" "cl") - (nil "test-tmp" "cl")) :test 'equal) - () "Didn't get the name of test-tmp.cl right") - (assert (equal - (pathname-foo (asdf:component-relative-pathname static)) - '((:relative "level2") "static" "file")) - () "Didn't get the name of static.file right"))) + (flet ((pathname-foo (x) + (list (or (asdf::normalize-pathname-directory-component (pathname-directory x)) '(:relative)) + (pathname-name x) (pathname-type x)))) + (let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file"))) + (test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl")))) + (assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp)) + '((:relative) "test-tmp" "cl")) + (assert-equal (pathname-foo (asdf:component-relative-pathname static)) + '((:relative "level2") "static" "file")))) (assert (find-package :test-package) () "package test-package not found") (assert (find-symbol (symbol-name '*file-tmp*) :test-package) @@ -29,28 +20,26 @@ (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) () "symbol `*file-tmp*` has wrong value") -#| ; must be adapted to ABL - (assert (probe-file (merge-pathnames - (make-pathname - :name "file1" - :type (pathname-type (compile-file-pathname "x")) - :directory '(:relative "sources" "level1")))) - nil "compiled file not found") -|# + (assert (probe-file + (asdf::apply-output-translations + (asdf::merge-pathnames* + (asdf::make-pathname* + :name "file1" + :type (asdf::fasl-type) + :directory '(:relative "sources" "level1")) + *test-directory*))) + () "compiled file not found") - (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil - "symbol `*file-tmp2*` not found") + (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) + () "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) - nil "symbol `*file-tmp2*` has wrong value") + () "symbol `*file-tmp2*` has wrong value") -#| ; must be adapted to ABL - - (assert (probe-file (merge-pathnames - (make-pathname - :name "file2" - :type (pathname-type (compile-file-pathname "x")) - :directory '(:relative "sources" "level1" "level2")))) - nil "compiled file not found") -|# - -) + (assert (probe-file + (asdf::apply-output-translations + (asdf::merge-pathnames* + (asdf::make-pathname* + :name "file2" + :type (asdf::fasl-type) + :directory '(:relative "sources" "level1" "level2"))))) + nil "compiled file not found")) diff --git a/test/test-multiple.script b/test/test-multiple.script index 7a9ecc2c..2eeafa6a 100644 --- a/test/test-multiple.script +++ b/test/test-multiple.script @@ -6,14 +6,11 @@ (use-package :asdf-test) (quit-on-error - (let* ((asd (merge-pathnames* (coerce-pathname "test-multiple.asd") - *test-directory*)) - (tmp (merge-pathnames* (coerce-pathname "../tmp/") - *test-directory*)) - (asd2 (merge-pathnames* (coerce-pathname "test-multiple-too.asd") - tmp)) + (let* ((asd (subpathname *test-directory* "test-multiple.asd")) + (tmp (subpathname *test-directory* "../tmp/")) + (asd2 (subpathname tmp "test-multiple-too.asd")) (file4 (compile-file-pathname* "file4"))) - (setf *central-registry* `(*default-pathname-defaults* ,tmp)) + (setf *central-registry* `(,*test-directory* ,tmp)) (assert (= 0 (run-shell-command (format nil "/bin/ln -sf ~A ~A" (native-namestring asd) diff --git a/test/test-system-pathnames.script b/test/test-system-pathnames.script index 3422bd50..4d661814 100644 --- a/test/test-system-pathnames.script +++ b/test/test-system-pathnames.script @@ -3,25 +3,7 @@ (load-asdf) (quit-on-error - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-system-pathnames) - (flet ((submodule (module name) - (find name (asdf:module-components module) - :key #'asdf:component-name :test #'equal)) - (pathname-foo (x) - (list (pathname-directory x) (pathname-name x) (pathname-type x)))) - (let* ((system (asdf:find-system "test-module-pathnames")) - (level1 (submodule system "sources/level1")) - (static (submodule level1 "level2/static.file")) - (test-tmp (submodule level1 "test-tmp.cl"))) - (assert (member (pathname-foo (asdf:component-relative-pathname test-tmp)) - '(((:relative) "test-tmp" "cl") - (nil "test-tmp" "cl")) :test 'equal) - () "Didn't get the name of test-tmp.cl right") - (assert (equal - (pathname-foo (asdf:component-relative-pathname static)) - '((:relative "level2") "static" "file")) - () "Didn't get the name of static.file right"))) (assert (find-package :test-package) () "package test-package not found") (assert (find-symbol (symbol-name '*file-tmp*) :test-package) @@ -29,28 +11,26 @@ (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) () "symbol `*file-tmp*` has wrong value") -#| ; must be adapted to ABL - (assert (probe-file (merge-pathnames - (make-pathname - :name "file1" - :type (pathname-type (compile-file-pathname "x")) - :directory '(:relative "sources" "level1")))) - nil "compiled file not found") -|# + (assert (probe-file + (asdf::apply-output-translations + (asdf::merge-pathnames* + (asdf::make-pathname* + :name "file1" + :type (asdf::fasl-type) + :directory '(:relative "sources" "level1")) + *test-directory*))) + () "compiled file not found") (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) nil "symbol `*file-tmp2*` has wrong value") -#| ; must be adapted to ABL - - (assert (probe-file (merge-pathnames - (make-pathname - :name "file2" - :type (pathname-type (compile-file-pathname "x")) - :directory '(:relative "sources" "level1" "level2")))) - nil "compiled file not found") -|# - -) + (assert (probe-file + (asdf::apply-output-translations + (asdf::merge-pathnames* + (asdf::make-pathname* + :name "file2" + :type (asdf::fasl-type) + :directory '(:relative "sources" "level1" "level2"))))) + nil "compiled file not found")) diff --git a/test/test-try-recompiling-1.script b/test/test-try-recompiling-1.script index 79efdc2d..0b15456b 100644 --- a/test/test-try-recompiling-1.script +++ b/test/test-try-recompiling-1.script @@ -7,10 +7,7 @@ (defvar *caught-error* nil) (quit-on-error - (run-shell-command "rm -f ~A" - (namestring - (compile-file-pathname "try-recompiling-1"))) - (setf *central-registry* '(*default-pathname-defaults*)) + (asdf::delete-file-if-exists (compile-file-pathname "try-recompiling-1")) #-gcl (handler-bind ((error (lambda (c) (setf *caught-error* t) @@ -26,4 +23,5 @@ (when restart (invoke-restart restart))))))) (oos 'load-op 'try-recompiling-1)) + #-gcl (assert *caught-error*)) diff --git a/test/test-xach-update-bug.script b/test/test-xach-update-bug.script index d9bacb17..eb40cba7 100644 --- a/test/test-xach-update-bug.script +++ b/test/test-xach-update-bug.script @@ -2,17 +2,12 @@ (load "script-support.lisp") (load-asdf) +#+gcl (trace load compile-file asdf:perform asdf::perform-plan) (quit-on-error - (let ((*default-pathname-defaults* (make-pathname :name nil - :type nil - :defaults *load-truename*))) - (setf asdf:*central-registry* nil) - (push (merge-pathnames #p"xach-foo-1/") asdf:*central-registry*) - (asdf:load-system "foo") - (assert (symbol-value (find-symbol (string :loaded) :first-version))) - (push (merge-pathnames #p"xach-foo-2/") asdf:*central-registry*) - (asdf:load-system "foo") - (assert (symbol-value (find-symbol (string :loaded) :second-version))) - (assert (eql 42 (funcall (find-symbol (string :wtf) :second-version)))))) - - + (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))) + (setf asdf:*central-registry* (list (asdf::subpathname *test-directory* "xach-foo-2/"))) + (asdf:load-system "foo") + (assert (symbol-value (find-symbol (string :loaded) :second-version))) + (assert (eql 42 (funcall (find-symbol (string :wtf) :second-version))))) diff --git a/test/xach-foo-1/a.lisp b/test/xach-foo-1/a.lisp index 126cae5a..94c0bddc 100644 --- a/test/xach-foo-1/a.lisp +++ b/test/xach-foo-1/a.lisp @@ -1,9 +1,9 @@ ;;;; a.lisp -(defpackage #:first-version +(defpackage :first-version (:use #:cl) (:export #:loaded)) -(in-package #:first-version) +(in-package :first-version) (defparameter loaded t) diff --git a/test/xach-foo-2/a.lisp b/test/xach-foo-2/a.lisp index b517d778..d8dee0d7 100644 --- a/test/xach-foo-2/a.lisp +++ b/test/xach-foo-2/a.lisp @@ -1,10 +1,10 @@ ;;;; a.lisp -(defpackage #:second-version +(defpackage :second-version (:use #:cl) (:export #:loaded #:wtf)) -(in-package #:second-version) +(in-package :second-version) (defparameter loaded t) diff --git a/test/xach-foo-2/b.lisp b/test/xach-foo-2/b.lisp index dda671b5..0b82a074 100644 --- a/test/xach-foo-2/b.lisp +++ b/test/xach-foo-2/b.lisp @@ -1,6 +1,6 @@ ;;;; b.lisp -(in-package #:second-version) +(in-package :second-version) (defun wtf () 42) -- GitLab