Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
ab5fb657
Commit
ab5fb657
authored
33 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Make stuff work when conc-names make a subtype slot accessor have the same name
as the supertype accessor.
parent
13792b3f
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/defstruct.lisp
+115
-119
115 additions, 119 deletions
code/defstruct.lisp
with
115 additions
and
119 deletions
code/defstruct.lisp
+
115
−
119
View file @
ab5fb657
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.
29
199
1/12/14 08:56:10 wlott
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.
30
199
2/03/09 14:55:49 ram
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -138,28 +138,30 @@
(
make-load-form-fun
nil
)
(
make-load-form-fun-p
nil
))
((
null
options
)
(
make-defstruct-description
:name
name
:conc-name
conc-name
:constructors
(
if
constructor-opt-p
(
nreverse
constructors
)
(
list
(
concat-pnames
'make-
name
)))
:boa-constructors
boa-constructors
:copier
copier
:predicate
predicate
:include
include
:print-function
print-function
:type
type
:lisp-type
(
cond
((
eq
type
'structure
)
'simple-vector
)
((
eq
type
'vector
)
'simple-vector
)
((
eq
type
'list
)
'list
)
((
and
(
listp
type
)
(
eq
(
car
type
)
'vector
))
(
cons
'simple-array
(
cdr
type
)))
(
t
(
error
"~S is a bad :TYPE for Defstruct."
type
)))
:named
(
if
saw-type
saw-named
t
)
:offset
offset
:make-load-form-fun
make-load-form-fun
))
(
let
((
named
(
if
saw-type
saw-named
t
)))
(
make-defstruct-description
:name
name
:conc-name
conc-name
:constructors
(
if
constructor-opt-p
(
nreverse
constructors
)
(
list
(
concat-pnames
'make-
name
)))
:boa-constructors
boa-constructors
:copier
copier
:predicate
predicate
:include
include
:print-function
print-function
:type
type
:length
(
if
named
1
0
)
:lisp-type
(
cond
((
eq
type
'structure
)
'simple-vector
)
((
eq
type
'vector
)
'simple-vector
)
((
eq
type
'list
)
'list
)
((
and
(
listp
type
)
(
eq
(
car
type
)
'vector
))
(
cons
'simple-array
(
cdr
type
)))
(
t
(
error
"~S is a bad :TYPE for Defstruct."
type
)))
:named
named
:offset
offset
:make-load-form-fun
make-load-form-fun
)))
(
if
(
atom
(
car
options
))
(
case
(
car
options
)
(
:constructor
...
...
@@ -224,6 +226,52 @@
;;;; Stuff to parse slot descriptions.
;;; PARSE-1-DSD -- Internal
;;;
;;; Parse a slot description for DEFSTRUCT and add it to the description.
;;; If supplied, ISLOT is a pre-initialized DSD that we modify to get the new
;;; slot. This is supplied when handling included slots. If the new accessor
;;; name is EQ to the included name, then set the DSD-ACCESSOR to NIL so that
;;; we don't clobber the more general accessor.
;;;
(
defun
parse-1-dsd
(
defstruct
spec
&optional
(
islot
(
make-defstruct-slot-description
:%name
""
:index
0
:type
t
)))
(
multiple-value-bind
(
name
default
default-p
type
type-p
read-only
ro-p
)
(
cond
((
listp
spec
)
(
destructuring-bind
(
name
&optional
(
default
nil
default-p
)
&key
(
type
nil
type-p
)
(
read-only
nil
ro-p
))
spec
(
values
name
default
default-p
type
type-p
read-only
ro-p
)))
(
t
(
when
(
keywordp
spec
)
(
warn
"Keyword slot name indicates possible syntax ~
error in DEFSTRUCT -- ~S."
spec
))
spec
))
(
when
(
find
name
(
dd-slots
defstruct
)
:test
#'
string=
:key
#'
dsd-%name
)
(
error
"Duplicate slot name ~S."
name
))
(
setf
(
dsd-%name
islot
)
(
string
name
))
(
setf
(
dd-slots
defstruct
)
(
nconc
(
dd-slots
defstruct
)
(
list
islot
)))
(
let
((
aname
(
concat-pnames
(
dd-conc-name
defstruct
)
name
)))
(
setf
(
dsd-accessor
islot
)
(
if
(
eq
aname
(
dsd-accessor
islot
))
nil
aname
)))
(
when
default-p
(
setf
(
dsd-default
islot
)
default
))
(
when
type-p
(
setf
(
dsd-type
islot
)
type
))
(
when
ro-p
(
setf
(
dsd-read-only
islot
)
read-only
))
(
setf
(
dsd-index
islot
)
(
dd-length
defstruct
))
(
incf
(
dd-length
defstruct
)))
(
undefined-value
))
;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
;;; any structure inclusion that needs to be done.
;;;
...
...
@@ -234,83 +282,30 @@
(
setq
slots
(
cdr
slots
)))
;; Then include stuff. We add unparsed items to the start of the Slots.
(
when
(
dd-include
defstruct
)
(
let*
((
included-name
(
car
(
dd-include
defstruct
)))
(
included-thing
(
info
type
structure-info
included-name
))
(
modified-slots
(
cdr
(
dd-include
defstruct
))))
(
unless
included-thing
(
error
"Cannot find description of structure ~S to use for inclusion."
included-name
))
(
setf
(
dd-includes
defstruct
)
(
cons
(
dd-name
included-thing
)
(
dd-includes
included-thing
)))
(
setf
(
dd-offset
defstruct
)
(
dd-offset
included-thing
))
(
do*
((
islots
(
mapcar
#'
(
lambda
(
slot
)
`
(
,
(
dsd-name
slot
)
,
(
dsd-default
slot
)
:type
,
(
dsd-type
slot
)
:read-only
,
(
dsd-read-only
slot
)))
(
dd-slots
included-thing
)))
(
islots*
islots
(
cdr
islots*
)))
((
null
islots*
)
(
setq
slots
(
nconc
islots
slots
)))
(
let*
((
islot
(
car
islots*
))
(
modifiee
(
find
(
car
islot
)
modified-slots
:key
#'
(
lambda
(
x
)
(
if
(
atom
x
)
x
(
car
x
)))
:test
#'
string=
)))
(
when
modifiee
(
cond
((
symbolp
modifiee
)
;; If it's just a symbol, nilify the default.
(
setf
(
cadr
islot
)
nil
))
((
listp
modifiee
)
;; If it's a list, parse new defaults and options.
(
setf
(
cadr
islot
)
(
cadr
modifiee
))
(
when
(
cddr
modifiee
)
(
do
((
options
(
cddr
modifiee
)
(
cddr
options
)))
((
null
options
))
(
case
(
car
options
)
(
:type
(
setf
(
cadddr
islot
)
(
cadr
options
)))
(
:read-only
(
setf
(
cadr
(
cddddr
islot
))
(
cadr
options
)))
(
t
(
error
"Bad option in included slot spec: ~S."
(
car
options
)))))))))))))
(
destructuring-bind
(
included-name
&rest
modified-slots
)
(
dd-include
defstruct
)
(
let
((
included-thing
(
or
(
info
type
structure-info
included-name
)
(
error
"Cannot find description of structure ~S ~
to use for inclusion."
included-name
))))
(
setf
(
dd-includes
defstruct
)
(
cons
(
dd-name
included-thing
)
(
dd-includes
included-thing
)))
(
incf
(
dd-offset
defstruct
)
(
dd-offset
included-thing
))
(
incf
(
dd-length
defstruct
)
(
dd-offset
defstruct
))
(
dolist
(
islot
(
dd-slots
included-thing
))
(
let*
((
iname
(
dsd-name
islot
))
(
modified
(
or
(
find
iname
modified-slots
:key
#'
(
lambda
(
x
)
(
if
(
atom
x
)
x
(
car
x
)))
:test
#'
string=
)
`
(
,
iname
))))
(
parse-1-dsd
defstruct
modified
(
copy-defstruct-slot-description
islot
)))))))
;; Finally parse the slots into Slot-Description objects.
(
do
((
slots
slots
(
cdr
slots
))
(
index
(
+
(
dd-offset
defstruct
)
(
if
(
dd-named
defstruct
)
1
0
))
(
1+
index
))
(
descriptions
()))
((
null
slots
)
(
setf
(
dd-length
defstruct
)
index
)
(
setf
(
dd-slots
defstruct
)
(
nreverse
descriptions
)))
(
let*
((
slot
(
car
slots
))
(
name
(
if
(
atom
slot
)
slot
(
car
slot
))))
(
when
(
keywordp
name
)
(
warn
"Keyword slot name indicates possible syntax error in DEFSTRUCT ~
-- ~S."
name
))
(
push
(
if
(
atom
slot
)
(
make-defstruct-slot-description
:%name
(
string
name
)
:index
index
:accessor
(
concat-pnames
(
dd-conc-name
defstruct
)
name
)
:type
t
)
(
do
((
options
(
cddr
slot
)
(
cddr
options
))
(
default
(
cadr
slot
))
(
type
t
)
(
read-only
nil
))
((
null
options
)
(
make-defstruct-slot-description
:%name
(
string
name
)
:index
index
:accessor
(
concat-pnames
(
dd-conc-name
defstruct
)
name
)
:default
default
:type
type
:read-only
read-only
))
(
case
(
car
options
)
(
:type
(
setq
type
(
cadr
options
)))
(
:read-only
(
setq
read-only
(
cadr
options
))))))
descriptions
))))
(
dolist
(
slot
slots
)
(
parse-1-dsd
defstruct
slot
))
(
undefined-value
))
;;;; Default structure access and copiers:
...
...
@@ -403,28 +398,29 @@
(
dolist
(
slot
(
dd-slots
info
))
(
let
((
dsd
slot
))
(
setf
(
symbol-function
(
dsd-accessor
slot
))
#'
(
lambda
(
structure
)
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
unless
(
typep-to-structure
structure
info
)
(
error
"Structure for accessor ~S is not a ~S:~% ~S"
(
dsd-accessor
dsd
)
(
dd-name
info
)
structure
))
(
structure-ref
structure
(
dsd-index
dsd
))))
(
unless
(
dsd-read-only
slot
)
(
setf
(
fdefinition
`
(
setf
,
(
dsd-accessor
slot
)))
#'
(
lambda
(
new-value
structure
)
(
when
(
dsd-accessor
slot
)
(
setf
(
symbol-function
(
dsd-accessor
slot
))
#'
(
lambda
(
structure
)
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
unless
(
typep-to-structure
structure
info
)
(
error
"Structure for setter ~S is not a ~S:~% ~S"
`
(
setf
,
(
dsd-accessor
dsd
))
(
dd-name
info
)
structure
))
(
unless
(
typep
new-value
(
dsd-type
dsd
))
(
error
"New-Value for setter ~S is not a ~S:~% ~S."
`
(
setf
,
(
dsd-accessor
dsd
))
(
dsd-type
dsd
)
new-value
))
(
setf
(
structure-ref
structure
(
dsd-index
dsd
))
new-value
))))))
(
error
"Structure for accessor ~S is not a ~S:~% ~S"
(
dsd-accessor
dsd
)
(
dd-name
info
)
structure
))
(
structure-ref
structure
(
dsd-index
dsd
))))
(
unless
(
dsd-read-only
slot
)
(
setf
(
fdefinition
`
(
setf
,
(
dsd-accessor
slot
)))
#'
(
lambda
(
new-value
structure
)
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
unless
(
typep-to-structure
structure
info
)
(
error
"Structure for setter ~S is not a ~S:~% ~S"
`
(
setf
,
(
dsd-accessor
dsd
))
(
dd-name
info
)
structure
))
(
unless
(
typep
new-value
(
dsd-type
dsd
))
(
error
"New-Value for setter ~S is not a ~S:~% ~S."
`
(
setf
,
(
dsd-accessor
dsd
))
(
dsd-type
dsd
)
new-value
))
(
setf
(
structure-ref
structure
(
dsd-index
dsd
))
new-value
)))))))
(
when
(
dd-predicate
info
)
(
setf
(
symbol-function
(
dd-predicate
info
))
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
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!
Save comment
Cancel
Please
register
or
sign in
to comment