From aa031e1831179afaeb8cb1934c79a2f004589b5e Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Tue, 29 Jan 2013 13:51:37 -0500 Subject: [PATCH] 2.26.166: Debug a define-package bug. ENSURE-EXPORTED was exporting the wrong symbol via EXPORT*. Also, backward compatibility with systems (i.e. cxml) that directly access the relative-pathname slot of a system the ASDF 1 way, instead of using system-relative-pathname. Eliminate the last use of merge-pathnames. --- asdf.asd | 2 +- bundle.lisp | 2 +- header.lisp | 2 +- package.lisp | 545 +++++++++++++++++++++------------------ system.lisp | 7 +- test/run-tests.sh | 4 - test/script-support.lisp | 84 +++--- upgrade.lisp | 2 +- utility.lisp | 47 ++-- version.lisp-expr | 2 +- 10 files changed, 377 insertions(+), 320 deletions(-) diff --git a/asdf.asd b/asdf.asd index 08ed65a62..c910bd787 100644 --- a/asdf.asd +++ b/asdf.asd @@ -66,7 +66,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.165" ;; to be automatically updated by make bump-version + :version "2.26.166" ;; to be automatically updated by make bump-version :depends-on () #+asdf3 :encoding #+asdf3 :utf-8 ;; For most purposes, asdf itself specially counts as a builtin system. diff --git a/bundle.lisp b/bundle.lisp index 55ff80d2c..08d1a3419 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -270,7 +270,7 @@ (move-here-path (if (and move-here (typep move-here '(or pathname string))) (pathname move-here) - (merge-pathnames "./asdf-output/"))) + (system-relative-pathname system "asdf-output/"))) (operation (apply #'operate operation-name system (remove-plist-keys '(:monolithic :type :move-here) args))) diff --git a/header.lisp b/header.lisp index a48e27663..c83a0194b 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.26.165: Another System Definition Facility. +;;; This is ASDF 2.26.166: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/package.lisp b/package.lisp index 1069e8dbf..8c8ecc7d4 100644 --- a/package.lisp +++ b/package.lisp @@ -120,16 +120,9 @@ or when loading the package is optional." (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *all-package-happiness* '()) (defvar *all-package-fishiness* (list t)) - (defvar *package-fishiness* '()) - (defun flush-fishy () - (when *package-fishiness* - (if (null (rest *package-fishiness*)) - (push (first *package-fishiness*) *all-package-happiness*) - (push (nreverse *package-fishiness*) *all-package-fishiness*)) - (setf *package-fishiness* nil))) (defun record-fishy (info) ;;(format t "~&FISHY: ~S~%" info) - (push info *package-fishiness*)) + (push info *all-package-fishiness*)) (defmacro when-package-fishiness (&body body) `(when *all-package-fishiness* ,@body)) (defmacro note-package-fishiness (&rest info) @@ -207,9 +200,9 @@ or when loading the package is optional." (and overwritten-symbol-status (symbol-shadowing-p overwritten-symbol package)))) (note-package-fishiness - :rehome-symbol name (package-name old-package) - (package-name package) old-status (and shadowing t) - overwritten-symbol-status overwritten-symbol-shadowing-p) + :rehome-symbol name + (when old-package (package-name old-package)) old-status (and shadowing t) + (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) (when old-package (if shadowing (shadowing-import shadowing old-package)) @@ -337,8 +330,211 @@ or when loading the package is optional." ;;; ensure-package, define-package - (eval-when (:load-toplevel :compile-toplevel :execute) + (defun ensure-shadowing-import (name to-package from-package shadowed imported) + (check-type name string) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (let ((import-me (find-symbol* name from-package))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (cond + ((gethash name shadowed) + (unless (eq import-me existing) + (error "Conflicting shadowings for ~A" name))) + (t + (setf (gethash name shadowed) t) + (setf (gethash name imported) t) + (unless (or (null status) + (and (member status '(:internal :external)) + (eq existing import-me) + (symbol-shadowing-p existing to-package))) + (note-package-fishiness + :shadowing-import name + (package-name from-package) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name to-package) status + (and status (or (home-package-p existing to-package) (symbol-package-name existing)))) + (shadowing-import import-me to-package))))))) + (defun ensure-import (name to-package from-package shadowed imported) + (check-type name string) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (let* ((import-me (find-symbol* name from-package))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (cond + ((gethash name imported) + (unless (eq import-me existing) + (error "Can't import ~S from both ~S and ~S" + name (package-name (symbol-package existing)) (package-name from-package)))) + ((gethash name shadowed) + (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) + (t + (setf (gethash name imported) t) + (unless (and status (eq import-me existing)) + (when status + (note-package-fishiness + :import name + (package-name from-package) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name to-package) status + (and status (or (home-package-p existing to-package) (symbol-package-name existing)))) + (unintern* existing to-package)) + (import import-me to-package))))))) + (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type from-package package) + (check-type mixp boolean) + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (multiple-value-bind (existing status) (find-symbol name to-package) + (let* ((sp (symbol-package symbol)) + (in (gethash name inherited)) + (xp (and status (symbol-package existing)))) + (when (null sp) + (note-package-fishiness + :import-uninterned name + (package-name from-package) (package-name to-package) mixp) + (import symbol from-package) + (setf sp (package-name from-package))) + (cond + ((gethash name shadowed)) + (in + (unless (equal sp (first in)) + (if mixp + (ensure-shadowing-import name to-package (second in) shadowed imported) + (error "Can't inherit ~S from ~S, it is inherited from ~S" + name (package-name sp) (package-name (first in)))))) + ((gethash name imported) + (unless (eq symbol existing) + (error "Can't inherit ~S from ~S, it is imported from ~S" + name (package-name sp) (package-name xp)))) + (t + (setf (gethash name inherited) (list sp from-package)) + (when (and status (not (eq sp xp))) + (let ((shadowing (symbol-shadowing-p existing to-package))) + (note-package-fishiness + :inherited name + (package-name from-package) + (or (home-package-p symbol from-package) (symbol-package-name symbol)) + (package-name to-package) + (or (home-package-p existing to-package) (symbol-package-name existing))) + (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported) + (unintern* existing to-package))))))))) + (defun ensure-mix (name symbol to-package from-package shadowed imported inherited) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (unless (gethash name shadowed) + (multiple-value-bind (existing status) (find-symbol name to-package) + (let* ((sp (symbol-package symbol)) + (im (gethash name imported)) + (in (gethash name inherited))) + (cond + ((or (null status) + (and status (eq symbol existing)) + (and in (eq sp (first in)))) + (ensure-inherited name symbol to-package from-package t shadowed imported inherited)) + (in + (remhash name inherited) + (ensure-shadowing-import name to-package (second in) shadowed imported)) + (im + (error "Symbol ~S import from ~S~:[~*~; actually ~:[~*uninterned~;from ~S~]~] conflicts with existing symbol in ~S~:[~*~; actually ~:[~*uninterned~;from ~S~]~]" + name (package-name from-package) + (home-package-p symbol from-package) (symbol-package-name symbol) + (package-name to-package) + (home-package-p existing to-package) (symbol-package-name existing))) + (t + (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) + (defun recycle-symbol (name recycle exported) + (check-type name string) + (check-type recycle list) + (check-type exported hash-table) + (when (gethash name exported) ;; don't bother recycling private symbols + (let (recycled foundp) + (dolist (r recycle (values recycled foundp)) + (multiple-value-bind (symbol status) (find-symbol name r) + (when (and status (home-package-p symbol r)) + (cond + (foundp + ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. + (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r))) + (t + (setf recycled symbol foundp r))))))))) + (defun symbol-recycled-p (sym recycle) + (check-type sym symbol) + (check-type recycle list) + (member (symbol-package sym) recycle)) + (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) + (check-type name string) + (check-type package package) + (check-type intern boolean) + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (unless (or (gethash name shadowed) + (gethash name imported) + (gethash name inherited)) + (multiple-value-bind (existing status) + (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) + (cond + ((and status (eq existing recycled) (eq previous package))) + (previous + (rehome-symbol recycled package)) + ((and status (eq package (symbol-package existing)))) + (t + (when status + (note-package-fishiness + :ensure-symbol name + (reify-package (symbol-package existing) package) + status intern) + (unintern existing)) + (when intern + (intern* name package)))))))) + (declaim (ftype function ensure-exported)) + (defun ensure-exported-to-user (name symbol to-package &optional recycle) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type recycle list) + (multiple-value-bind (existing status) (find-symbol name to-package) + (unless (and status (eq symbol existing)) + (let ((accessible + (or (null status) + (let ((shadowing (symbol-shadowing-p existing to-package)) + (recycled (symbol-recycled-p existing recycle))) + (unless (and shadowing (not recycled)) + (note-package-fishiness + :ensure-export name (symbol-package-name symbol) + (package-name to-package) + (or (home-package-p existing to-package) (symbol-package-name existing)) + status shadowing) + (if (or (eq status :inherited) shadowing) + (shadowing-import symbol to-package) + (unintern existing to-package)) + t))))) + (when (and accessible (eq status :external)) + (ensure-exported name symbol to-package recycle)))))) + (defun ensure-exported (name symbol from-package &optional recycle) + (dolist (to-package (package-used-by-list from-package)) + (ensure-exported-to-user name symbol to-package recycle)) + (import symbol from-package) + (export* name from-package)) + (defun ensure-export (name from-package &optional recycle) + (multiple-value-bind (symbol status) (find-symbol* name from-package) + (unless (eq status :external) + (ensure-exported name symbol from-package recycle)))) (defun ensure-package (name &key nicknames documentation use shadow shadowing-import-from @@ -346,239 +542,98 @@ or when loading the package is optional." recycle mix reexport unintern) #+(or gcl2.6 genera) (declare (ignore documentation)) - (macrolet ((when-fishy (&body body) `(when-package-fishiness ,@body)) - (fishy (&rest info) `(note-package-fishiness ,@info))) - (let* ((package-name (string name)) - (nicknames (mapcar #'string nicknames)) - (names (cons package-name nicknames)) - (previous (packages-from-names names)) - (discarded (cdr previous)) - (to-delete ()) - (package (or (first previous) (make-package package-name :nicknames nicknames))) - (recycle (packages-from-names recycle)) - (use (mapcar 'find-package* use)) - (mix (mapcar 'find-package* mix)) - (reexport (mapcar 'find-package* reexport)) - (shadow (mapcar 'string shadow)) - (export (mapcar 'string export)) - (intern (mapcar 'string intern)) - (unintern (mapcar 'string unintern)) - (shadowed (make-hash-table :test 'equal)) ; string to bool - (imported (make-hash-table :test 'equal)) ; string to bool - (exported (make-hash-table :test 'equal)) ; string to bool - ;; string to list home package and use package: - (inherited (make-hash-table :test 'equal))) - (when-fishy (record-fishy package-name)) - (labels - ((ensure-shadowing-import (name p) - (let ((import-me (find-symbol* name p))) - (multiple-value-bind (existing status) (find-symbol name package) - (cond - ((gethash name shadowed) - (unless (eq import-me existing) - (error "Conflicting shadowings for ~A" name))) - (t - (setf (gethash name shadowed) t) - (setf (gethash name imported) t) - (unless (or (null status) - (and (member status '(:internal :external)) - (eq existing import-me) - (symbol-shadowing-p existing package))) - (fishy :shadowing-import - name (package-name p) (symbol-package-name import-me) - (and status (symbol-package-name existing)) status)) - (shadowing-import import-me package)))))) - (ensure-import (sym p) - (let* ((name (string sym)) - (import-me (find-symbol* name p))) - (multiple-value-bind (existing status) (find-symbol name package) - (cond - ((gethash name imported) - (unless (eq import-me existing) - (error "Can't import ~S from both ~S and ~S" - name (package-name (symbol-package existing)) (package-name p)))) - ((gethash name shadowed) - (error "Can't both shadow ~S and import it from ~S" name (package-name p))) - (t - (setf (gethash name imported) t) - (unless (and status (eq import-me existing)) - (when status - (fishy :import name (package-name p) (symbol-package-name import-me) - (and status (symbol-package-name existing)) status) - (unintern* existing package)) - (import import-me package))))))) - (ensure-mix (name symbol p) - (unless (gethash name shadowed) - (multiple-value-bind (existing status) (find-symbol name package) - (let* ((sp (symbol-package symbol)) - (im (gethash name imported)) - (in (gethash name inherited))) - (cond - ((or (null status) - (and status (eq symbol existing)) - (and in (eq sp (first in)))) - (ensure-inherited name symbol p t)) - (in - (remhash name inherited) - (ensure-shadowing-import name (second in))) - (im - (error "Imported symbol ~S conflicts with inherited symbol ~S in ~S" - existing symbol (package-name package))) - (t - (ensure-inherited name symbol p t))))))) - (ensure-inherited (name symbol p mix) - (multiple-value-bind (existing status) (find-symbol name package) - (let* ((sp (symbol-package symbol)) - (in (gethash name inherited)) - (xp (and status (symbol-package existing)))) - (when (null sp) - (fishy :import-uninterned name (package-name p) mix) - (import symbol p) - (setf sp (package-name p))) - (cond - ((gethash name shadowed)) - (in - (unless (equal sp (first in)) - (if mix - (ensure-shadowing-import name (second in)) - (error "Can't inherit ~S from ~S, it is inherited from ~S" - name (package-name sp) (package-name (first in)))))) - ((gethash name imported) - (unless (eq symbol existing) - (error "Can't inherit ~S from ~S, it is imported from ~S" - name (package-name sp) (package-name xp)))) - (t - (setf (gethash name inherited) (list sp p)) - (when (and status (not (eq sp xp))) - (let ((shadowing (symbol-shadowing-p existing package))) - (fishy :inherited name (package-name p) (package-name sp) - (package-name xp)) - (if shadowing (ensure-shadowing-import name p) - (unintern* existing package))))))))) - (recycle-symbol (name) - (when (gethash name exported) ;; don't bother recycling private symbols - (let (recycled foundp) - (dolist (r recycle (values recycled foundp)) - (multiple-value-bind (symbol status) (find-symbol name r) - (when (and status (home-package-p symbol r)) - (cond - (foundp - ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. - (fishy :recycled-duplicate name (package-name foundp) (package-name r))) - (t - (setf recycled symbol foundp r))))))))) - (symbol-recycled-p (sym) - (member (symbol-package sym) recycle)) - (ensure-symbol (name &optional intern) - (unless (or (gethash name shadowed) - (gethash name imported) - (gethash name inherited)) - (multiple-value-bind (existing status) - (find-symbol name package) - (multiple-value-bind (recycled previous) (recycle-symbol name) - (cond - ((and status (eq existing recycled) (eq previous package))) - (previous - (rehome-symbol recycled package)) - ((and status (eq package (symbol-package existing)))) - (t - (when status - (fishy :ensure-symbol name - (reify-package (symbol-package existing) package) - status intern) - (unintern existing)) - (when intern - (intern* name package)))))))) - (ensure-export (name p) - (multiple-value-bind (symbol status) (find-symbol* name p) - (unless (eq status :external) - (ensure-exported name symbol p)))) - (ensure-exported (name sym p) - (dolist (u (package-used-by-list p)) - (ensure-exported-to-user name sym u)) - (export* sym p)) - (ensure-exported-to-user (name sym u) - (multiple-value-bind (usym ustat) (find-symbol name u) - (unless (and ustat (eq sym usym)) - (let ((accessible - (or (null ustat) - (let ((shadowing (symbol-shadowing-p usym u)) - (recycled (symbol-recycled-p usym))) - (unless (and shadowing (not recycled)) - (fishy :ensure-export name (symbol-package-name sym) - (package-name u) - (and ustat (symbol-package-name usym)) ustat shadowing) - (if (or (eq ustat :inherited) shadowing) - (shadowing-import sym u) - (unintern usym u)) - t))))) - (when (and accessible (eq ustat :external)) - (ensure-exported name sym u))))))) - #-(or gcl2.6 genera) - (when documentation (setf (documentation package t) documentation)) - (loop :for p :in (set-difference (package-use-list package) (append mix use)) - :do (fishy :use (package-names p)) (unuse-package p package)) - (loop :for p :in discarded - :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) - (package-names p)) - :do (fishy :nickname (package-names p)) - (cond (n (rename-package p (first n) (rest n))) - (t (rename-package-away p) - (push p to-delete)))) - (rename-package package package-name nicknames) - (dolist (name unintern) - (multiple-value-bind (existing status) (find-symbol name package) - (when status - (unless (eq status :inherited) - (fishy :unintern name (symbol-package-name existing) status) - (unintern* name package nil))))) - (dolist (name export) - (setf (gethash name exported) t)) - (dolist (p reexport) - (do-external-symbols (sym p) - (setf (gethash (string sym) exported) t))) - (do-external-symbols (sym package) - (let ((name (symbol-name sym))) - (unless (gethash name exported) - (fishy :over-exported name (symbol-package-name sym)) - (unexport sym package)))) - (dolist (name shadow) - (setf (gethash name shadowed) t) - (multiple-value-bind (existing status) (find-symbol name package) - (multiple-value-bind (recycled previous) (recycle-symbol name) - (let ((shadowing (and status (symbol-shadowing-p existing package)))) - (cond - ((eq previous package)) - (previous - (rehome-symbol recycled package)) - ((or (member status '(nil :inherited)) - (home-package-p existing package))) - (t - (let ((dummy (make-symbol name))) - (fishy :shadow-imported name (symbol-package-name existing) status shadowing) - (shadowing-import dummy package) - (import dummy package))))))) - (shadow name package)) - (loop :for (p . syms) :in shadowing-import-from - :for pp = (find-package* p) :do - (dolist (sym syms) (ensure-shadowing-import (string sym) pp))) - (dolist (p mix) - (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym p))) - (loop :for (p . syms) :in import-from :do - (dolist (sym syms) (ensure-import sym p))) - (dolist (p (append use mix)) - (do-external-symbols (sym p) (ensure-inherited (string sym) sym p nil)) - (use-package p package)) - (loop :for name :being :the :hash-keys :of exported :do - (ensure-symbol name t) - (ensure-export name package)) - (dolist (name intern) - (ensure-symbol name t)) - (do-symbols (sym package) - (ensure-symbol (symbol-name sym))) - (map () 'delete-package* to-delete) - (flush-fishy) - package))))) + (let* ((package-name (string name)) + (nicknames (mapcar #'string nicknames)) + (names (cons package-name nicknames)) + (previous (packages-from-names names)) + (discarded (cdr previous)) + (to-delete ()) + (package (or (first previous) (make-package package-name :nicknames nicknames))) + (recycle (packages-from-names recycle)) + (use (mapcar 'find-package* use)) + (mix (mapcar 'find-package* mix)) + (reexport (mapcar 'find-package* reexport)) + (shadow (mapcar 'string shadow)) + (export (mapcar 'string export)) + (intern (mapcar 'string intern)) + (unintern (mapcar 'string unintern)) + (shadowed (make-hash-table :test 'equal)) ; string to bool + (imported (make-hash-table :test 'equal)) ; string to bool + (exported (make-hash-table :test 'equal)) ; string to bool + ;; string to list home package and use package: + (inherited (make-hash-table :test 'equal))) + (when-package-fishiness (record-fishy package-name)) + #-(or gcl2.6 genera) + (when documentation (setf (documentation package t) documentation)) + (loop :for p :in (set-difference (package-use-list package) (append mix use)) + :do (note-package-fishiness :over-use name (package-names p)) + (unuse-package p package)) + (loop :for p :in discarded + :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) + (package-names p)) + :do (note-package-fishiness :nickname name (package-names p)) + (cond (n (rename-package p (first n) (rest n))) + (t (rename-package-away p) + (push p to-delete)))) + (rename-package package package-name nicknames) + (dolist (name unintern) + (multiple-value-bind (existing status) (find-symbol name package) + (when status + (unless (eq status :inherited) + (note-package-fishiness + :unintern (package-name package) name (symbol-package-name existing) status) + (unintern* name package nil))))) + (dolist (name export) + (setf (gethash name exported) t)) + (dolist (p reexport) + (do-external-symbols (sym p) + (setf (gethash (string sym) exported) t))) + (do-external-symbols (sym package) + (let ((name (symbol-name sym))) + (unless (gethash name exported) + (note-package-fishiness + :over-export (package-name package) name + (or (home-package-p sym package) (symbol-package-name sym))) + (unexport sym package)))) + (dolist (name shadow) + (setf (gethash name shadowed) t) + (multiple-value-bind (existing status) (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) + (let ((shadowing (and status (symbol-shadowing-p existing package)))) + (cond + ((eq previous package)) + (previous + (rehome-symbol recycled package)) + ((or (member status '(nil :inherited)) + (home-package-p existing package))) + (t + (let ((dummy (make-symbol name))) + (note-package-fishiness + :shadow-imported (package-name package) name + (symbol-package-name existing) status shadowing) + (shadowing-import dummy package) + (import dummy package))))))) + (shadow name package)) + (loop :for (p . syms) :in shadowing-import-from + :for pp = (find-package* p) :do + (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) + (dolist (p mix) + (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym package p shadowed imported inherited))) + (loop :for (p . syms) :in import-from + :for pp = (find-package p) :do + (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) + (dolist (p (append use mix)) + (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) + (use-package p package)) + (loop :for name :being :the :hash-keys :of exported :do + (ensure-symbol name package t recycle shadowed imported inherited exported) + (ensure-export name package recycle)) + (dolist (name intern) + (ensure-symbol name package t recycle shadowed imported inherited exported)) + (do-symbols (sym package) + (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) + (map () 'delete-package* to-delete) + package))) (eval-when (:load-toplevel :compile-toplevel :execute) (defun parse-define-package-form (package clauses) diff --git a/system.lisp b/system.lisp index 713f8e8fa..91daaa0c2 100644 --- a/system.lisp +++ b/system.lisp @@ -72,8 +72,11 @@ in which the system specification (.asd file) is located." (subpathname (system-source-directory system) name :type type)) (defmethod component-pathname ((system system)) - (or (call-next-method) - (system-source-directory system))) + (let ((pathname (or (call-next-method) (system-source-directory system)))) + (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age + (slot-value system 'relative-pathname)) ;; systems that directly access this slot. + (setf (slot-value system 'relative-pathname) pathname)) + pathname)) (defmethod component-relative-pathname ((system system)) (parse-unix-namestring diff --git a/test/run-tests.sh b/test/run-tests.sh index 40d56661d..4adc93094 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -225,10 +225,6 @@ fi ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)" -## Make sure testing remains within the confines of this filesystem tree -export CL_SOURCE_REGISTRY="${ASDFDIR}" -export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)" - cmd="$command $flags" debugp= if [ -z "${DEBUG_ASDF_TEST}" ] ; then diff --git a/test/script-support.lisp b/test/script-support.lisp index 24208297f..a70586ede 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -430,30 +430,6 @@ is bound, write a message and exit on an error. If (cons (format nil "~{~D~^.~}" ver)) (null "1.0")))))) -(defun test-upgrade (old-method new-method tag) ;; called by run-test - (with-test () - (verbose t nil) - (when old-method - (cond - ((string-equal tag "REQUIRE") - (format t "Requiring some previous ASDF ~A~%" tag) - (ignore-errors (funcall 'require "asdf")) - (if (member "ASDF" *modules* :test 'equalp) - (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version)) - (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0))) - (t - (format t "Loading old asdf ~A via ~A~%" tag old-method) - (funcall old-method tag)))) - (when (asym :*asdf-verbose* nil nil) (setf (asymval :*asdf-verbose*) t)) - (when (asym :*verbose-out* nil nil) (setf (asymval :*verbose-out*) *standard-output*)) - (format t "Now loading new asdf via method ~A~%" new-method) - (funcall new-method) - (format t "Testing it~%") - (register-directory *test-directory*) - (load-test-system :test-module-depend) - (assert (eval (intern (symbol-name '#:*file1*) :test-package))) - (assert (eval (intern (symbol-name '#:*file3*) :test-package))))) - (defun output-location (&rest sublocation) (list* *asdf-directory* "build/fasls" :implementation sublocation)) (defun resolve-output (&rest sublocation) @@ -477,27 +453,30 @@ is bound, write a message and exit on an error. If (clean-asdf-system)) (defun configure-asdf () - (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))) - (untrace) + (when (asym :getenvp nil nil) + (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 - ((,*asdf-directory* :**/ :*.*.*) ,(output-location "asdf")) - (t ,(output-location "root")) - :ignore-inherited-configuration)) + (when (asym :initialize-source-registry nil nil) + (acall :initialize-source-registry + `(:source-registry :ignore-inherited-configuration))) + (when (asym :initialize-output-translations nil nil) + (acall :initialize-output-translations + `(:output-translations + ((,*asdf-directory*) ,(output-location "asdf")) + (t ,(output-location "root")) + :ignore-inherited-configuration))) (set (asym :*central-registry*) `(,*test-directory*)) (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t)) (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) - (let ((x (acall :system-source-directory :hello-world-example))) - (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!) - (unless (equal *test-directory* x) - (format t "Interestingly, while *test-directory* has components~% ~S~%~ + (when (asym :system-source-directory nil nil) + (let ((x (acall :system-source-directory :test-module-depend))) + (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!) + (unless (equal *test-directory* x) + (format t "Interestingly, while *test-directory* has components~% ~S~%~ ASDF finds the ASDs in~% ~S~%Using the latter.~%" - (pathname-components *test-directory*) - (pathname-components x))) - (setf *test-directory* x)) + (pathname-components *test-directory*) + (pathname-components x))) + (setf *test-directory* x))) t) (defun load-asdf (&optional tag) @@ -537,6 +516,31 @@ is bound, write a message and exit on an error. If (acall :load-system sys)) (format t "~&Done!~%")) +(defun test-upgrade (old-method new-method tag) ;; called by run-test + (with-test () + (verbose t nil) + (when old-method + (cond + ((string-equal tag "REQUIRE") + (format t "Requiring some previous ASDF ~A~%" tag) + (ignore-errors (funcall 'require "asdf")) + (if (member "ASDF" *modules* :test 'equalp) + (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version)) + (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0))) + (t + (format t "Loading old asdf ~A via ~A~%" tag old-method) + (funcall old-method tag)))) + (configure-asdf) + (when (asym :*asdf-verbose* nil nil) (setf (asymval :*asdf-verbose*) t)) + (when (asym :*verbose-out* nil nil) (setf (asymval :*verbose-out*) *standard-output*)) + (format t "Now loading new asdf via method ~A~%" new-method) + (funcall new-method) + (format t "Testing it~%") + (register-directory *test-directory*) + (load-test-system :test-module-depend) + (assert (eval (intern (symbol-name '#:*file1*) :test-package))) + (assert (eval (intern (symbol-name '#:*file3*) :test-package))))) + ;; These are shorthands for interactive debugging of test scripts: (!a common-lisp-user::debug-asdf debug-asdf diff --git a/upgrade.lisp b/upgrade.lisp index ae86a8984..26fbf7e1e 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "2.26.165") + (asdf-version "2.26.166") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) diff --git a/utility.lisp b/utility.lisp index ce3fc62f5..12470858e 100644 --- a/utility.lisp +++ b/utility.lisp @@ -52,30 +52,29 @@ #-gcl2.6 (fmakunbound function-spec)) (t (error "bad function spec ~S" function-spec)))) (defun undefine-functions (function-spec-list) - (map () 'undefine-function function-spec-list))) - -(macrolet - ((defdef (def* def) - `(defmacro ,def* (name formals &rest rest) - (destructuring-bind (name &key (supersede t)) - (if (or (atom name) (eq (car name) 'setf)) - (list name :supersede nil) - name) - (declare (ignorable supersede)) - `(progn - ;; undefining the previous function is the portable way - ;; of overriding any incompatible previous gf, except on CLISP. - ;; We usually try to do it only for the functions that need it, - ;; which happens in asdf/upgrade - however, for ECL, we need this hammer, - ;; (which causes issues in clisp) - ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX - `((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)))) - (,',def ,name ,formals ,@rest)))))) - (defdef defgeneric* defgeneric) - (defdef defun* defun)) + (map () 'undefine-function function-spec-list)) + (macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + (destructuring-bind (name &key (supersede t)) + (if (or (atom name) (eq (car name) 'setf)) + (list name :supersede nil) + name) + (declare (ignorable supersede)) + `(progn + ;; undefining the previous function is the portable way + ;; of overriding any incompatible previous gf, except on CLISP. + ;; We usually try to do it only for the functions that need it, + ;; which happens in asdf/upgrade - however, for ECL, we need this hammer, + ;; (which causes issues in clisp) + ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX + `((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)))) + (,',def ,name ,formals ,@rest)))))) + (defdef defgeneric* defgeneric) + (defdef defun* defun))) ;;; Magic debugging help. See contrib/debug.lisp diff --git a/version.lisp-expr b/version.lisp-expr index d1c20033f..0211e0c14 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.165" +"2.26.166" -- GitLab