On Apr 9, 8:42 pm, Eduardo Cavazos <[email protected]> wrote:
> Hello,
>
> I've mentioned the idea of "programmable delimiters" here before.
>
> My 'define-record-type++' code (ab)uses the popular "dot" syntax for
> method invocation (and field access). In the spirit of "programmable
> delimiters", I'm now wondering about a "programmable dot". Right now,
> the dot syntax indicates a literal pair. With a programmable dot, you'd
> get an expansion into:
>
> (dot LEFT-EXPR RIGHT-EXPR)
>
> And the default binding of the 'dot' macro would be to call 'cons'.
>
> Of course, for this to work with things like method invocation:
>
> (num.sqrt)
>
> the dot would have to be recognized even when not whitespace delimited.
> Still, in certain libraries, I'd be happy to exchange literal pair
> syntax for a 'dot' macro.
>
> Ed
Hi!
I experimented with something similar a while ago and this macro came
out of it:
#!r6rs
(library (my syntax-walker)
(export with-special-syntax)
(import (rnrs))
(define-syntax with-special-syntax
(lambda (stx)
(syntax-case stx ()
((_ transformer body0 body ...)
#'(begin
(define-syntax walker
(lambda (stx)
(define transform transformer)
(define (walk stx)
(let ((stx2 (guard
(con ((syntax-violation? con) stx))
(transform stx))))
(if (eq? stx2 stx)
(syntax-case stx2 (quote quasiquote)
; quoted expressions
((quote x) #'(quote x))
; quasiquoted expressions
((quasiquote x)
#`(quasiquote #,(walk-quasiquote #'x)))
; lists
((x y (... ...) . r)
#`(#,@(map walk #'(x y (... ...))) . #,
(walk #'r)))
; unquoted vectors
(#(x (... ...))
#`#(#,@(map walk #'(x (... ...)))))
; everything else
(x #'x))
(walk stx2))))
(define (walk-quasiquote stx)
(syntax-case stx (unquote unquote-splicing)
((unquote x)
#`(unquote #,(walk #'x)))
((unquote-splicing x)
#`(unquote-splicing #,(walk #'x)))
((x y (... ...) . r)
#`(#,@(map walk-quasiquote #'(x y (... ...))) .
#,(walk-quasiquote #'r)))
(x #'x)))
(syntax-case stx ()
((_ a) (walk #'a)))))
(walker body0)
(walker body) ...))))))
With this you can do some nifty stuff:
#!r6rs
(import (rnrs)
(for (rnrs mutable-pairs) expand)
(my syntax-walker))
(with-special-syntax ; dot
(lambda (stx)
(define (split-symbol x)
(let* ((s (symbol->string x))
(l (string-length s)))
(let loop ((i (- l 2)))
(cond
((< i 1) #f)
((char=? (string-ref s i) #\.)
(cons (string->symbol (substring s 0 i))
(string->symbol (substring s (+ i 1) l))))
(else (loop (- i 1)))))))
(syntax-case stx ()
((x y ...)
(identifier? #'x)
(let ((v (split-symbol (syntax->datum #'x))))
(if (pair? v)
(cons* (datum->syntax #'x (cdr v))
(datum->syntax #'x (car v)) #'(y ...))
stx)))
(x
(identifier? #'x)
(let ((v (split-symbol (syntax->datum #'x))))
(if (pair? v)
(list (datum->syntax #'x (cdr v))
(datum->syntax #'x (car v)))
stx)))))
(define l '(1 2 3))
(display l.car)
(newline)
(display l.cdr)
(newline)
(display l.length)
(newline)
l.null?.display
(newline))
;=> 1
;=> (2 3)
;=> 3
;=> #f
(with-special-syntax ; keyword
(lambda (stx)
(syntax-case stx ()
(x
(and (identifier? #'x)
(char=?
(string-ref (symbol->string (syntax->datum #'x)) 0) #\:))
#'(quote x))))
(display :keyword)
(newline)
(display (symbol? :keyword))
(newline))
;=> :keyword
;=> #t
(with-special-syntax ; list-ref (ok this is dumb, but whatever)
(lambda (stx)
(syntax-case stx (in)
((a in b)
#'(list-ref b a))))
(display (2 in '(1 2 3 4)))
(newline))
;=> 3
(with-special-syntax ; unquoted vector
(let ((counter 345734817))
(lambda (stx)
(define (gensym)
(set! counter (+ counter 1))
(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)))
(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)))
(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))
;=> (2 3 4 5)
;=> (2 6 12 20)
;=> (1 2 3 4)
In case you're wondering about the guard expression in the
with-special-syntax macro, it's there so I don't have to put
(_ stx) as default clause into all the transformer procedures.
If you like it, feel free to use it however you like.
Greetings,
Juergen
