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
7105d16b
Commit
7105d16b
authored
26 years ago
by
dtc
Browse files
Options
Downloads
Patches
Plain Diff
Define a VALUES setf expander.
Update references to the obsolete define-setf-method to define-setf-expander
parent
1866dce2
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/macros.lisp
+27
-11
27 additions, 11 deletions
code/macros.lisp
with
27 additions
and
11 deletions
code/macros.lisp
+
27
−
11
View file @
7105d16b
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.5
7
1998/07/1
6
1
3:30:48 pw
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.5
8
1998/07/1
7
1
2:10:44 dtc
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -196,14 +196,14 @@
"Syntax like DEFMACRO, but creates a Setf-Method generator. The body
must be a form that returns the five magical values."
(
unless
(
symbolp
access-fn
)
(
error
"~S -- Access-function name not a symbol in DEFINE-SETF-
METHOD
."
(
error
"~S -- Access-function name not a symbol in DEFINE-SETF-
EXPANDER
."
access-fn
))
(
let
((
whole
(
gensym
"WHOLE-"
))
(
environment
(
gensym
"ENV-"
)))
(
multiple-value-bind
(
body
local-decs
doc
)
(
parse-defmacro
lambda-list
whole
body
access-fn
'define-setf-
method
'define-setf-
expander
:environment
environment
)
`
(
eval-when
(
load
compile
eval
)
(
%define-setf-macro
...
...
@@ -519,7 +519,7 @@
;;; new-value arg at the end.
;;;
;;; A SETF method expander is created by the long form of DEFSETF or
;;; by DEFINE-SETF-
METHOD
. It is a function that is called on the reference
;;; by DEFINE-SETF-
EXPANDER
. It is a function that is called on the reference
;;; form and that produces five values: a list of temporary variables, a list
;;; of value forms, a list of the single store-value form, a storing function,
;;; and an accessing function.
...
...
@@ -995,7 +995,7 @@
#+
long-float
(
defsetf
sap-ref-long
%set-sap-ref-long
)
(
define-setf-
method
getf
(
place
prop
&optional
default
&environment
env
)
(
define-setf-
expander
getf
(
place
prop
&optional
default
&environment
env
)
(
multiple-value-bind
(
temps
values
stores
set
get
)
(
get-setf-method
place
env
)
(
let
((
newval
(
gensym
))
...
...
@@ -1009,7 +1009,7 @@
,
newval
)
`
(
getf
,
get
,
ptemp
,@
(
if
default
`
(
,
def-temp
)))))))
(
define-setf-
method
get
(
symbol
prop
&optional
default
)
(
define-setf-
expander
get
(
symbol
prop
&optional
default
)
(
let
((
symbol-temp
(
gensym
))
(
prop-temp
(
gensym
))
(
def-temp
(
gensym
))
...
...
@@ -1020,7 +1020,7 @@
`
(
%put
,
symbol-temp
,
prop-temp
,
newval
)
`
(
get
,
symbol-temp
,
prop-temp
,@
(
if
default
`
(
,
def-temp
))))))
(
define-setf-
method
gethash
(
key
hashtable
&optional
default
)
(
define-setf-
expander
gethash
(
key
hashtable
&optional
default
)
(
let
((
key-temp
(
gensym
))
(
hashtable-temp
(
gensym
))
(
default-temp
(
gensym
))
...
...
@@ -1041,7 +1041,7 @@
;;; it used to be.) The function arg must be constant, and is converted to an
;;; APPLY of ther SETF function, which ought to exist.
;;;
(
define-setf-
method
apply
(
function
&rest
args
)
(
define-setf-
expander
apply
(
function
&rest
args
)
(
unless
(
and
(
listp
function
)
(
=
(
list-length
function
)
2
)
(
eq
(
first
function
)
'function
)
...
...
@@ -1060,7 +1060,7 @@
;;; Special-case a BYTE bytespec so that the compiler can recognize it.
;;;
(
define-setf-
method
ldb
(
bytespec
place
&environment
env
)
(
define-setf-
expander
ldb
(
bytespec
place
&environment
env
)
"The first argument is a byte specifier. The second is any place form
acceptable to SETF. Replaces the specified byte of the number in this
place with bits from the low-order end of the new value."
...
...
@@ -1089,7 +1089,7 @@
`
(
ldb
,
btemp
,
getter
))))))
(
define-setf-
method
mask-field
(
bytespec
place
&environment
env
)
(
define-setf-
expander
mask-field
(
bytespec
place
&environment
env
)
"The first argument is a byte specifier. The second is any place form
acceptable to SETF. Replaces the specified byte of the number in this place
with bits from the corresponding position in the new value."
...
...
@@ -1106,7 +1106,7 @@
`
(
mask-field
,
btemp
,
getter
)))))
(
define-setf-
method
the
(
type
place
&environment
env
)
(
define-setf-
expander
the
(
type
place
&environment
env
)
(
multiple-value-bind
(
dummies
vals
newval
setter
getter
)
(
get-setf-method
place
env
)
(
values
dummies
...
...
@@ -1115,6 +1115,22 @@
(
subst
`
(
the
,
type
,
(
car
newval
))
(
car
newval
)
setter
)
`
(
the
,
type
,
getter
))))
(
define-setf-expander
values
(
&rest
places
&environment
env
)
(
collect
((
setters
)
(
getters
))
(
let
((
all-dummies
'
())
(
all-vals
'
())
(
newvals
'
()))
(
dolist
(
place
places
)
(
multiple-value-bind
(
dummies
vals
newval
setter
getter
)
(
get-setf-expansion
place
env
)
(
setf
all-dummies
(
append
all-dummies
dummies
))
(
setf
all-vals
(
append
all-vals
vals
))
(
setf
newvals
(
append
newvals
newval
))
(
setters
setter
)
(
getters
getter
)))
(
values
all-dummies
all-vals
newvals
`
(
values
,@
(
setters
))
`
(
values
,@
(
getters
))))))
;;;; CASE, TYPECASE, & Friends.
...
...
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