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
59744901
Commit
59744901
authored
Aug 19, 2012
by
ehuelsmann@1c010e3e-69d0-11dd-93a8-456734b0d56f
Browse files
Fix #113 (redefinition of structures can crash ABCL) by failing
the redefinition if the two structure definitions are not equalp.
parent
0bb77c56
Changes
1
Hide whitespace changes
Inline
Side-by-side
src/org/armedbear/lisp/defstruct.lisp
View file @
59744901
...
...
@@ -517,8 +517,8 @@
slots
inherited-accessors
documentation
)
(
s
et
f
(
get
name
'structure-defini
tion
)
(
make-defstruct-description
:name
name
(
l
et
(
(
descrip
tion
(
make-defstruct-description
:name
name
:conc-name
conc-name
:default-constructor
default-constructor
:constructors
constructors
...
...
@@ -533,6 +533,27 @@
:direct-slots
direct-slots
:slots
slots
:inherited-accessors
inherited-accessors
))
(
old
(
get
name
'structure-definition
)))
(
when
old
(
unless
;; Assert that the structure definitions are exactly the same
;; we need to support this type of redefinition during bootstrap
;; building ourselves
(
and
(
equalp
(
aref
old
0
)
(
aref
description
0
))
;; the CONC-NAME slot is an uninterned symbol if not supplied
;; thus different on each redefinition round. Check that the
;; names are equal, because it produces the same end result
;; when they are.
(
string=
(
aref
old
1
)
(
aref
description
1
))
(
dotimes
(
index
13
t
)
(
when
(
not
(
equalp
(
aref
old
(
+
2
index
))
(
aref
description
(
+
2
index
))))
(
return
nil
))))
(
error
'program-error
:format-control
"Structure redefinition not supported ~
in DEFSTRUCT for ~A"
:format-arguments
(
list
name
))))
(
setf
(
get
name
'structure-definition
)
description
))
(
%set-documentation
name
'structure
documentation
)
(
when
(
or
(
null
type
)
named
)
(
let
((
structure-class
...
...
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