Commit 669baad6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.117: fix setf symbol frobbing on CLISP.

Also remove some forgotten debugging statement,
clean the asd somewhat.
parent 5f6aabab
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.116" ;; to be automatically updated by bin/bump-revision
:version "2.26.117" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......@@ -66,6 +66,7 @@
(:file "interface")
(:file "footer" :depends-on ("interface"))))
#+asdf2.27
(defsystem :asdf/header
:components
((:static-file "header.lisp")))
......@@ -284,8 +284,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(check-type found (or null pathname system))
(values foundp found-system pathname previous previous-time)))
(asdf-debug)
(defmethod find-system ((name string) &optional (error-p t))
(with-system-definitions ()
(loop
......
......@@ -68,6 +68,7 @@
(when *load-verbose*
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
;;; Local Variables:
;;; mode: lisp
;;; End:
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.116: Another System Definition Facility.
;;; This is ASDF 2.26.117: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -112,6 +112,24 @@ or when loading the package is optional."
(if package (intern* symbol-name package)
(make-symbol* symbol-name)))))))
(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*))
(defmacro when-package-fishiness (&body body)
`(when *all-package-fishiness* ,@body))
(defmacro note-package-fishiness (&rest info)
`(when-package-fishiness (record-fishy (list ,@info)))))
(eval-when (:load-toplevel :compile-toplevel :execute)
#+(or clisp clozure)
(defun get-setf-function-symbol (symbol)
......@@ -133,7 +151,9 @@ or when loading the package is optional."
((eq kind :setf-function)
(setf (get symbol 'system::setf-function) new-setf-symbol))
((eq kind :setf-expander)
(setf (get symbol 'system::setf-expander) new-setf-symbol)))
(setf (get symbol 'system::setf-expander) new-setf-symbol))
(t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
kind symbol new-setf-symbol)))
#+clozure
(progn
(gethash symbol ccl::%setf-function-names%) new-setf-symbol
......@@ -181,6 +201,10 @@ or when loading the package is optional."
(let ((overwritten-symbol-shadowing-p
(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)
(when old-package
(if shadowing
(shadowing-import shadowing old-package))
......@@ -201,8 +225,15 @@ or when loading the package is optional."
(when kind
(let* ((setf-function (fdefinition setf-symbol))
(new-setf-symbol (create-setf-function-symbol symbol)))
(note-package-fishiness
:setf-function
name (package-name package)
(symbol-name setf-symbol) (symbol-package-name setf-symbol)
(symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
(when (symbol-package setf-symbol)
(unintern setf-symbol (symbol-package setf-symbol)))
(setf (fdefinition new-setf-symbol) setf-function)
(set-setf-function-symbol symbol new-setf-symbol kind))))
(set-setf-function-symbol new-setf-symbol symbol kind))))
#+(or clisp clozure)
(multiple-value-bind (overwritten-setf foundp)
(get-setf-function-symbol overwritten-symbol)
......@@ -299,34 +330,21 @@ or when loading the package is optional."
;;; ensure-package, define-package
(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)
(push info *package-fishiness*))
(defun ensure-package (name &key
nicknames documentation use
shadow shadowing-import-from
import-from export intern
recycle mix reexport
unintern)
(macrolet ((when-fishy (&body body)
`(when *all-package-fishiness* ,@body))
(fishy (&rest info)
`(when-fishy (record-fishy (list ,@info)))))
(let* ((name (string name))
(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 name nicknames))
(names (cons package-name nicknames))
(previous (packages-from-names names))
(discarded (cdr previous))
(to-delete ())
(package (or (first previous) (make-package name :nicknames nicknames)))
(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))
......@@ -340,7 +358,7 @@ or when loading the package is optional."
(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 name))
(when-fishy (record-fishy package-name))
(labels
((ensure-shadowing-import (name p)
(let ((import-me (find-symbol* name p)))
......@@ -375,9 +393,9 @@ or when loading the package is optional."
(setf (gethash name imported) t)
(unless (and status (eq import-me existing))
(when status
(unintern* existing package)
(fishy :import name (package-name p) (symbol-package-name import-me)
(and status (symbol-package-name existing)) status))
(and status (symbol-package-name existing)) status)
(unintern* existing package))
(import import-me package)))))))
(ensure-mix (name symbol p)
(unless (gethash name shadowed)
......@@ -424,16 +442,17 @@ or when loading the package is optional."
(if shadowing (ensure-shadowing-import name p)
(unintern* existing package)))))))))
(recycle-symbol (name)
(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))))))))
(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)
......@@ -450,10 +469,10 @@ or when loading the package is optional."
((and status (eq package (symbol-package existing))))
(t
(when status
(unintern existing)
(fishy :ensure-symbol name
(reify-package (symbol-package existing) package)
status intern))
status intern)
(unintern existing))
(when intern
(intern* name package))))))))
(ensure-export (name p)
......@@ -483,7 +502,7 @@ or when loading the package is optional."
(ensure-exported name sym u)))))))
#-gcl (setf (documentation package t) documentation) #+gcl documentation
(loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (unuse-package p package) (fishy :use (package-names p)))
: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))
......@@ -491,13 +510,13 @@ or when loading the package is optional."
(cond (n (rename-package p (first n) (rest n)))
(t (rename-package-away p)
(push p to-delete))))
(rename-package package name nicknames)
(rename-package package package-name nicknames)
(dolist (name unintern)
(multiple-value-bind (existing status) (find-symbol name package)
(when status
(unless (eq status :inherited)
(unintern* name package nil))
(fishy :unintern name (symbol-package-name existing) status))))
(fishy :unintern name (symbol-package-name existing) status)
(unintern* name package nil)))))
(dolist (name export)
(setf (gethash name exported) t))
(dolist (p reexport)
......@@ -516,8 +535,6 @@ or when loading the package is optional."
(cond
((eq previous package))
(previous
(fishy :shadow-recycled name (package-name previous)
(and status (symbol-package-name existing)) status shadowing)
(rehome-symbol recycled package))
((or (member status '(nil :inherited))
(home-package-p existing package)))
......
......@@ -201,9 +201,9 @@ export CL_SOURCE_REGISTRY="${ASDFDIR}"
export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)"
command="$command $flags"
cmd="$command $flags"
if [ -z "${DEBUG_ASDF_TEST}" ] ; then
command="$command $nodebug"
cmd="$cmd $nodebug"
fi
......@@ -282,12 +282,16 @@ run_upgrade_tests () {
if valid_upgrade_test_p $lisp $tag $method ; then
echo "Testing ASDF upgrade from ${tag} using method $method"
extract_tagged_asdf $tag
$command $eval \
$cmd $eval \
"'(#.(load\"$su\")#.(in-package :asdf-test)#.(test-upgrade $method \"$tag\"))" ||
{ echo "upgrade FAILED for $lisp from $tag using method $method" ;
echo "you can retry just that test with:" ;
echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ADSF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ;
exit 1 ;}
echo "or more interactively (and maybe with rlwrap or in emacs), start with:"
echo "$command"
echo "then copy/paste:"
echo "(load\"$su\") (da) (test-upgrade $method \"$tag\")"
exit 1 ;}
fi ; done ; done 2>&1 | tee build/results/${lisp}-upgrade.text
}
run_tests () {
......@@ -296,7 +300,7 @@ run_tests () {
mkdir -p ../build/results
echo failure > ../build/results/status
thedate=`date "+%Y-%m-%d"`
do_tests "$command" "$eval" 2>&1 | \
do_tests "$cmd" "$eval" 2>&1 | \
tee "../build/results/${lisp}.text" "../build/results/${lisp}-${thedate}.save"
read a < ../build/results/status
clean_up
......@@ -317,10 +321,10 @@ test_clean_load () {
esac
nop=build/results/${lisp}-nop.text
load=build/results/${lisp}-load.text
${command} ${eval} \
${cmd} ${eval} \
'(or #.(setf *load-verbose* nil) #.(load "test/script-support.lisp") #.(asdf-test::exit-lisp 0))' \
> $nop 2>&1
${command} ${eval} \
${cmd} ${eval} \
'(or #.(setf *load-verbose* nil) #.(load "build/asdf.lisp") #.(asdf/image:quit 0))' \
> $load 2>&1
if diff $nop $load ; then
......@@ -330,7 +334,7 @@ test_clean_load () {
fi
}
if [ -z "$command" ] ; then
if [ -z "$cmd" ] ; then
echo "Error: cannot find or do not know how to run Lisp named $lisp"
elif [ -n "$clean_load" ] ; then
test_clean_load
......
......@@ -45,7 +45,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.116")
(asdf-version "2.26.117")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......
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