Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
abcl
abcl
Commits
ea130a4a
Commit
ea130a4a
authored
Mar 10, 2013
by
rschlatte@1c010e3e-69d0-11dd-93a8-456734b0d56f
Browse files
Make add-package-local-nicknames errors continuable
- partly fixes #307
parent
00fd6662
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/org/armedbear/lisp/Package.java
View file @
ea130a4a
...
...
@@ -780,16 +780,6 @@ public final class Package extends LispObject implements java.io.Serializable
public
LispObject
addLocalPackageNickname
(
String
name
,
Package
pack
)
{
if
(
name
.
equals
(
"CL"
)
||
name
.
equals
(
"COMMON-LISP"
)
||
name
.
equals
(
"KEYWORD"
))
{
return
error
(
new
LispError
(
"Trying to define a local nickname for "
+
name
));
}
if
(
name
.
equals
(
this
.
name
)
||
(
nicknames
!=
null
&&
nicknames
.
contains
(
name
)))
{
return
error
(
new
LispError
(
"Trying to override package name or nickname with a local nickname "
+
name
));
}
if
(
localNicknames
==
null
)
{
localNicknames
=
new
ConcurrentHashMap
<
String
,
Package
>();
}
...
...
src/org/armedbear/lisp/PackageFunctions.java
View file @
ea130a4a
...
...
@@ -285,7 +285,7 @@ public final class PackageFunctions
// ### add-package-local-nickname
// add-package-local-nickname local-nickname package &optional package-designator => package
private
static
final
Primitive
ADD_PACKAGE_LOCAL_NICKNAME
=
new
Primitive
(
"add-package-local-nickname"
,
PACKAGE_
EXT
,
tru
e
,
new
Primitive
(
"
%
add-package-local-nickname"
,
PACKAGE_
SYS
,
fals
e
,
"local-nickname package &optional package-designator"
)
{
@Override
...
...
src/org/armedbear/lisp/Symbol.java
View file @
ea130a4a
...
...
@@ -2968,6 +2968,8 @@ public class Symbol extends LispObject implements java.io.Serializable
PACKAGE_EXT
.
addExternalSymbol
(
"URL-PATHNAME"
);
public
static
final
Symbol
WEAK_REFERENCE
=
PACKAGE_EXT
.
addExternalSymbol
(
"WEAK-REFERENCE"
);
public
static
final
Symbol
ADD_PACKAGE_LOCAL_NICKNAME
=
PACKAGE_EXT
.
addExternalSymbol
(
"ADD-PACKAGE-LOCAL-NICKNAME"
);
// MOP.
public
static
final
Symbol
CLASS_LAYOUT
=
...
...
src/org/armedbear/lisp/package.lisp
View file @
ea130a4a
...
...
@@ -96,3 +96,24 @@
(
defun
delete-package
(
package
)
(
with-simple-restart
(
continue
"Ignore missing package."
)
(
sys::%delete-package
package
)))
(
defun
add-package-local-nickname
(
local-nickname
actual-package
&optional
(
package-designator
*package*
))
(
let*
((
local-nickname
(
string
local-nickname
))
(
package-designator
(
or
(
find-package
package-designator
)
(
error
"Package ~A not found"
package-designator
)))
(
actual-package
(
or
(
find-package
actual-package
)
(
error
"Package ~A not found"
actual-package
))))
(
when
(
member
local-nickname
'
(
"CL"
"COMMON-LISP"
"KEYWORD"
)
:test
#'
string=
)
(
cerror
"Continue anyway"
"Trying to define a local nickname called ~A"
local-nickname
))
(
when
(
member
local-nickname
(
list*
(
package-name
package-designator
)
(
package-nicknames
package-designator
))
:test
#'
string=
)
(
cerror
"Continue anyway"
"Trying to override the name or nickname ~A for package ~A ~
with a local nickname for another package ~A"
local-nickname
package-designator
actual-package
))
(
sys::%add-package-local-nickname
local-nickname
actual-package
package-designator
)))
test/lisp/abcl/package-local-nicknames-tests.lisp
View file @
ea130a4a
...
...
@@ -151,31 +151,29 @@
(
ext:add-package-local-nickname
:own-name-as-nickname1
p2
p1
)
(
error
()
:oops
))))
;; TODO: add continuable errors for this
;; (handler-bind ((error #'continue))
;; (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
;; (assert (eq (intern "FOO" p2)
;; (let ((*package* p1))
;; (intern "FOO" :own-name-as-nickname1))))
(
handler-bind
((
error
#'
continue
))
(
ext:add-package-local-nickname
:own-name-as-nickname1
p2
p1
))
(
assert
(
eq
(
intern
"FOO"
p2
)
(
let
((
*package*
p1
))
(
intern
"FOO"
:own-name-as-nickname1
))))
:success
)
:success
)
(
deftest
pln-own-nickname-as-local-nickname
(
with-tmp-packages
((
p1
(
make-package
"OWN-NICKNAME-AS-NICKNAME1"
:nicknames
'
(
"OWN-NICKNAME"
)))
(
p2
(
make-package
"OWN-NICKNAME-AS-NICKNAME2"
)))
(
assert
(
eq
:oops
(
handler-case
(
add-package-local-nickname
:own-nickname
p2
p1
)
(
error
()
:oops
))))
;; TODO: make errors continuable
;; (handler-bind ((error #'continue))
;; (add-package-local-nickname :own-nickname p2 p1))
;; (assert (eq (intern "FOO" p2)
;; (let ((*package* p1))
;; (intern "FOO" :own-nickname))))
:success
)
(
with-tmp-packages
((
p1
(
make-package
"OWN-NICKNAME-AS-NICKNAME1"
:nicknames
'
(
"OWN-NICKNAME"
)))
(
p2
(
make-package
"OWN-NICKNAME-AS-NICKNAME2"
)))
(
assert
(
eq
:oops
(
handler-case
(
ext:add-package-local-nickname
:own-nickname
p2
p1
)
(
error
()
:oops
))))
(
handler-bind
((
error
#'
continue
))
(
ext:add-package-local-nickname
:own-nickname
p2
p1
))
(
assert
(
eq
(
intern
"FOO"
p2
)
(
let
((
*package*
p1
))
(
intern
"FOO"
:own-nickname
))))
:success
)
:success
)
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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