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
Momchil Ivanov
alexandria
Commits
656344e6
Commit
656344e6
authored
Feb 17, 2008
by
Nikodemus Siivola
Browse files
extended ONCE-ONLY
* Support (once-only ((nx x)) ...) style also.
parent
816d2f40
Changes
2
Hide whitespace changes
Inline
Side-by-side
macros.lisp
View file @
656344e6
...
...
@@ -17,21 +17,35 @@
"Alias for WITH-GENSYMS."
`
(
with-gensyms
,
names
,@
forms
))
(
defmacro
once-only
(
names
&body
forms
)
"Evaluates FORMS with NAMES rebound to temporary variables,
ensuring that each is evaluated only once.
(
defmacro
once-only
(
specs
&body
forms
)
"Each SPEC must be either a NAME, or a (NAME INITFORM), with plain
NAME using the named variable as initform.
Evaluates FORMS with names rebound to temporary variables, ensuring
that each is evaluated only once.
Example:
(defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
(let ((y 0)) (cons1 (incf y))) => (1 . 1)"
(
let
((
gensyms
(
make-gensym-list
(
length
names
)
"ONCE-ONLY"
)))
(
let
((
gensyms
(
make-gensym-list
(
length
specs
)
"ONCE-ONLY"
))
(
names-and-forms
(
mapcar
(
lambda
(
spec
)
(
etypecase
spec
(
list
(
destructuring-bind
(
name
form
)
spec
(
cons
name
form
)))
(
symbol
(
cons
spec
spec
))))
specs
)))
;; bind in user-macro
`
(
let
,
(
mapcar
(
lambda
(
g
n
)
(
list
g
`
(
gensym
,
(
string
n
))))
gensyms
names
)
`
(
let
,
(
mapcar
(
lambda
(
g
n
)
(
list
g
`
(
gensym
,
(
string
(
car
n
)
))))
gensyms
names
-and-forms
)
;; bind in final expansion
`
(
let
(
,,@
(
mapcar
(
lambda
(
g
n
)
``
(
,,
g
,,
n
))
gensyms
names
))
`
(
let
(
,,@
(
mapcar
(
lambda
(
g
n
)
``
(
,,
g
,,
(
cdr
n
)))
gensyms
names-and-forms
))
;; bind in user-macro
,
(
let
,
(
mapcar
#'
list
names
gensyms
)
,
(
let
,
(
mapcar
(
lambda
(
n
g
)
(
list
(
car
n
)
g
))
names-and-forms
gensyms
)
,@
forms
)))))
(
defun
parse-body
(
body
&key
documentation
whole
)
...
...
tests.lisp
View file @
656344e6
...
...
@@ -1137,6 +1137,16 @@
y
)))
((
1
.
1
)
1
(
2
.
3
)
3
))
(
deftest
once-only.2
(
macrolet
((
cons1
(
x
)
(
once-only
((
y
x
))
`
(
cons
,
y
,
y
))))
(
let
((
z
0
))
(
list
(
cons1
(
incf
z
))
z
(
cons1
(
incf
z
)))))
((
1
.
1
)
1
(
2
.
2
)))
(
deftest
parse-body.1
(
parse-body
'
(
"doc"
"body"
)
:documentation
t
)
(
"body"
)
...
...
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