On Apr 11, 7:00 pm, Eduardo Cavazos <[email protected]> wrote:
> On 04/11/2010 11:50 AM, jhaase wrote:
>
> > Here is a version that works in ikarus. I just forgot to datum->syntax
> > the generated symbols. Strangely this worked in plt-scheme ...
>
> Cool. I tested it and it works in Ikarus, Chez, and Mosh. Ypsilon and
> Larceny have some trouble with it though (just fyi, not expecting you to
> debug :-)). The exact script I used is below.
>
> Ed
>
> (import (rnrs)
> (for (rnrs mutable-pairs) (meta 1))
> (syntax-walker))
>
> (with-special-syntax
> (let ((counter 345734817))
> (lambda (stx)
> (define (gensym ctxt)
> (set! counter (+ counter 1))
> (datum->syntax ctxt
> (string->symbol (string-append "partial-app-gensym-"
> (number->string counter)))))
> (define (last-pair ls)
> (if (null? (cdr ls))
> ls
> (last-pair (cdr ls))))
> (syntax-case stx ()
> (#(f args ...)
> (identifier? #'f)
> (let loop ((oldargs #'(args ...))
> (newargs '())
> (lambdalist '()))
> (syntax-case oldargs ()
> ((x)
> (let ((lambdalist (reverse lambdalist)))
> (if (eq? (syntax->datum #'x) '_)
> (let ((sym (gensym #'f)))
> (if (null? lambdalist)
> (set! lambdalist sym)
> (set-cdr! (last-pair lambdalist) sym))
> #`(lambda #,lambdalist
> (apply f #,@(reverse newargs) #,sym)))
> #`(lambda #,lambdalist
> (f #,@(reverse (cons #'x newargs)))))))
> ((x y ...)
> (if (eq? (syntax->datum #'x) '_)
> (let ((sym (gensym #'f)))
> (loop #'(y ...)
> (cons sym newargs)
> (cons sym lambdalist)))
> (loop #'(y ...)
> (cons #'x newargs)
> lambdalist)))))))))
>
> (display (map #(+ _ 1) '(1 2 3 4)))
> (newline)
>
> (display (map #(* _ _) '(1 2 3 4) '(2 3 4 5)))
> (newline)
>
> (display (#(list _) 1 2 3 4))
> (newline))
Ah, by the way you can drop the syntax clause guard (identifier? #'f)
and generate the gensyms with context #'x instead of #'f.
It's just a remnant from an early version. So the first element inside
the vector doesn't have to be an identifier:
(with-special-syntax
(let ((counter 345734817))
(lambda (stx)
(define (gensym ctxt)
(set! counter (+ counter 1))
(datum->syntax ctxt
(string->symbol (string-append "partial-app-gensym-"
(number->string counter)))))
(define (last-pair ls)
(if (null? (cdr ls))
ls
(last-pair (cdr ls))))
(syntax-case stx ()
(#(f args ...)
(let loop ((oldargs #'(args ...))
(newargs '())
(lambdalist '()))
(syntax-case oldargs ()
((x)
(let ((lambdalist (reverse lambdalist)))
(if (eq? (syntax->datum #'x) '_)
(let ((sym (gensym #'x)))
(if (null? lambdalist)
(set! lambdalist sym)
(set-cdr! (last-pair lambdalist) sym))
#`(lambda #,lambdalist
(apply f #,@(reverse newargs) #,sym)))
#`(lambda #,lambdalist
(f #,@(reverse (cons #'x newargs)))))))
((x y ...)
(if (eq? (syntax->datum #'x) '_)
(let ((sym (gensym #'x)))
(loop #'(y ...)
(cons sym newargs)
(cons sym lambdalist)))
(loop #'(y ...)
(cons #'x newargs)
lambdalist)))))))))
(display (map #((lambda (x y) (* x y)) _ _) '(1 2 3 4) '(2 3 4 5)))
(newline))
Greetings,
Juergen
