214 lines
5.8 KiB
Scheme
214 lines
5.8 KiB
Scheme
;;----------------------------------------------------------------------
|
|
;; #%qqstx : quasisyntax
|
|
|
|
(module qqstx '#%kernel
|
|
(#%require "small-scheme.ss" "stxcase-scheme.ss" "stx.ss"
|
|
(for-syntax '#%kernel "small-scheme.ss" "stxcase-scheme.ss" "stx.ss"))
|
|
|
|
(#%provide quasisyntax
|
|
quasisyntax/loc
|
|
unsyntax
|
|
unsyntax-splicing)
|
|
|
|
(define-syntaxes (unsyntax unsyntax-splicing)
|
|
(let ([f (lambda (stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"illegal outside of quasisyntax"
|
|
stx))])
|
|
(values f f)))
|
|
|
|
(-define (check-splicing-list l ctx)
|
|
(unless (stx-list? l)
|
|
(raise-type-error
|
|
'unsyntax-splicing
|
|
"proper syntax list"
|
|
l))
|
|
(datum->syntax ctx l ctx))
|
|
|
|
(define-syntaxes (quasisyntax quasisyntax/loc)
|
|
(let ([qq
|
|
(lambda (orig-stx body mk-final)
|
|
(let ([here-stx #'here])
|
|
(let loop ([stx body]
|
|
[depth 0]
|
|
[same-k (lambda ()
|
|
(datum->syntax
|
|
here-stx
|
|
(mk-final body)
|
|
orig-stx))]
|
|
[convert-k (lambda (body bindings)
|
|
(datum->syntax
|
|
here-stx
|
|
(list
|
|
(quote-syntax with-syntax)
|
|
bindings
|
|
(mk-final body))
|
|
orig-stx))])
|
|
(syntax-case stx (unsyntax unsyntax-splicing quasisyntax)
|
|
[(unsyntax x)
|
|
(if (zero? depth)
|
|
(let ([temp (car (generate-temporaries '(uq)))])
|
|
(convert-k temp (list (list temp (syntax x)))))
|
|
(loop (syntax x) (sub1 depth)
|
|
same-k
|
|
(lambda (v bindings)
|
|
(convert-k (datum->syntax
|
|
here-stx
|
|
(list (stx-car stx) v)
|
|
stx)
|
|
bindings))))]
|
|
[unsyntax
|
|
(raise-syntax-error
|
|
#f
|
|
"misuse within quasisyntax"
|
|
orig-stx
|
|
stx)]
|
|
[((unsyntax-splicing x) . rest)
|
|
(if (zero? depth)
|
|
(let ([rest-done-k
|
|
(lambda (rest-v bindings)
|
|
(with-syntax ([temp (car (generate-temporaries '(uqs)))]
|
|
[ctx (datum->syntax #'x 'ctx #'x)])
|
|
(convert-k (datum->syntax
|
|
stx
|
|
(list* (syntax temp)
|
|
(quote-syntax ...)
|
|
rest-v)
|
|
stx)
|
|
(cons #'[(temp (... ...)) (check-splicing-list x (quote-syntax ctx))]
|
|
bindings))))])
|
|
(loop (syntax rest) depth
|
|
(lambda ()
|
|
(rest-done-k (syntax rest) null))
|
|
rest-done-k))
|
|
(let ([mk-rest-done-k
|
|
(lambda (x-v x-bindings)
|
|
(lambda (rest-v rest-bindings)
|
|
(convert-k (datum->syntax
|
|
stx
|
|
(cons x-v rest-v)
|
|
stx)
|
|
(append x-bindings
|
|
rest-bindings))))])
|
|
(loop (syntax x) (sub1 depth)
|
|
(lambda ()
|
|
;; x is unchanged.
|
|
(loop (syntax rest) depth
|
|
same-k
|
|
(mk-rest-done-k (stx-car stx) null)))
|
|
(lambda (x-v x-bindings)
|
|
;; x is generated by x-v
|
|
(let ([rest-done-k (mk-rest-done-k
|
|
(datum->syntax
|
|
(stx-car stx)
|
|
(list (stx-car (stx-car stx)) x-v)
|
|
(stx-car stx))
|
|
x-bindings)])
|
|
(loop (syntax rest) depth
|
|
(lambda ()
|
|
;; rest is unchanged
|
|
(rest-done-k (syntax rest) null))
|
|
rest-done-k))))))]
|
|
[unsyntax-splicing
|
|
(raise-syntax-error
|
|
#f
|
|
"misuse within quasisyntax"
|
|
orig-stx
|
|
stx)]
|
|
[(quasisyntax x)
|
|
(loop (syntax x) (add1 depth)
|
|
same-k
|
|
(lambda (v bindings)
|
|
(convert-k (datum->syntax
|
|
stx
|
|
(list (stx-car stx) v)
|
|
stx)
|
|
bindings)))]
|
|
[_
|
|
(cond
|
|
;; We treat pairs specially so that we don't generate a lot
|
|
;; of syntax objects when the input syntax collapses a list
|
|
;; into a single syntax object.
|
|
[(pair? (syntax-e stx))
|
|
(let ploop ([l (syntax-e stx)]
|
|
[same-k same-k]
|
|
[convert-k (lambda (l bindings)
|
|
(convert-k (datum->syntax
|
|
stx
|
|
l
|
|
stx)
|
|
bindings))])
|
|
(cond
|
|
[(pair? l)
|
|
(if (let ([a (car l)])
|
|
(or (and (identifier? a)
|
|
(or (free-identifier=? a (quote-syntax unsyntax))
|
|
(free-identifier=? a (quote-syntax quasisyntax))))
|
|
(and (stx-pair? a)
|
|
(let ([a (stx-car a)])
|
|
(and (identifier? a)
|
|
(free-identifier=? a (quote-syntax unsyntax-splicing)))))))
|
|
;; Found something important, like `unsyntax'; stop the special
|
|
;; handling for pairs
|
|
(loop (datum->syntax #f l #f) depth
|
|
same-k
|
|
convert-k)
|
|
;; Normal special pair handling
|
|
(ploop (cdr l)
|
|
(lambda ()
|
|
;; rest is the same
|
|
(loop (car l) depth
|
|
same-k
|
|
(lambda (a a-bindings)
|
|
(convert-k (cons (datum->syntax
|
|
(car l)
|
|
a
|
|
(car l))
|
|
(cdr l))
|
|
a-bindings))))
|
|
(lambda (rest rest-bindings)
|
|
(loop (car l) depth
|
|
(lambda ()
|
|
(convert-k (cons (car l) rest)
|
|
rest-bindings))
|
|
(lambda (a a-bindings)
|
|
(convert-k (cons (datum->syntax
|
|
(car l)
|
|
a
|
|
(car l))
|
|
rest)
|
|
(append a-bindings
|
|
rest-bindings)))))))]
|
|
[(null? l) (same-k)]
|
|
[else (loop l depth same-k convert-k)]))]
|
|
[(vector? (syntax-e stx))
|
|
(loop (datum->syntax
|
|
stx
|
|
(vector->list (syntax-e stx))
|
|
stx)
|
|
depth
|
|
same-k
|
|
(lambda (v bindings)
|
|
(convert-k (datum->syntax
|
|
stx
|
|
(list->vector (syntax->list v))
|
|
stx)
|
|
bindings)))]
|
|
[else
|
|
(same-k)])]))))])
|
|
(values (lambda (orig-stx)
|
|
(syntax-case orig-stx ()
|
|
[(_ stx) (qq orig-stx
|
|
(syntax stx)
|
|
(lambda (body)
|
|
(list (quote-syntax syntax) body)))]))
|
|
(lambda (orig-stx)
|
|
(syntax-case orig-stx ()
|
|
[(_ loc stx) (qq orig-stx
|
|
(syntax stx)
|
|
(lambda (body)
|
|
(list (quote-syntax syntax/loc)
|
|
(syntax loc)
|
|
body)))]))))))
|