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
0d7a4c95
Commit
0d7a4c95
authored
27 years ago
by
pw
Browse files
Options
Downloads
Patches
Plain Diff
New shiftf from Bruno Haible fixes problem with duplicated places.
parent
d755099f
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/macros.lisp
+18
-29
18 additions, 29 deletions
code/macros.lisp
with
18 additions
and
29 deletions
code/macros.lisp
+
18
−
29
View file @
0d7a4c95
...
...
@@ -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.
49
1997/0
5
/0
8 20:5
2:4
3
pw Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.
50
1997/0
6
/0
5 13:0
2:4
5
pw Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -726,38 +726,27 @@
`
(
progn
,@
(
setters
)
nil
))))
(
thunk
(
let*-bindings
)
(
mv-bindings
)))))
(
defmacro
shiftf
(
&rest
args
&environment
env
)
(
defmacro
shiftf
(
&whole
form
&rest
args
&environment
env
)
"One or more SETF-style place expressions, followed by a single
value expression. Evaluates all of the expressions in turn, then
assigns the value of each expression to the place on its left,
returning the value of the leftmost."
(
if
(
<
(
length
args
)
2
)
(
error
"Too few argument forms to a SHIFTF."
))
(
collect
((
let*-bindings
)
(
forms
))
(
do
((
first
t
nil
)
(
a
args
(
cdr
a
))
(
prev-store-vars
)
(
prev-setter
))
((
endp
(
cdr
a
))
(
forms
`
(
multiple-value-bind
,
prev-store-vars
,
(
car
a
)
,
prev-setter
)))
(
multiple-value-bind
(
temps
exprs
store-vars
setter
getter
)
(
get-setf-expansion
(
car
a
)
env
)
(
loop
for
temp
in
temps
for
expr
in
exprs
do
(
let*-bindings
`
(
,
temp
,
expr
)))
(
forms
(
if
first
getter
`
(
multiple-value-bind
,
prev-store-vars
,
getter
,
prev-setter
)))
(
setf
prev-store-vars
store-vars
)
(
setf
prev-setter
setter
)))
`
(
let*
,
(
let*-bindings
)
(
multiple-value-prog1
,@
(
forms
)))))
(
when
(
<
(
length
args
)
2
)
(
error
"~S called with too few arguments: ~S"
'shiftf
form
))
(
let
((
resultvar
(
gensym
)))
(
do
((
arglist
args
(
cdr
arglist
))
(
bindlist
nil
)
(
storelist
nil
)
(
lastvar
resultvar
))
((
atom
(
cdr
arglist
))
(
push
`
(
,
lastvar
,
(
first
arglist
))
bindlist
)
`
(
LET*
,
(
nreverse
bindlist
)
,@
(
nreverse
storelist
)
,
resultvar
))
(
multiple-value-bind
(
SM1
SM2
SM3
SM4
SM5
)
(
get-setf-method
(
first
arglist
)
env
)
(
mapc
#'
(
lambda
(
var
val
)
(
push
`
(
,
var
,
val
)
bindlist
))
SM1
SM2
)
(
push
`
(
,
lastvar
,
SM5
)
bindlist
)
(
push
SM4
storelist
)
(
setq
lastvar
(
first
SM3
))))))
(
defmacro
rotatef
(
&rest
args
&environment
env
)
"Takes any number of SETF-style place expressions. Evaluates all of the
...
...
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