Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
669baad6
Commit
669baad6
authored
Jan 18, 2013
by
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
Changes
8
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
669baad6
...
...
@@ -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.11
6
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.11
7
"
;; 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"
)))
find-system.lisp
View file @
669baad6
...
...
@@ -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
...
...
footer.lisp
View file @
669baad6
...
...
@@ -68,6 +68,7 @@
(
when
*load-verbose*
(
asdf-message
";; ASDF, version ~a~%"
(
asdf-version
)))
;;; Local Variables:
;;; mode: lisp
;;; End:
header.lisp
View file @
669baad6
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.11
6
: Another System Definition Facility.
;;; This is ASDF 2.26.11
7
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
package.lisp
View file @
669baad6
...
...
@@ -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
)))
...
...
test/run-tests.sh
View file @
669baad6
...
...
@@ -201,9 +201,9 @@ export CL_SOURCE_REGISTRY="${ASDFDIR}"
export
ASDF_OUTPUT_TRANSLATIONS
=
"(:output-translations (
\"
${
ASDFDIR
}
\"
(
\"
${
ASDFDIR
}
/build/fasls
\"
:implementation)) :ignore-inherited-configuration)"
c
omman
d
=
"
$command
$flags
"
c
m
d
=
"
$command
$flags
"
if
[
-z
"
${
DEBUG_ASDF_TEST
}
"
]
;
then
c
ommand
=
"
$comman
d
$nodebug
"
c
md
=
"
$cm
d
$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
$c
omman
d
$eval
\
$c
m
d
$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
"
$c
omman
d
"
"
$eval
"
2>&1 |
\
do_tests
"
$c
m
d
"
"
$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
${
c
omman
d
}
${
eval
}
\
${
c
m
d
}
${
eval
}
\
'(or #.(setf *load-verbose* nil) #.(load "test/script-support.lisp") #.(asdf-test::exit-lisp 0))'
\
>
$nop
2>&1
${
c
omman
d
}
${
eval
}
\
${
c
m
d
}
${
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
"
$c
omman
d
"
]
;
then
if
[
-z
"
$c
m
d
"
]
;
then
echo
"Error: cannot find or do not know how to run Lisp named
$lisp
"
elif
[
-n
"
$clean_load
"
]
;
then
test_clean_load
...
...
upgrade.lisp
View file @
669baad6
...
...
@@ -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.11
6
"
)
(
asdf-version
"2.26.11
7
"
)
(
existing-asdf
(
find-class
(
find-symbol*
:component
:asdf
nil
)
nil
))
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
)))
...
...
version.lisp-expr
View file @
669baad6
"2.26.11
6
"
"2.26.11
7
"
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment