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))
