Imported more files from 28f1df4cff
This commit is contained in:
Georges Dupéron
parent
1ee830a59e
commit
ea44edde13
74
case/stxcase-scheme.rkt
Normal file
74
case/stxcase-scheme.rkt
Normal file
|
|
@ -0,0 +1,74 @@
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
;; #%stxcase-scheme: adds let-syntax, syntax-rules, and
|
||||||
|
;; check-duplicate-identifier, and assembles everything we have so far
|
||||||
|
|
||||||
|
(module stxcase-scheme '#%kernel
|
||||||
|
(#%require "small-scheme.rkt" "stx.rkt" "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
|
||||||
|
(for-syntax '#%kernel "small-scheme.rkt" "stx.rkt" "stxcase.rkt"
|
||||||
|
"stxloc.rkt"))
|
||||||
|
|
||||||
|
(-define (check-duplicate-identifier names)
|
||||||
|
(unless (and (list? names) (andmap identifier? names))
|
||||||
|
(raise-argument-error 'check-duplicate-identifier "(listof identifier?)" names))
|
||||||
|
(let/ec escape
|
||||||
|
(let ([ht (make-hasheq)])
|
||||||
|
(for-each
|
||||||
|
(lambda (defined-name)
|
||||||
|
(unless (identifier? defined-name)
|
||||||
|
(raise-argument-error 'check-duplicate-identifier
|
||||||
|
"(listof identifier?)" names))
|
||||||
|
(let ([l (hash-ref ht (syntax-e defined-name) null)])
|
||||||
|
(when (ormap (lambda (i) (bound-identifier=? i defined-name)) l)
|
||||||
|
(escape defined-name))
|
||||||
|
(hash-set! ht (syntax-e defined-name) (cons defined-name l))))
|
||||||
|
names)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-values (check-sr-rules)
|
||||||
|
(lambda (stx kws)
|
||||||
|
(for-each (lambda (id)
|
||||||
|
(unless (identifier? id)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"pattern must start with an identifier, found something else"
|
||||||
|
stx
|
||||||
|
id)))
|
||||||
|
(syntax->list kws)))))
|
||||||
|
|
||||||
|
;; From Dybvig, mostly:
|
||||||
|
(-define-syntax syntax-rules
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case** syntax-rules #t stx () free-identifier=? #f
|
||||||
|
((sr (k ...) ((keyword . pattern) template) ...)
|
||||||
|
(andmap identifier? (syntax->list (syntax (k ...))))
|
||||||
|
(begin
|
||||||
|
(check-sr-rules stx (syntax (keyword ...)))
|
||||||
|
(syntax/loc stx
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case** sr #t x (k ...) free-identifier=? #f
|
||||||
|
((_ . pattern) (syntax-protect (syntax/loc x template)))
|
||||||
|
...))))))))
|
||||||
|
|
||||||
|
(-define-syntax syntax-id-rules
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case** syntax-id-rules #t x () free-identifier=? #f
|
||||||
|
((sidr (k ...) (pattern template) ...)
|
||||||
|
(andmap identifier? (syntax->list (syntax (k ...))))
|
||||||
|
(syntax/loc x
|
||||||
|
(make-set!-transformer
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case** sidr #t x (k ...) free-identifier=? #f
|
||||||
|
(pattern (syntax-protect (syntax/loc x template)))
|
||||||
|
...))))))))
|
||||||
|
|
||||||
|
(-define (syntax-protect stx)
|
||||||
|
(if (syntax? stx)
|
||||||
|
(syntax-arm stx #f #t)
|
||||||
|
(raise-argument-error 'syntax-protect "syntax?" stx)))
|
||||||
|
|
||||||
|
(#%provide syntax datum (all-from "with-stx.rkt") (all-from "stxloc.rkt")
|
||||||
|
check-duplicate-identifier syntax-protect
|
||||||
|
syntax-rules syntax-id-rules
|
||||||
|
(for-syntax syntax-pattern-variable?)))
|
||||||
604
case/stxcase.rkt
Normal file
604
case/stxcase.rkt
Normal file
|
|
@ -0,0 +1,604 @@
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
;; syntax-case and syntax
|
||||||
|
|
||||||
|
(module stxcase '#%kernel
|
||||||
|
(#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
|
||||||
|
"ellipses.rkt"
|
||||||
|
(for-syntax "stx.rkt" "small-scheme.rkt"
|
||||||
|
"member.rkt" "sc.rkt" '#%kernel))
|
||||||
|
|
||||||
|
(-define (datum->syntax/shape orig datum)
|
||||||
|
(if (syntax? datum)
|
||||||
|
datum
|
||||||
|
;; Keeps 'paren-shape and any other properties:
|
||||||
|
(datum->syntax orig datum orig orig)))
|
||||||
|
|
||||||
|
(-define (catch-ellipsis-error thunk sexp sloc)
|
||||||
|
((let/ec esc
|
||||||
|
(with-continuation-mark
|
||||||
|
exception-handler-key
|
||||||
|
(lambda (exn)
|
||||||
|
(esc
|
||||||
|
(lambda ()
|
||||||
|
(if (exn:break? exn)
|
||||||
|
(raise exn)
|
||||||
|
(raise-syntax-error
|
||||||
|
'syntax
|
||||||
|
"incompatible ellipsis match counts for template"
|
||||||
|
sexp
|
||||||
|
sloc)))))
|
||||||
|
(let ([v (thunk)])
|
||||||
|
(lambda () v))))))
|
||||||
|
|
||||||
|
(-define substitute-stop 'dummy)
|
||||||
|
|
||||||
|
;; pattern-substitute optimizes a pattern substitution by
|
||||||
|
;; merging variables that look up the same simple mapping
|
||||||
|
(-define-syntax pattern-substitute
|
||||||
|
(lambda (stx)
|
||||||
|
(let ([pat (stx-car (stx-cdr stx))]
|
||||||
|
[subs (stx->list (stx-cdr (stx-cdr stx)))])
|
||||||
|
(let ([ht-common (make-hash)]
|
||||||
|
[ht-map (make-hasheq)])
|
||||||
|
;; Determine merges:
|
||||||
|
(let loop ([subs subs])
|
||||||
|
(unless (null? subs)
|
||||||
|
(let ([id (syntax-e (car subs))]
|
||||||
|
[expr (cadr subs)])
|
||||||
|
(when (or (identifier? expr)
|
||||||
|
(and (stx-pair? expr)
|
||||||
|
(memq (syntax-e (stx-car expr))
|
||||||
|
'(car cadr caddr cadddr
|
||||||
|
cdr cddr cdddr cddddr
|
||||||
|
list-ref list-tail))
|
||||||
|
(stx-pair? (stx-cdr expr))
|
||||||
|
(identifier? (stx-car (stx-cdr expr)))))
|
||||||
|
(let ([s-expr (syntax->datum expr)])
|
||||||
|
(let ([new-id (hash-ref ht-common s-expr #f)])
|
||||||
|
(if new-id
|
||||||
|
(hash-set! ht-map id new-id)
|
||||||
|
(hash-set! ht-common s-expr id))))))
|
||||||
|
(loop (cddr subs))))
|
||||||
|
;; Merge:
|
||||||
|
(let ([new-pattern (if (zero? (hash-count ht-map))
|
||||||
|
pat
|
||||||
|
(let loop ([stx pat])
|
||||||
|
(cond
|
||||||
|
[(pair? stx)
|
||||||
|
(let ([a (loop (car stx))]
|
||||||
|
[b (loop (cdr stx))])
|
||||||
|
(if (and (eq? a (car stx))
|
||||||
|
(eq? b (cdr stx)))
|
||||||
|
stx
|
||||||
|
(cons a b)))]
|
||||||
|
[(symbol? stx)
|
||||||
|
(let ([new-id (hash-ref ht-map stx #f)])
|
||||||
|
(or new-id stx))]
|
||||||
|
[(syntax? stx)
|
||||||
|
(let ([new-e (loop (syntax-e stx))])
|
||||||
|
(if (eq? (syntax-e stx) new-e)
|
||||||
|
stx
|
||||||
|
(datum->syntax stx new-e stx stx)))]
|
||||||
|
[(vector? stx)
|
||||||
|
(list->vector (map loop (vector->list stx)))]
|
||||||
|
[(box? stx) (box (loop (unbox stx)))]
|
||||||
|
[else stx])))])
|
||||||
|
(datum->syntax (quote-syntax here)
|
||||||
|
`(apply-pattern-substitute
|
||||||
|
,new-pattern
|
||||||
|
(quote ,(let loop ([subs subs])
|
||||||
|
(cond
|
||||||
|
[(null? subs) null]
|
||||||
|
[(hash-ref ht-map (syntax-e (car subs)) #f)
|
||||||
|
;; Drop mapped id
|
||||||
|
(loop (cddr subs))]
|
||||||
|
[else
|
||||||
|
(cons (car subs) (loop (cddr subs)))])))
|
||||||
|
. ,(let loop ([subs subs])
|
||||||
|
(cond
|
||||||
|
[(null? subs) null]
|
||||||
|
[(hash-ref ht-map (syntax-e (car subs)) #f)
|
||||||
|
;; Drop mapped id
|
||||||
|
(loop (cddr subs))]
|
||||||
|
[else
|
||||||
|
(cons (cadr subs) (loop (cddr subs)))])))
|
||||||
|
stx))))))
|
||||||
|
|
||||||
|
(-define apply-pattern-substitute
|
||||||
|
(lambda (stx sub-ids . sub-vals)
|
||||||
|
(let loop ([stx stx])
|
||||||
|
(cond
|
||||||
|
[(pair? stx) (let ([a (loop (car stx))]
|
||||||
|
[b (loop (cdr stx))])
|
||||||
|
(if (and (eq? a (car stx))
|
||||||
|
(eq? b (cdr stx)))
|
||||||
|
stx
|
||||||
|
(cons a b)))]
|
||||||
|
[(symbol? stx)
|
||||||
|
(let sloop ([sub-ids sub-ids][sub-vals sub-vals])
|
||||||
|
(cond
|
||||||
|
[(null? sub-ids) stx]
|
||||||
|
[(eq? stx (car sub-ids)) (car sub-vals)]
|
||||||
|
[else (sloop (cdr sub-ids) (cdr sub-vals))]))]
|
||||||
|
[(syntax? stx)
|
||||||
|
(let ([new-e (loop (syntax-e stx))])
|
||||||
|
(if (eq? (syntax-e stx) new-e)
|
||||||
|
stx
|
||||||
|
(datum->syntax/shape stx new-e)))]
|
||||||
|
[(vector? stx)
|
||||||
|
(list->vector (map loop (vector->list stx)))]
|
||||||
|
[(box? stx) (box (loop (unbox stx)))]
|
||||||
|
[else stx]))))
|
||||||
|
|
||||||
|
(-define interp-match
|
||||||
|
(lambda (pat e literals immediate=?)
|
||||||
|
(interp-gen-match pat e literals immediate=? #f)))
|
||||||
|
|
||||||
|
(-define interp-s-match
|
||||||
|
(lambda (pat e literals immediate=?)
|
||||||
|
(interp-gen-match pat e literals immediate=? #t)))
|
||||||
|
|
||||||
|
(-define interp-gen-match
|
||||||
|
(lambda (pat e literals immediate=? s-exp?)
|
||||||
|
(let loop ([pat pat][e e][cap e])
|
||||||
|
(cond
|
||||||
|
[(null? pat)
|
||||||
|
(if s-exp?
|
||||||
|
(null? e)
|
||||||
|
(stx-null? e))]
|
||||||
|
[(number? pat)
|
||||||
|
(and (if s-exp? (symbol? e) (identifier? e))
|
||||||
|
(immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))]
|
||||||
|
[(not pat)
|
||||||
|
#t]
|
||||||
|
[else
|
||||||
|
(let ([i (vector-ref pat 0)])
|
||||||
|
(cond
|
||||||
|
[(eq? i 'bind)
|
||||||
|
(let ([e (if s-exp?
|
||||||
|
e
|
||||||
|
(if (vector-ref pat 2)
|
||||||
|
(datum->syntax cap e cap)
|
||||||
|
e))])
|
||||||
|
(if (vector-ref pat 1)
|
||||||
|
e
|
||||||
|
(list e)))]
|
||||||
|
[(eq? i 'pair)
|
||||||
|
(let ([match-head (vector-ref pat 1)]
|
||||||
|
[match-tail (vector-ref pat 2)]
|
||||||
|
[mh-did-var? (vector-ref pat 3)]
|
||||||
|
[mt-did-var? (vector-ref pat 4)])
|
||||||
|
(let ([cap (if (syntax? e) e cap)])
|
||||||
|
(and (stx-pair? e)
|
||||||
|
(let ([h (loop match-head (stx-car e) cap)])
|
||||||
|
(and h
|
||||||
|
(let ([t (loop match-tail (stx-cdr e) cap)])
|
||||||
|
(and t
|
||||||
|
(if mh-did-var?
|
||||||
|
(if mt-did-var?
|
||||||
|
(append h t)
|
||||||
|
h)
|
||||||
|
t))))))))]
|
||||||
|
[(eq? i 'quote)
|
||||||
|
(if s-exp?
|
||||||
|
(and (equal? (vector-ref pat 1) e)
|
||||||
|
null)
|
||||||
|
(and (syntax? e)
|
||||||
|
(equal? (vector-ref pat 1) (syntax-e e))
|
||||||
|
null))]
|
||||||
|
[(eq? i 'ellipses)
|
||||||
|
(let ([match-head (vector-ref pat 1)]
|
||||||
|
[nest-cnt (vector-ref pat 2)]
|
||||||
|
[last? (vector-ref pat 3)])
|
||||||
|
(and (if s-exp?
|
||||||
|
(list? e)
|
||||||
|
(stx-list? e))
|
||||||
|
(if (zero? nest-cnt)
|
||||||
|
(andmap (lambda (e) (loop match-head e cap))
|
||||||
|
(if s-exp? e (stx->list e)))
|
||||||
|
(let/ec esc
|
||||||
|
(let ([l (map (lambda (e)
|
||||||
|
(let ([m (loop match-head e cap)])
|
||||||
|
(if m
|
||||||
|
m
|
||||||
|
(esc #f))))
|
||||||
|
(if s-exp? e (stx->list e)))])
|
||||||
|
(if (null? l)
|
||||||
|
(let loop ([cnt nest-cnt])
|
||||||
|
(cond
|
||||||
|
[(= 1 cnt) (if last? '() '(()))]
|
||||||
|
[else (cons '() (loop (sub1 cnt)))]))
|
||||||
|
((if last? stx-rotate* stx-rotate) l)))))))]
|
||||||
|
[(eq? i 'mid-ellipses)
|
||||||
|
(let ([match-head (vector-ref pat 1)]
|
||||||
|
[match-tail (vector-ref pat 2)]
|
||||||
|
[tail-cnt (vector-ref pat 3)]
|
||||||
|
[prop? (vector-ref pat 4)]
|
||||||
|
[mh-did-var? (vector-ref pat 5)]
|
||||||
|
[mt-did-var? (vector-ref pat 6)])
|
||||||
|
(let-values ([(pre-items post-items ok?)
|
||||||
|
(split-stx-list e tail-cnt prop?)]
|
||||||
|
[(cap) (if (syntax? e) e cap)])
|
||||||
|
(and ok?
|
||||||
|
(let ([h (loop match-head pre-items cap)])
|
||||||
|
(and h
|
||||||
|
(let ([t (loop match-tail post-items cap)])
|
||||||
|
(and t
|
||||||
|
(if mt-did-var?
|
||||||
|
(if mh-did-var?
|
||||||
|
(append h t)
|
||||||
|
t)
|
||||||
|
h))))))))]
|
||||||
|
[(eq? i 'veclist)
|
||||||
|
(and (if s-exp?
|
||||||
|
(vector? e)
|
||||||
|
(stx-vector? e #f))
|
||||||
|
(loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))]
|
||||||
|
[(eq? i 'vector)
|
||||||
|
(and (if s-exp?
|
||||||
|
(and (vector? e) (= (vector-length e) (vector-ref pat 1)))
|
||||||
|
(stx-vector? e (vector-ref pat 1)))
|
||||||
|
(let vloop ([p (vector-ref pat 2)][pos 0])
|
||||||
|
(cond
|
||||||
|
[(null? p) null]
|
||||||
|
[else
|
||||||
|
(let ([clause (car p)])
|
||||||
|
(let ([match-elem (car clause)]
|
||||||
|
[elem-did-var? (cdr clause)])
|
||||||
|
(let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)])
|
||||||
|
(and m
|
||||||
|
(let ([body (vloop (cdr p) (add1 pos))])
|
||||||
|
(and body
|
||||||
|
(if elem-did-var?
|
||||||
|
(if (null? body)
|
||||||
|
m
|
||||||
|
(append m body))
|
||||||
|
body)))))))])))]
|
||||||
|
[(eq? i 'box)
|
||||||
|
(let ([match-content (vector-ref pat 1)])
|
||||||
|
(and (if s-exp?
|
||||||
|
(box? e)
|
||||||
|
(stx-box? e))
|
||||||
|
(loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))]
|
||||||
|
[(eq? i 'prefab)
|
||||||
|
(and (if s-exp?
|
||||||
|
(equal? (vector-ref pat 1) (prefab-struct-key e))
|
||||||
|
(stx-prefab? (vector-ref pat 1) e))
|
||||||
|
(loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))]
|
||||||
|
[else (error "yikes!" pat)]))]))))
|
||||||
|
|
||||||
|
(-define-syntax syntax-case**
|
||||||
|
(lambda (x)
|
||||||
|
(-define l (and (stx-list? x) (cdr (stx->list x))))
|
||||||
|
(unless (and (stx-list? x)
|
||||||
|
(> (length l) 3))
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"bad form"
|
||||||
|
x))
|
||||||
|
(let ([who (car l)]
|
||||||
|
[arg-is-stx? (cadr l)]
|
||||||
|
[expr (caddr l)]
|
||||||
|
[kws (cadddr l)]
|
||||||
|
[lit-comp (cadddr (cdr l))]
|
||||||
|
[s-exp? (syntax-e (cadddr (cddr l)))]
|
||||||
|
[clauses (cddddr (cddr l))])
|
||||||
|
(unless (stx-list? kws)
|
||||||
|
(raise-syntax-error
|
||||||
|
(syntax-e who)
|
||||||
|
"expected a parenthesized sequence of literal identifiers"
|
||||||
|
kws))
|
||||||
|
(for-each
|
||||||
|
(lambda (lit)
|
||||||
|
(unless (identifier? lit)
|
||||||
|
(raise-syntax-error
|
||||||
|
(syntax-e who)
|
||||||
|
"literal is not an identifier"
|
||||||
|
lit)))
|
||||||
|
(stx->list kws))
|
||||||
|
(for-each
|
||||||
|
(lambda (clause)
|
||||||
|
(unless (and (stx-list? clause)
|
||||||
|
(<= 2 (length (stx->list clause)) 3))
|
||||||
|
(raise-syntax-error
|
||||||
|
(syntax-e who)
|
||||||
|
"expected a clause containing a pattern, an optional guard expression, and an expression"
|
||||||
|
clause)))
|
||||||
|
clauses)
|
||||||
|
(let ([patterns (map stx-car clauses)]
|
||||||
|
[fenders (map (lambda (clause)
|
||||||
|
(and (stx-pair? (stx-cdr (stx-cdr clause)))
|
||||||
|
(stx-car (stx-cdr clause))))
|
||||||
|
clauses)]
|
||||||
|
[answers (map (lambda (clause)
|
||||||
|
(let ([r (stx-cdr (stx-cdr clause))])
|
||||||
|
(if (stx-pair? r)
|
||||||
|
(stx-car r)
|
||||||
|
(stx-car (stx-cdr clause)))))
|
||||||
|
clauses)])
|
||||||
|
(let* ([arg (quote-syntax arg)]
|
||||||
|
[rslt (quote-syntax rslt)]
|
||||||
|
[pattern-varss (map
|
||||||
|
(lambda (pattern)
|
||||||
|
(get-match-vars who pattern pattern (stx->list kws)))
|
||||||
|
(stx->list patterns))]
|
||||||
|
[lit-comp-is-mod? (and (identifier? lit-comp)
|
||||||
|
(free-identifier=?
|
||||||
|
lit-comp
|
||||||
|
(quote-syntax free-identifier=?)))])
|
||||||
|
(syntax-arm
|
||||||
|
(datum->syntax
|
||||||
|
(quote-syntax here)
|
||||||
|
(list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?))
|
||||||
|
expr
|
||||||
|
(list (quote-syntax datum->syntax)
|
||||||
|
(list
|
||||||
|
(quote-syntax quote-syntax)
|
||||||
|
(datum->syntax
|
||||||
|
expr
|
||||||
|
'here))
|
||||||
|
expr))))
|
||||||
|
(let loop ([patterns patterns]
|
||||||
|
[fenders fenders]
|
||||||
|
[unflat-pattern-varss pattern-varss]
|
||||||
|
[answers answers])
|
||||||
|
(cond
|
||||||
|
[(null? patterns)
|
||||||
|
(list
|
||||||
|
(quote-syntax raise-syntax-error)
|
||||||
|
#f
|
||||||
|
"bad syntax"
|
||||||
|
arg)]
|
||||||
|
[else
|
||||||
|
(let ([rest (loop (cdr patterns) (cdr fenders)
|
||||||
|
(cdr unflat-pattern-varss) (cdr answers))])
|
||||||
|
(let ([pattern (car patterns)]
|
||||||
|
[fender (car fenders)]
|
||||||
|
[unflat-pattern-vars (car unflat-pattern-varss)]
|
||||||
|
[answer (car answers)])
|
||||||
|
(-define pattern-vars
|
||||||
|
(map (lambda (var)
|
||||||
|
(let loop ([var var])
|
||||||
|
(if (syntax? var)
|
||||||
|
var
|
||||||
|
(loop (car var)))))
|
||||||
|
unflat-pattern-vars))
|
||||||
|
(-define temp-vars
|
||||||
|
(map
|
||||||
|
(lambda (p) (gen-temp-id 'sc))
|
||||||
|
pattern-vars))
|
||||||
|
(-define tail-pattern-var (sub1 (length pattern-vars)))
|
||||||
|
;; Here's the result expression for one match:
|
||||||
|
(let* ([do-try-next (if (car fenders)
|
||||||
|
(list (quote-syntax try-next))
|
||||||
|
rest)]
|
||||||
|
[mtch (make-match&env
|
||||||
|
who
|
||||||
|
pattern
|
||||||
|
pattern
|
||||||
|
(stx->list kws)
|
||||||
|
(not lit-comp-is-mod?)
|
||||||
|
s-exp?)]
|
||||||
|
[cant-fail? (if lit-comp-is-mod?
|
||||||
|
(equal? mtch '(lambda (e) e))
|
||||||
|
(equal? mtch '(lambda (e free-identifier=?) e)))]
|
||||||
|
;; Avoid generating gigantic matching expressions.
|
||||||
|
;; If it's too big, interpret at run time, instead
|
||||||
|
[interp? (and (not cant-fail?)
|
||||||
|
(zero?
|
||||||
|
(let sz ([mtch mtch][fuel 100])
|
||||||
|
(cond
|
||||||
|
[(zero? fuel) 0]
|
||||||
|
[(pair? mtch) (sz (cdr mtch)
|
||||||
|
(sz (car mtch)
|
||||||
|
fuel))]
|
||||||
|
[(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))]
|
||||||
|
[else (sub1 fuel)]))))]
|
||||||
|
[mtch (if interp?
|
||||||
|
(let ([interp-box (box null)])
|
||||||
|
(let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)])
|
||||||
|
(list 'lambda
|
||||||
|
'(e)
|
||||||
|
(list (if s-exp? 'interp-s-match 'interp-match)
|
||||||
|
(list 'quote pat)
|
||||||
|
'e
|
||||||
|
(if (null? (unbox interp-box))
|
||||||
|
#f
|
||||||
|
(list (if s-exp? 'quote 'quote-syntax)
|
||||||
|
(list->vector (reverse (unbox interp-box)))))
|
||||||
|
lit-comp))))
|
||||||
|
mtch)]
|
||||||
|
[m
|
||||||
|
;; Do match, bind result to rslt:
|
||||||
|
(list (quote-syntax let)
|
||||||
|
(list
|
||||||
|
(list rslt
|
||||||
|
(if cant-fail?
|
||||||
|
arg
|
||||||
|
(list* (datum->syntax
|
||||||
|
(quote-syntax here)
|
||||||
|
mtch
|
||||||
|
pattern)
|
||||||
|
arg
|
||||||
|
(if (or interp? lit-comp-is-mod?)
|
||||||
|
null
|
||||||
|
(list lit-comp))))))
|
||||||
|
;; If match succeeded...
|
||||||
|
(list
|
||||||
|
(quote-syntax if)
|
||||||
|
(if cant-fail?
|
||||||
|
#t
|
||||||
|
rslt)
|
||||||
|
;; Extract each name binding into a temp variable:
|
||||||
|
(list
|
||||||
|
(quote-syntax let)
|
||||||
|
(map (lambda (pattern-var temp-var)
|
||||||
|
(list
|
||||||
|
temp-var
|
||||||
|
(let ([pos (stx-memq-pos pattern-var pattern-vars)])
|
||||||
|
(let ([accessor (cond
|
||||||
|
[(= tail-pattern-var pos)
|
||||||
|
(cond
|
||||||
|
[(eq? pos 0) 'tail]
|
||||||
|
[(eq? pos 1) (quote-syntax unsafe-cdr)]
|
||||||
|
[else 'tail])]
|
||||||
|
[(eq? pos 0) (quote-syntax unsafe-car)]
|
||||||
|
[else #f])])
|
||||||
|
(cond
|
||||||
|
[(eq? accessor 'tail)
|
||||||
|
(if (zero? pos)
|
||||||
|
rslt
|
||||||
|
(list
|
||||||
|
(quote-syntax unsafe-list-tail)
|
||||||
|
rslt
|
||||||
|
pos))]
|
||||||
|
[accessor (list
|
||||||
|
accessor
|
||||||
|
rslt)]
|
||||||
|
[else (list
|
||||||
|
(quote-syntax unsafe-list-ref)
|
||||||
|
rslt
|
||||||
|
pos)])))))
|
||||||
|
pattern-vars temp-vars)
|
||||||
|
;; Tell nested `syntax' forms about the
|
||||||
|
;; pattern-bound variables:
|
||||||
|
(list
|
||||||
|
(quote-syntax letrec-syntaxes+values)
|
||||||
|
(map (lambda (pattern-var unflat-pattern-var temp-var)
|
||||||
|
(list (list pattern-var)
|
||||||
|
(list
|
||||||
|
(if s-exp?
|
||||||
|
(quote-syntax make-s-exp-mapping)
|
||||||
|
(quote-syntax make-syntax-mapping))
|
||||||
|
;; Tell it the shape of the variable:
|
||||||
|
(let loop ([var unflat-pattern-var][d 0])
|
||||||
|
(if (syntax? var)
|
||||||
|
d
|
||||||
|
(loop (car var) (add1 d))))
|
||||||
|
;; Tell it the variable name:
|
||||||
|
(list
|
||||||
|
(quote-syntax quote-syntax)
|
||||||
|
temp-var))))
|
||||||
|
pattern-vars unflat-pattern-vars
|
||||||
|
temp-vars)
|
||||||
|
null
|
||||||
|
(if fender
|
||||||
|
(list (quote-syntax if) fender
|
||||||
|
answer
|
||||||
|
do-try-next)
|
||||||
|
answer)))
|
||||||
|
do-try-next))])
|
||||||
|
(if fender
|
||||||
|
(list
|
||||||
|
(quote-syntax let)
|
||||||
|
;; Bind try-next to try next case
|
||||||
|
(list (list (quote try-next)
|
||||||
|
(list (quote-syntax lambda)
|
||||||
|
(list)
|
||||||
|
rest)))
|
||||||
|
;; Try one match
|
||||||
|
m)
|
||||||
|
;; Match try already embed the rest case
|
||||||
|
m))))])))
|
||||||
|
x)))))))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-values (gen-template)
|
||||||
|
(lambda (x s-exp?)
|
||||||
|
(-define here-stx (quote-syntax here))
|
||||||
|
(unless (and (stx-pair? x)
|
||||||
|
(let ([rest (stx-cdr x)])
|
||||||
|
(and (stx-pair? rest)
|
||||||
|
(stx-null? (stx-cdr rest)))))
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"bad form"
|
||||||
|
x))
|
||||||
|
(syntax-arm
|
||||||
|
(datum->syntax
|
||||||
|
here-stx
|
||||||
|
(let ([pattern (stx-car (stx-cdr x))])
|
||||||
|
(let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)])
|
||||||
|
(let ([var-bindings
|
||||||
|
(map
|
||||||
|
(lambda (var)
|
||||||
|
(and (let ([v (syntax-local-value var (lambda () #f))])
|
||||||
|
(and (if s-exp?
|
||||||
|
(s-exp-pattern-variable? v)
|
||||||
|
(syntax-pattern-variable? v))
|
||||||
|
v))))
|
||||||
|
unique-vars)])
|
||||||
|
(if (and (or (null? var-bindings)
|
||||||
|
(not (ormap (lambda (x) x) var-bindings)))
|
||||||
|
(no-ellipses? pattern))
|
||||||
|
;; Constant template:
|
||||||
|
(list (if s-exp?
|
||||||
|
(quote-syntax quote)
|
||||||
|
(quote-syntax quote-syntax))
|
||||||
|
pattern)
|
||||||
|
;; Non-constant:
|
||||||
|
(let ([proto-r (let loop ([vars unique-vars][bindings var-bindings])
|
||||||
|
(if (null? bindings)
|
||||||
|
null
|
||||||
|
(let ([rest (loop (cdr vars)
|
||||||
|
(cdr bindings))])
|
||||||
|
(if (car bindings)
|
||||||
|
(cons (let loop ([v (car vars)]
|
||||||
|
[d (if s-exp?
|
||||||
|
(s-exp-mapping-depth (car bindings))
|
||||||
|
(syntax-mapping-depth (car bindings)))])
|
||||||
|
(if (zero? d)
|
||||||
|
v
|
||||||
|
(loop (list v) (sub1 d))))
|
||||||
|
rest)
|
||||||
|
rest))))]
|
||||||
|
[non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings])
|
||||||
|
(if (null? bindings)
|
||||||
|
null
|
||||||
|
(let ([rest (loop (cdr vars)
|
||||||
|
(cdr bindings))])
|
||||||
|
(if (car bindings)
|
||||||
|
rest
|
||||||
|
(cons (car vars) rest)))))])
|
||||||
|
(let ([build-from-template
|
||||||
|
;; Even if we don't use the builder, we need to check
|
||||||
|
;; for a well-formed pattern:
|
||||||
|
(make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)]
|
||||||
|
[r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss])
|
||||||
|
(cond
|
||||||
|
[(null? bindings) null]
|
||||||
|
[(car bindings)
|
||||||
|
(cons
|
||||||
|
(syntax-property
|
||||||
|
(let ([id (if s-exp?
|
||||||
|
(s-exp-mapping-valvar (car bindings))
|
||||||
|
(syntax-mapping-valvar (car bindings)))])
|
||||||
|
(datum->syntax
|
||||||
|
id
|
||||||
|
(syntax-e id)
|
||||||
|
x))
|
||||||
|
'disappeared-use
|
||||||
|
(map syntax-local-introduce (car all-varss)))
|
||||||
|
(loop (cdr vars) (cdr bindings) (cdr all-varss)))]
|
||||||
|
[else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))])
|
||||||
|
(if (identifier? pattern)
|
||||||
|
;; Simple syntax-id lookup:
|
||||||
|
(car r)
|
||||||
|
;; General case:
|
||||||
|
(list (datum->syntax
|
||||||
|
here-stx
|
||||||
|
build-from-template
|
||||||
|
pattern)
|
||||||
|
(let ([len (length r)])
|
||||||
|
(cond
|
||||||
|
[(zero? len) (quote-syntax ())]
|
||||||
|
[(= len 1) (car r)]
|
||||||
|
[else
|
||||||
|
(cons (quote-syntax list*) r)]))))))))))
|
||||||
|
x)))))
|
||||||
|
|
||||||
|
(-define-syntax syntax (lambda (stx) (gen-template stx #f)))
|
||||||
|
(-define-syntax datum (lambda (stx) (gen-template stx #t)))
|
||||||
|
|
||||||
|
(#%provide (all-from "ellipses.rkt") syntax-case** syntax datum
|
||||||
|
(for-syntax syntax-pattern-variable?)))
|
||||||
80
case/stxloc.rkt
Normal file
80
case/stxloc.rkt
Normal file
|
|
@ -0,0 +1,80 @@
|
||||||
|
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
;; syntax/loc
|
||||||
|
|
||||||
|
(module stxloc '#%kernel
|
||||||
|
(#%require "qq-and-or.rkt" "stxcase.rkt" "define-et-al.rkt"
|
||||||
|
(for-syntax '#%kernel "stxcase.rkt" "sc.rkt"))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-values (transform-to-syntax-case**)
|
||||||
|
(lambda (stx sc arg-is-stx? expr kws lit-comp s-exp? clauses)
|
||||||
|
((λ (ans) (datum->syntax #'here ans stx))
|
||||||
|
(list* 'syntax-case** sc arg-is-stx? expr kws lit-comp s-exp?
|
||||||
|
clauses)))))
|
||||||
|
|
||||||
|
;; Like regular syntax-case, but with free-identifier=? replacement
|
||||||
|
(-define-syntax syntax-case*
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case** #f #t stx () free-identifier=? #f
|
||||||
|
[(sc stxe kl id=? . clause)
|
||||||
|
(transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'id=? #f #'clause)])))
|
||||||
|
|
||||||
|
;; Regular syntax-case
|
||||||
|
(-define-syntax syntax-case
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case** #f #t stx () free-identifier=? #f
|
||||||
|
[(sc stxe kl . clause)
|
||||||
|
(transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'free-identifier=? #f
|
||||||
|
#'clause)])))
|
||||||
|
|
||||||
|
;; Like `syntax-case, but on plain datums
|
||||||
|
(-define-syntax datum-case
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case** #f #t stx () free-identifier=? #f
|
||||||
|
[(sc stxe kl . clause)
|
||||||
|
(transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)])))
|
||||||
|
|
||||||
|
(-define (relocate loc stx)
|
||||||
|
(if (or (syntax-source loc)
|
||||||
|
(syntax-position loc))
|
||||||
|
(datum->syntax stx
|
||||||
|
(syntax-e stx)
|
||||||
|
loc
|
||||||
|
stx)
|
||||||
|
stx))
|
||||||
|
|
||||||
|
;; Like syntax, but also takes a syntax object
|
||||||
|
;; that supplies a source location for the
|
||||||
|
;; resulting syntax object.
|
||||||
|
(-define-syntax syntax/loc
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case** #f #t stx () free-identifier=? #f
|
||||||
|
[(_ loc pattern)
|
||||||
|
(if (if (symbol? (syntax-e #'pattern))
|
||||||
|
(syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f)))
|
||||||
|
#f)
|
||||||
|
(syntax (syntax pattern))
|
||||||
|
(syntax (relocate loc (syntax pattern))))])))
|
||||||
|
|
||||||
|
(-define-syntax quote-syntax/prune
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case** #f #t stx () free-identifier=? #f
|
||||||
|
[(_ id)
|
||||||
|
(if (symbol? (syntax-e #'id))
|
||||||
|
(datum->syntax #'here
|
||||||
|
(list (quote-syntax quote-syntax)
|
||||||
|
(identifier-prune-lexical-context (syntax id)
|
||||||
|
(list
|
||||||
|
(syntax-e (syntax id))
|
||||||
|
'#%top)))
|
||||||
|
stx
|
||||||
|
#f
|
||||||
|
stx)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"expected an identifier"
|
||||||
|
stx
|
||||||
|
#'id))])))
|
||||||
|
|
||||||
|
(#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _))
|
||||||
208
case/syntax.rkt
Normal file
208
case/syntax.rkt
Normal file
|
|
@ -0,0 +1,208 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require (for-syntax racket/base
|
||||||
|
racket/private/sc))
|
||||||
|
(provide define/with-syntax
|
||||||
|
|
||||||
|
current-recorded-disappeared-uses
|
||||||
|
with-disappeared-uses
|
||||||
|
syntax-local-value/record
|
||||||
|
record-disappeared-uses
|
||||||
|
|
||||||
|
format-symbol
|
||||||
|
format-id
|
||||||
|
|
||||||
|
current-syntax-context
|
||||||
|
wrong-syntax
|
||||||
|
|
||||||
|
generate-temporary
|
||||||
|
internal-definition-context-apply
|
||||||
|
syntax-local-eval
|
||||||
|
with-syntax*)
|
||||||
|
|
||||||
|
;; == Defining pattern variables ==
|
||||||
|
|
||||||
|
(define-syntax (define/with-syntax stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(define/with-syntax pattern rhs)
|
||||||
|
(let* ([pvar-env (get-match-vars #'define/with-syntax
|
||||||
|
stx
|
||||||
|
#'pattern
|
||||||
|
'())]
|
||||||
|
[depthmap (for/list ([x pvar-env])
|
||||||
|
(let loop ([x x] [d 0])
|
||||||
|
(if (pair? x)
|
||||||
|
(loop (car x) (add1 d))
|
||||||
|
(cons x d))))]
|
||||||
|
[pvars (map car depthmap)]
|
||||||
|
[depths (map cdr depthmap)]
|
||||||
|
[mark (make-syntax-introducer)])
|
||||||
|
(with-syntax ([(pvar ...) pvars]
|
||||||
|
[(depth ...) depths]
|
||||||
|
[(valvar ...) (generate-temporaries pvars)])
|
||||||
|
#'(begin (define-values (valvar ...)
|
||||||
|
(with-syntax ([pattern rhs])
|
||||||
|
(values (pvar-value pvar) ...)))
|
||||||
|
(define-syntax pvar
|
||||||
|
(make-syntax-mapping 'depth (quote-syntax valvar)))
|
||||||
|
...)))]))
|
||||||
|
;; Ryan: alternative name: define/syntax-pattern ??
|
||||||
|
|
||||||
|
;; auxiliary macro
|
||||||
|
(define-syntax (pvar-value stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ pvar)
|
||||||
|
(identifier? #'pvar)
|
||||||
|
(let ([mapping (syntax-local-value #'pvar)])
|
||||||
|
(unless (syntax-pattern-variable? mapping)
|
||||||
|
(raise-syntax-error #f "not a pattern variable" #'pvar))
|
||||||
|
(syntax-mapping-valvar mapping))]))
|
||||||
|
|
||||||
|
|
||||||
|
;; == Disappeared uses ==
|
||||||
|
|
||||||
|
(define current-recorded-disappeared-uses (make-parameter #f))
|
||||||
|
|
||||||
|
(define-syntax-rule (with-disappeared-uses body-expr ... stx-expr)
|
||||||
|
(let-values ([(stx disappeared-uses)
|
||||||
|
(parameterize ((current-recorded-disappeared-uses null))
|
||||||
|
(let ([result (let () body-expr ... stx-expr)])
|
||||||
|
(values result (current-recorded-disappeared-uses))))])
|
||||||
|
(syntax-property stx
|
||||||
|
'disappeared-use
|
||||||
|
(append (or (syntax-property stx 'disappeared-use) null)
|
||||||
|
disappeared-uses))))
|
||||||
|
|
||||||
|
(define (syntax-local-value/record id pred)
|
||||||
|
(unless (identifier? id)
|
||||||
|
(raise-argument-error 'syntax-local-value/record
|
||||||
|
"identifier?"
|
||||||
|
0 id pred))
|
||||||
|
(unless (and (procedure? pred)
|
||||||
|
(procedure-arity-includes? pred 1))
|
||||||
|
(raise-argument-error 'syntax-local-value/record
|
||||||
|
"(-> any/c boolean?)"
|
||||||
|
1 id pred))
|
||||||
|
(let ([value (syntax-local-value id (lambda () #f))])
|
||||||
|
(and (pred value)
|
||||||
|
(begin (record-disappeared-uses (list id))
|
||||||
|
value))))
|
||||||
|
|
||||||
|
(define (record-disappeared-uses ids)
|
||||||
|
(cond
|
||||||
|
[(identifier? ids) (record-disappeared-uses (list ids))]
|
||||||
|
[(and (list? ids) (andmap identifier? ids))
|
||||||
|
(let ([uses (current-recorded-disappeared-uses)])
|
||||||
|
(when uses
|
||||||
|
(current-recorded-disappeared-uses
|
||||||
|
(append
|
||||||
|
(if (syntax-transforming?)
|
||||||
|
(map syntax-local-introduce ids)
|
||||||
|
ids)
|
||||||
|
uses))))]
|
||||||
|
[else (raise-argument-error 'record-disappeared-uses
|
||||||
|
"(or/c identifier? (listof identifier?))"
|
||||||
|
ids)]))
|
||||||
|
|
||||||
|
|
||||||
|
;; == Identifier formatting ==
|
||||||
|
|
||||||
|
(define (format-id lctx
|
||||||
|
#:source [src #f]
|
||||||
|
#:props [props #f]
|
||||||
|
#:cert [cert #f]
|
||||||
|
fmt . args)
|
||||||
|
(define (convert x) (->atom x 'format-id))
|
||||||
|
(check-restricted-format-string 'format-id fmt)
|
||||||
|
(let* ([args (map convert args)]
|
||||||
|
[str (apply format fmt args)]
|
||||||
|
[sym (string->symbol str)])
|
||||||
|
(datum->syntax lctx sym src props cert)))
|
||||||
|
;; Eli: This looks very *useful*, but I'd like to see it more convenient to
|
||||||
|
;; "preserve everything". Maybe add a keyword argument that when #t makes
|
||||||
|
;; all the others use values lctx, and when syntax makes the others use that
|
||||||
|
;; syntax?
|
||||||
|
;; Finally, if you get to add this, then another useful utility in the same
|
||||||
|
;; spirit is one that concatenates symbols and/or strings and/or identifiers
|
||||||
|
;; into a new identifier. I considered something like that, which expects a
|
||||||
|
;; single syntax among its inputs, and will use it for the context etc, or
|
||||||
|
;; throw an error if there's more or less than 1.
|
||||||
|
|
||||||
|
(define (format-symbol fmt . args)
|
||||||
|
(define (convert x) (->atom x 'format-symbol))
|
||||||
|
(check-restricted-format-string 'format-symbol fmt)
|
||||||
|
(let ([args (map convert args)])
|
||||||
|
(string->symbol (apply format fmt args))))
|
||||||
|
|
||||||
|
(define (restricted-format-string? fmt)
|
||||||
|
(regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt))
|
||||||
|
|
||||||
|
(define (check-restricted-format-string who fmt)
|
||||||
|
(unless (restricted-format-string? fmt)
|
||||||
|
(raise-arguments-error who
|
||||||
|
(format "format string should have ~a placeholders"
|
||||||
|
fmt)
|
||||||
|
"format string" fmt)))
|
||||||
|
|
||||||
|
(define (->atom x err)
|
||||||
|
(cond [(string? x) x]
|
||||||
|
[(symbol? x) x]
|
||||||
|
[(identifier? x) (syntax-e x)]
|
||||||
|
[(keyword? x) (keyword->string x)]
|
||||||
|
[(number? x) x]
|
||||||
|
[(char? x) x]
|
||||||
|
[else (raise-argument-error err
|
||||||
|
"(or/c string? symbol? identifier? keyword? char? number?)"
|
||||||
|
x)]))
|
||||||
|
|
||||||
|
|
||||||
|
;; == Error reporting ==
|
||||||
|
|
||||||
|
(define current-syntax-context
|
||||||
|
(make-parameter #f
|
||||||
|
(lambda (new-value)
|
||||||
|
(unless (or (syntax? new-value) (eq? new-value #f))
|
||||||
|
(raise-argument-error 'current-syntax-context
|
||||||
|
"(or/c syntax? #f)"
|
||||||
|
new-value))
|
||||||
|
new-value)))
|
||||||
|
|
||||||
|
(define (wrong-syntax stx #:extra [extras null] format-string . args)
|
||||||
|
(unless (or (eq? stx #f) (syntax? stx))
|
||||||
|
(raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args)))
|
||||||
|
(let* ([ctx (current-syntax-context)]
|
||||||
|
[blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))])
|
||||||
|
(raise-syntax-error (if (symbol? blame) blame #f)
|
||||||
|
(apply format format-string args)
|
||||||
|
ctx
|
||||||
|
stx
|
||||||
|
extras)))
|
||||||
|
;; Eli: The `report-error-as' thing seems arbitrary to me.
|
||||||
|
|
||||||
|
|
||||||
|
;; == Other utilities ==
|
||||||
|
|
||||||
|
;; generate-temporary : any -> identifier
|
||||||
|
(define (generate-temporary [stx 'g])
|
||||||
|
(car (generate-temporaries (list stx))))
|
||||||
|
|
||||||
|
;; Applies the renaming of intdefs to stx.
|
||||||
|
(define (internal-definition-context-apply intdefs stx)
|
||||||
|
(let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)])
|
||||||
|
(with-syntax ([(q astx) qastx]) #'astx)))
|
||||||
|
|
||||||
|
(define (syntax-local-eval stx [intdef0 #f])
|
||||||
|
(let* ([name (generate-temporary)]
|
||||||
|
[intdefs (syntax-local-make-definition-context intdef0)])
|
||||||
|
(syntax-local-bind-syntaxes (list name)
|
||||||
|
#`(call-with-values (lambda () #,stx) list)
|
||||||
|
intdefs)
|
||||||
|
(internal-definition-context-seal intdefs)
|
||||||
|
(apply values
|
||||||
|
(syntax-local-value (internal-definition-context-apply intdefs name)
|
||||||
|
#f intdefs))))
|
||||||
|
|
||||||
|
(define-syntax (with-syntax* stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ (cl) body ...) #'(with-syntax (cl) body ...)]
|
||||||
|
[(_ (cl cls ...) body ...)
|
||||||
|
#'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
|
||||||
99
case/with-stx.rkt
Normal file
99
case/with-stx.rkt
Normal file
|
|
@ -0,0 +1,99 @@
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
;; with-syntax, generate-temporaries
|
||||||
|
|
||||||
|
(module with-stx '#%kernel
|
||||||
|
(#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt"
|
||||||
|
(for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt"
|
||||||
|
"sc.rkt" "qq-and-or.rkt" "cond.rkt"))
|
||||||
|
|
||||||
|
(-define (with-syntax-fail stx)
|
||||||
|
(raise-syntax-error
|
||||||
|
'with-syntax
|
||||||
|
"binding match failed"
|
||||||
|
stx))
|
||||||
|
|
||||||
|
(-define (with-datum-fail stx)
|
||||||
|
(raise-syntax-error
|
||||||
|
'with-datum
|
||||||
|
"binding match failed"
|
||||||
|
stx))
|
||||||
|
|
||||||
|
;; Partly from Dybvig
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-values (gen-with-syntax)
|
||||||
|
(let ([here-stx (quote-syntax here)])
|
||||||
|
(lambda (x s-exp?)
|
||||||
|
(syntax-case x ()
|
||||||
|
((_ () e1 e2 ...)
|
||||||
|
(syntax/loc x (begin e1 e2 ...)))
|
||||||
|
((_ ((out in) ...) e1 e2 ...)
|
||||||
|
(let ([ins (syntax->list (syntax (in ...)))])
|
||||||
|
;; Check for duplicates or other syntax errors:
|
||||||
|
(get-match-vars (syntax _) x (syntax (out ...)) null)
|
||||||
|
;; Generate temps and contexts:
|
||||||
|
(let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)]
|
||||||
|
[heres (map (lambda (x)
|
||||||
|
(datum->syntax
|
||||||
|
x
|
||||||
|
'here
|
||||||
|
x))
|
||||||
|
ins)]
|
||||||
|
[outs (syntax->list (syntax (out ...)))])
|
||||||
|
;; Let-bind RHSs, then build up nested syntax-cases:
|
||||||
|
(datum->syntax
|
||||||
|
here-stx
|
||||||
|
`(let ,(map (lambda (tmp here in)
|
||||||
|
`[,tmp ,(if s-exp?
|
||||||
|
in
|
||||||
|
`(datum->syntax
|
||||||
|
(quote-syntax ,here)
|
||||||
|
,in))])
|
||||||
|
tmps heres ins)
|
||||||
|
,(let loop ([tmps tmps][outs outs])
|
||||||
|
(cond
|
||||||
|
[(null? tmps)
|
||||||
|
(syntax (begin e1 e2 ...))]
|
||||||
|
[else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp?
|
||||||
|
[,(car outs) ,(loop (cdr tmps)
|
||||||
|
(cdr outs))]
|
||||||
|
[_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail)
|
||||||
|
;; Minimize the syntax structure we keep:
|
||||||
|
(quote-syntax ,(datum->syntax
|
||||||
|
#f
|
||||||
|
(syntax->datum (car outs))
|
||||||
|
(car outs))))])])))
|
||||||
|
x)))))))))
|
||||||
|
|
||||||
|
(-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f)))
|
||||||
|
(-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t)))
|
||||||
|
|
||||||
|
(-define counter 0)
|
||||||
|
(-define (append-number s)
|
||||||
|
(set! counter (add1 counter))
|
||||||
|
(string->symbol (format "~a~s" s counter)))
|
||||||
|
|
||||||
|
(-define (generate-temporaries sl)
|
||||||
|
(unless (stx-list? sl)
|
||||||
|
(raise-argument-error
|
||||||
|
'generate-temporaries
|
||||||
|
"(or/c list? syntax->list)"
|
||||||
|
sl))
|
||||||
|
(let ([l (stx->list sl)])
|
||||||
|
(map (lambda (x)
|
||||||
|
((make-syntax-introducer)
|
||||||
|
(cond
|
||||||
|
[(symbol? x)
|
||||||
|
(datum->syntax #f (append-number x))]
|
||||||
|
[(string? x)
|
||||||
|
(datum->syntax #f (append-number x))]
|
||||||
|
[(keyword? x)
|
||||||
|
(datum->syntax #f (append-number (keyword->string x)))]
|
||||||
|
[(identifier? x)
|
||||||
|
(datum->syntax #f (append-number (syntax-e x)))]
|
||||||
|
[(and (syntax? x) (keyword? (syntax-e x)))
|
||||||
|
(datum->syntax #f (append-number (keyword->string (syntax-e x))))]
|
||||||
|
[else
|
||||||
|
(datum->syntax #f (append-number 'temp))])))
|
||||||
|
l)))
|
||||||
|
|
||||||
|
(#%provide with-syntax with-datum generate-temporaries))
|
||||||
Loading…
Reference in New Issue
Block a user