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 @@
: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)))
......
"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