Skip to content
Snippets Groups Projects
Commit 669baad6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.117: fix setf symbol frobbing on CLISP.

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