XPost: comp.lang.scheme

Peter Seibel wrote:

that didn't just throw away those valuse. Here' a version that uses
lexical variables, as requested. However it suffers from only allowing
a finite number of named bags. There may be some clever way to work
around that without walking the code. Or you could just live with it,
the same way we live with other limits such as the number of arguments
we can pass to a function.

(defmacro bag (&body body)
(let ((bag (gensym))
(namedbags (loop repeat 10 collect (gensym))))
`(let ((,bag ())
,@(loop for bag in namedbags collect `(,bag ())))
(flet ((find-bag (name)
(cond
(name
(loop for bag in ',namedbags
for bagname = (get bag 'bag-name)
when (eql name bagname) return bag
when (not bagname) do
(setf (get bag 'bag-name) name) and
return bag
finally (error "Out of bags")))
(t ',bag))))
(macrolet ((containing (item &optional name)
`(push ,item ,(find-bag name)))
(the-bag (name)
(find-bag name)))
,@body)
,bag))))

This lets you write stuff like:

CL-USER> (bag
(dotimes (i 10)
(if (evenp i)
(containing i evens)
(containing i odds)))
(containing (the-bag evens))
(containing (the-bag odds)))
((9 7 5 3 1) (8 6 4 2 0))

Gauche Scheme

(let@ ('() odds evens)
(dotimes (i 10)
(if (odd? i) (push! odds i) (push! evens i)))
(list evens odds))

((8 6 4 2 0) (9 7 5 3 1))

Given:

(define-syntax let@-aux
(syntax-rules ()
[(let@-aux ('() var ...) (pairs ...) stuff)
(let@-aux () (pairs ... (var '()) ...) stuff)]
[(let@-aux (var val more ...) (pairs ...) stuff)
(let@-aux (more ...) (pairs ... (var val)) stuff)]
[(let@-aux (var) pairs stuff)
(let@-aux (var '()) pairs stuff)]
[(let@-aux () ((var val) ...) (stuff ...))
(let* ((var val) ...) stuff ...)]))
(define-syntax let@
(syntax-rules ()
[(let@ things stuff ...)
(let@-aux things () (stuff ...))]))

Another way.

(lope
collectors (evens odds)
upto i 0 9
((if (odd? i) odds evens) i))

'(0 2 4 6 8)
'(1 3 5 7 9)

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)