Commit aa031e18 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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.
parent 185f4c69
......@@ -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.
......
......@@ -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)))
......
;;; -*- 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>.
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment