Moved files around to get the original directory structure
This commit is contained in:
Suzanne Soy
parent
c725ad4265
commit
34fa88001a
77
6-12/racket/collects/racket/private/stxcase-scheme.rkt
Normal file
77
6-12/racket/collects/racket/private/stxcase-scheme.rkt
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
|
||||
;;----------------------------------------------------------------------
|
||||
;; #%stxcase-scheme: adds let-syntax, syntax-rules, and
|
||||
;; check-duplicate-identifier, and assembles everything we have so far
|
||||
|
||||
(module stxcase-scheme '#%kernel
|
||||
(#%require racket/private/small-scheme racket/private/stx "stxcase.rkt"
|
||||
"with-stx.rkt" racket/private/stxloc
|
||||
(for-syntax '#%kernel racket/private/small-scheme
|
||||
racket/private/stx "stxcase.rkt"
|
||||
racket/private/stxloc))
|
||||
|
||||
(-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 racket/private/stxloc)
|
||||
check-duplicate-identifier syntax-protect
|
||||
syntax-rules syntax-id-rules
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
610
6-12/racket/collects/racket/private/stxcase.rkt
Normal file
610
6-12/racket/collects/racket/private/stxcase.rkt
Normal file
|
|
@ -0,0 +1,610 @@
|
|||
;;----------------------------------------------------------------------
|
||||
;; syntax-case and syntax
|
||||
|
||||
(module stxcase '#%kernel
|
||||
(#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
|
||||
racket/private/ellipses
|
||||
stxparse-info/current-pvars
|
||||
(for-syntax racket/private/stx racket/private/small-scheme
|
||||
racket/private/member racket/private/sc '#%kernel
|
||||
auto-syntax-e/utils))
|
||||
|
||||
(-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-auto-pvar))
|
||||
;; 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
|
||||
(list (quote-syntax with-pvars)
|
||||
pattern-vars
|
||||
answer)
|
||||
do-try-next)
|
||||
(list (quote-syntax with-pvars)
|
||||
pattern-vars
|
||||
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 racket/private/ellipses) syntax-case** syntax datum
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
80
6-12/racket/collects/racket/private/stxloc.rkt
Normal file
80
6-12/racket/collects/racket/private/stxloc.rkt
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
|
||||
;;----------------------------------------------------------------------
|
||||
;; syntax/loc
|
||||
|
||||
(module stxloc '#%kernel
|
||||
(#%require racket/private/qq-and-or "stxcase.rkt" racket/private/define-et-al
|
||||
(for-syntax '#%kernel "stxcase.rkt" racket/private/sc))
|
||||
|
||||
(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 ... _))
|
||||
212
6-12/racket/collects/racket/private/syntax.rkt
Normal file
212
6-12/racket/collects/racket/private/syntax.rkt
Normal file
|
|
@ -0,0 +1,212 @@
|
|||
#lang racket/base
|
||||
(require (only-in "stxloc.rkt" syntax-case)
|
||||
stxparse-info/current-pvars
|
||||
(for-syntax racket/base
|
||||
racket/private/sc
|
||||
auto-syntax-e/utils))
|
||||
(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-auto-pvar 'depth (quote-syntax valvar)))
|
||||
...
|
||||
(define-pvars pvar ...))))]))
|
||||
;; 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 ...))]))
|
||||
100
6-12/racket/collects/racket/private/with-stx.rkt
Normal file
100
6-12/racket/collects/racket/private/with-stx.rkt
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
;;----------------------------------------------------------------------
|
||||
;; with-syntax, generate-temporaries
|
||||
|
||||
(module with-stx '#%kernel
|
||||
(#%require racket/private/stx racket/private/small-scheme "stxcase.rkt"
|
||||
(for-syntax '#%kernel racket/private/stx "stxcase.rkt"
|
||||
racket/private/stxloc racket/private/sc
|
||||
racket/private/qq-and-or racket/private/cond))
|
||||
|
||||
(-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))
|
||||
31
6-12/racket/collects/syntax/parse.rkt
Normal file
31
6-12/racket/collects/syntax/parse.rkt
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/contract/base
|
||||
"parse/pre.rkt"
|
||||
"parse/experimental/provide.rkt"
|
||||
"parse/experimental/contract.rkt")
|
||||
(provide (except-out (all-from-out "parse/pre.rkt")
|
||||
static)
|
||||
expr/c)
|
||||
(provide-syntax-class/contract
|
||||
[static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])])
|
||||
|
||||
(begin-for-syntax
|
||||
(require racket/contract/base
|
||||
syntax/parse/private/residual-ct)
|
||||
(provide pattern-expander?
|
||||
(contract-out
|
||||
[pattern-expander
|
||||
(-> (-> syntax? syntax?) pattern-expander?)]
|
||||
[prop:pattern-expander
|
||||
(struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
|
||||
[syntax-local-syntax-parse-pattern-introduce
|
||||
(-> syntax? syntax?)]))
|
||||
|
||||
(require (only-in (for-template syntax/parse) pattern-expander))
|
||||
#;(define pattern-expander
|
||||
(let ()
|
||||
#;(struct pattern-expander (proc) #:transparent
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:pattern-expander (λ (this) (pattern-expander-proc this)))
|
||||
pattern-expander)))
|
||||
40
6-12/racket/collects/syntax/parse/experimental/contract.rkt
Normal file
40
6-12/racket/collects/syntax/parse/experimental/contract.rkt
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket/base
|
||||
(require stxparse-info/parse/pre
|
||||
"provide.rkt"
|
||||
syntax/contract
|
||||
(only-in stxparse-info/parse/private/residual ;; keep abs. path
|
||||
this-context-syntax
|
||||
this-role)
|
||||
racket/contract/base)
|
||||
|
||||
(define not-given (gensym))
|
||||
|
||||
(define-syntax-class (expr/c ctc-stx
|
||||
#:positive [pos-blame 'use-site]
|
||||
#:negative [neg-blame 'from-macro]
|
||||
#:macro [macro-name #f]
|
||||
#:name [expr-name not-given]
|
||||
#:context [ctx #f])
|
||||
#:attributes (c)
|
||||
#:commit
|
||||
(pattern y:expr
|
||||
#:with
|
||||
c (wrap-expr/c ctc-stx
|
||||
#'y
|
||||
#:positive pos-blame
|
||||
#:negative neg-blame
|
||||
#:name (if (eq? expr-name not-given)
|
||||
this-role
|
||||
expr-name)
|
||||
#:macro macro-name
|
||||
#:context (or ctx (this-context-syntax)))))
|
||||
|
||||
(provide-syntax-class/contract
|
||||
[expr/c (syntax-class/c (syntax?)
|
||||
(#:positive (or/c syntax? string? module-path-index?
|
||||
'from-macro 'use-site 'unknown)
|
||||
#:negative (or/c syntax? string? module-path-index?
|
||||
'from-macro 'use-site 'unknown)
|
||||
#:name (or/c identifier? string? symbol? #f)
|
||||
#:macro (or/c identifier? string? symbol? #f)
|
||||
#:context (or/c syntax? #f)))])
|
||||
430
6-12/racket/collects/syntax/parse/private/opt.rkt
Normal file
430
6-12/racket/collects/syntax/parse/private/opt.rkt
Normal file
|
|
@ -0,0 +1,430 @@
|
|||
#lang racket/base
|
||||
(require racket/syntax
|
||||
racket/pretty
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
syntax/parse/private/minimatch
|
||||
syntax/parse/private/rep-patterns
|
||||
syntax/parse/private/kws)
|
||||
(provide (struct-out pk1)
|
||||
(rename-out [optimize-matrix0 optimize-matrix]))
|
||||
|
||||
;; controls debugging output for optimization successes and failures
|
||||
(define DEBUG-OPT-SUCCEED #f)
|
||||
(define DEBUG-OPT-FAIL #f)
|
||||
|
||||
;; ----
|
||||
|
||||
;; A Matrix is a (listof PK) where each PK has same number of columns
|
||||
;; A PK is one of
|
||||
;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix
|
||||
;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out
|
||||
;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded
|
||||
;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded
|
||||
(struct pk1 (patterns k) #:prefab)
|
||||
(struct pk/same (pattern inner) #:prefab)
|
||||
(struct pk/pair (inner) #:prefab)
|
||||
(struct pk/and (inner) #:prefab)
|
||||
|
||||
(define (pk-columns pk)
|
||||
(match pk
|
||||
[(pk1 patterns k) (length patterns)]
|
||||
[(pk/same p inner) (add1 (pk-columns inner))]
|
||||
[(pk/pair inner) (sub1 (pk-columns inner))]
|
||||
[(pk/and inner) (sub1 (pk-columns inner))]))
|
||||
|
||||
;; Can factor pattern P given clauses like
|
||||
;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
|
||||
;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ]
|
||||
; [ P PN ... | eN] [ | [PN ... | eN] ]
|
||||
;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking)
|
||||
|
||||
;; Can unfold pair patterns as follows:
|
||||
;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
|
||||
;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ]
|
||||
;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
|
||||
|
||||
;; Can unfold ~and patterns similarly; ~and patterns can hide
|
||||
;; factoring opportunities.
|
||||
|
||||
;; ----
|
||||
|
||||
(define (optimize-matrix0 rows)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
|
||||
(eprintf "\n%% optimizing (~s):\n" (length rows))
|
||||
(pretty-write (matrix->sexpr rows) (current-error-port)))
|
||||
(define result (optimize-matrix rows))
|
||||
(define then (current-inexact-milliseconds))
|
||||
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
|
||||
(cond [(= (length result) (length rows))
|
||||
(eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
|
||||
[else
|
||||
(eprintf "==> (~s ms)\n" (floor (- then now)))
|
||||
(pretty-write (matrix->sexpr result) (current-error-port))
|
||||
(eprintf "\n")]))
|
||||
result)
|
||||
|
||||
;; optimize-matrix : (listof pk1) -> Matrix
|
||||
(define (optimize-matrix rows)
|
||||
(cond [(null? rows) null]
|
||||
[(null? (cdr rows)) rows] ;; no opportunities for 1 row
|
||||
[(null? (pk1-patterns (car rows))) rows]
|
||||
[else
|
||||
;; first unfold and-patterns
|
||||
(let-values ([(col1 col2)
|
||||
(for/lists (col1 col2) ([row (in-list rows)])
|
||||
(unfold-and (car (pk1-patterns row)) null))])
|
||||
(cond [(ormap pair? col2)
|
||||
(list
|
||||
(pk/and
|
||||
(optimize-matrix*
|
||||
(for/list ([row (in-list rows)]
|
||||
[col1 (in-list col1)]
|
||||
[col2 (in-list col2)])
|
||||
(pk1 (list* col1
|
||||
(make-and-pattern col2)
|
||||
(cdr (pk1-patterns row)))
|
||||
(pk1-k row))))))]
|
||||
[else (optimize-matrix* rows)]))]))
|
||||
|
||||
;; optimize-matrix* : (listof pk1) -> Matrix
|
||||
;; The matrix is nonempty, and first column has no unfoldable pat:and.
|
||||
;; Split into submatrixes (sequences of rows) starting with similar patterns,
|
||||
;; handle according to similarity, then recursively optimize submatrixes.
|
||||
(define (optimize-matrix* rows)
|
||||
(define row1 (car rows))
|
||||
(define pat1 (car (pk1-patterns row1)))
|
||||
(define k1 (pk1-k row1))
|
||||
;; Now accumulate rows starting with patterns like pat1
|
||||
(define-values (like? combine) (pattern->partitioner pat1))
|
||||
(let loop ([rows (cdr rows)] [rrows (list row1)])
|
||||
(cond [(null? rows)
|
||||
(cons (combine (reverse rrows)) null)]
|
||||
[else
|
||||
(define row1 (car rows))
|
||||
(define pat1 (car (pk1-patterns row1)))
|
||||
(cond [(like? pat1)
|
||||
(loop (cdr rows) (cons row1 rrows))]
|
||||
[else
|
||||
(cons (combine (reverse rrows))
|
||||
(optimize-matrix* rows))])])))
|
||||
|
||||
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
|
||||
(define (pattern->partitioner pat1)
|
||||
(match pat1
|
||||
[(pat:pair head tail)
|
||||
(values (lambda (p) (pat:pair? p))
|
||||
(lambda (rows)
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
|
||||
(cond [(> (length rows) 1)
|
||||
(pk/pair (optimize-matrix
|
||||
(for/list ([row (in-list rows)])
|
||||
(let* ([patterns (pk1-patterns row)]
|
||||
[pat1 (car patterns)])
|
||||
(pk1 (list* (pat:pair-head pat1)
|
||||
(pat:pair-tail pat1)
|
||||
(cdr patterns))
|
||||
(pk1-k row))))))]
|
||||
[else (car rows)])))]
|
||||
[(? pattern-factorable?)
|
||||
(values (lambda (pat2) (pattern-equal? pat1 pat2))
|
||||
(lambda (rows)
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
|
||||
(cond [(> (length rows) 1)
|
||||
(pk/same pat1
|
||||
(optimize-matrix
|
||||
(for/list ([row (in-list rows)])
|
||||
(pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
|
||||
[else (car rows)])))]
|
||||
[_
|
||||
(values (lambda (pat2)
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (pattern-equal? pat1 pat2)
|
||||
(eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2))))
|
||||
#f)
|
||||
(lambda (rows)
|
||||
;; (length rows) = 1
|
||||
(car rows)))]))
|
||||
|
||||
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
|
||||
(define (unfold-and p onto)
|
||||
(match p
|
||||
[(pat:and subpatterns)
|
||||
;; pat:and is worth unfolding if first subpattern is not pat:action
|
||||
;; if first subpattern is also pat:and, keep unfolding
|
||||
(let* ([first-sub (car subpatterns)]
|
||||
[rest-subs (cdr subpatterns)])
|
||||
(cond [(not (pat:action? first-sub))
|
||||
(when #f ;; DEBUG-OPT-SUCCEED
|
||||
(eprintf ">> unfolding: ~e\n" p))
|
||||
(unfold-and first-sub (*append rest-subs onto))]
|
||||
[else (values p onto)]))]
|
||||
[_ (values p onto)]))
|
||||
|
||||
(define (pattern-factorable? p)
|
||||
;; Can factor out p if p can succeed at most once, does not cut
|
||||
;; - if p can succeed multiple times, then factoring changes success order
|
||||
;; - if p can cut, then factoring changes which choice points are discarded (too few)
|
||||
(match p
|
||||
[(pat:any) #t]
|
||||
[(pat:svar _n) #t]
|
||||
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
|
||||
;; commit? implies delimit-cut
|
||||
commit?]
|
||||
[(? pat:integrated?) #t]
|
||||
[(pat:literal _lit _ip _lp) #t]
|
||||
[(pat:datum _datum) #t]
|
||||
[(pat:action _act _pat) #f]
|
||||
[(pat:head head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:dots heads tail)
|
||||
;; Conservative approximation for common case: one head pattern
|
||||
;; In general, check if heads don't overlap, don't overlap with tail.
|
||||
(and (= (length heads) 1)
|
||||
(let ([head (car heads)])
|
||||
(and (pattern-factorable? head)))
|
||||
(equal? tail (pat:datum '())))]
|
||||
[(pat:and patterns)
|
||||
(andmap pattern-factorable? patterns)]
|
||||
[(pat:or patterns) #f]
|
||||
[(pat:not pattern) #f] ;; FIXME: ?
|
||||
[(pat:pair head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:vector pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:box pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:pstruct key pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:describe pattern _desc _trans _role)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:delimit pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:commit pattern) #t]
|
||||
[(? pat:reflect?) #f]
|
||||
[(pat:ord pattern _ _)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:post pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
;; ----
|
||||
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
|
||||
commit?]
|
||||
[(hpat:seq inner)
|
||||
(pattern-factorable? inner)]
|
||||
[(hpat:commit inner) #t]
|
||||
;; ----
|
||||
[(ehpat head repc)
|
||||
(and (equal? repc #f)
|
||||
(pattern-factorable? head))]
|
||||
;; ----
|
||||
[else #f]))
|
||||
|
||||
(define (subpatterns-equal? as bs)
|
||||
(and (= (length as) (length bs))
|
||||
(for/and ([a (in-list as)]
|
||||
[b (in-list bs)])
|
||||
(pattern-equal? a b))))
|
||||
|
||||
(define (pattern-equal? a b)
|
||||
(define result
|
||||
(cond [(and (pat:any? a) (pat:any? b)) #t]
|
||||
[(and (pat:svar? a) (pat:svar? b))
|
||||
(bound-identifier=? (pat:svar-name a) (pat:svar-name b))]
|
||||
[(and (pat:var/p? a) (pat:var/p? b))
|
||||
(and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
|
||||
(bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b))
|
||||
(equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b))
|
||||
(equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
|
||||
(expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
|
||||
[(and (pat:integrated? a) (pat:integrated? b))
|
||||
(and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b))
|
||||
(free-identifier=? (pat:integrated-predicate a)
|
||||
(pat:integrated-predicate b))
|
||||
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
|
||||
[(and (pat:literal? a) (pat:literal? b))
|
||||
;; literals are hard to compare, so compare gensyms attached to
|
||||
;; literal ids (see rep.rkt) instead
|
||||
(let ([ka (syntax-property (pat:literal-id a) 'literal)]
|
||||
[kb (syntax-property (pat:literal-id b) 'literal)])
|
||||
(and ka kb (eq? ka kb)))]
|
||||
[(and (pat:datum? a) (pat:datum? b))
|
||||
(equal? (pat:datum-datum a)
|
||||
(pat:datum-datum b))]
|
||||
[(and (pat:head? a) (pat:head? b))
|
||||
(and (pattern-equal? (pat:head-head a) (pat:head-head b))
|
||||
(pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
|
||||
[(and (pat:dots? a) (pat:dots? b))
|
||||
(and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
|
||||
(pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
|
||||
[(and (pat:and? a) (pat:and? b))
|
||||
(subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
|
||||
[(and (pat:or? a) (pat:or? b))
|
||||
(subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
|
||||
[(and (pat:not? a) (pat:not? b))
|
||||
(pattern-equal? (pat:not-pattern a) (pat:not-pattern b))]
|
||||
[(and (pat:pair? a) (pat:pair? b))
|
||||
(and (pattern-equal? (pat:pair-head a) (pat:pair-head b))
|
||||
(pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))]
|
||||
[(and (pat:vector? a) (pat:vector? b))
|
||||
(pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))]
|
||||
[(and (pat:box? a) (pat:box? b))
|
||||
(pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
|
||||
[(and (pat:pstruct? a) (pat:pstruct? b))
|
||||
(and (equal? (pat:pstruct-key a)
|
||||
(pat:pstruct-key b))
|
||||
(pattern-equal? (pat:pstruct-pattern a)
|
||||
(pat:pstruct-pattern b)))]
|
||||
[(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
|
||||
[(and (pat:delimit? a) (pat:delimit? b))
|
||||
(pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
|
||||
[(and (pat:commit? a) (pat:commit? b))
|
||||
(pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
|
||||
[(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
|
||||
[(and (pat:ord? a) (pat:ord? b))
|
||||
(and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b))
|
||||
(equal? (pat:ord-group a) (pat:ord-group b))
|
||||
(equal? (pat:ord-index a) (pat:ord-index b)))]
|
||||
[(and (pat:post? a) (pat:post? b))
|
||||
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
|
||||
;; ---
|
||||
[(and (hpat:var/p? a) (hpat:var/p? b))
|
||||
(and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
|
||||
(bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
|
||||
(equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b))
|
||||
(equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
|
||||
(expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
|
||||
[(and (hpat:seq? a) (hpat:seq? b))
|
||||
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
|
||||
;; ---
|
||||
[(and (ehpat? a) (ehpat? b))
|
||||
(and (equal? (ehpat-repc a) #f)
|
||||
(equal? (ehpat-repc b) #f)
|
||||
(pattern-equal? (ehpat-head a) (ehpat-head b)))]
|
||||
;; FIXME: more?
|
||||
[else #f]))
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (and (eq? result #f)
|
||||
(equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
|
||||
(eprintf "** pattern-equal? failed on ~e\n" a)))
|
||||
result)
|
||||
|
||||
(define (equal-iattrs? as bs)
|
||||
(and (= (length as) (length bs))
|
||||
;; assumes attrs in same order
|
||||
(for/and ([aa (in-list as)]
|
||||
[ba (in-list bs)])
|
||||
(and (bound-identifier=? (attr-name aa) (attr-name ba))
|
||||
(equal? (attr-depth aa) (attr-depth ba))
|
||||
(equal? (attr-syntax? aa) (attr-syntax? ba))))))
|
||||
|
||||
(define (expr-equal? a b)
|
||||
;; Expression equality is undecidable in general. Especially difficult for unexpanded
|
||||
;; code, but it would be very difficult to set up correct env for local-expand because of
|
||||
;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
|
||||
;; FIXME: any other common cases?
|
||||
(cond [(not (and (syntax? a) (syntax? b)))
|
||||
(equal? a b)]
|
||||
[(and (identifier? a) (identifier? b))
|
||||
;; note: "vars" might be identifier macros (unsafe to consider equal),
|
||||
;; so check var has no compile-time binding
|
||||
(and (free-identifier=? a b)
|
||||
(let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
|
||||
[(syntax-case (list a b) (quote)
|
||||
[((quote ad) (quote bd))
|
||||
(cons (syntax->datum #'ad) (syntax->datum #'bd))]
|
||||
[_ #f])
|
||||
=> (lambda (ad+bd)
|
||||
(equal? (car ad+bd) (cdr ad+bd)))]
|
||||
[else
|
||||
;; approx: equal? only if both simple data (bool, string, etc), no inner stx
|
||||
(let ([ad (syntax-e a)]
|
||||
[bd (syntax-e b)])
|
||||
(and (equal? ad bd)
|
||||
(free-identifier=? (datum->syntax a '#%datum) #'#%datum)
|
||||
(free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
|
||||
|
||||
(define (equal-argu? a b)
|
||||
(define (unwrap-arguments x)
|
||||
(match x
|
||||
[(arguments pargs kws kwargs)
|
||||
(values pargs kws kwargs)]))
|
||||
(define (list-equal? as bs inner-equal?)
|
||||
(and (= (length as) (length bs))
|
||||
(andmap inner-equal? as bs)))
|
||||
(let-values ([(apargs akws akwargs) (unwrap-arguments a)]
|
||||
[(bpargs bkws bkwargs) (unwrap-arguments b)])
|
||||
(and (list-equal? apargs bpargs expr-equal?)
|
||||
(equal? akws bkws)
|
||||
(list-equal? akwargs bkwargs expr-equal?))))
|
||||
|
||||
(define (free-id/f-equal? a b)
|
||||
(or (and (eq? a #f)
|
||||
(eq? b #f))
|
||||
(and (identifier? a)
|
||||
(identifier? b)
|
||||
(free-identifier=? a b))))
|
||||
|
||||
(define (bound-id/f-equal? a b)
|
||||
(or (and (eq? a #f)
|
||||
(eq? b #f))
|
||||
(and (identifier? a)
|
||||
(identifier? b)
|
||||
(bound-identifier=? a b))))
|
||||
|
||||
(define (make-and-pattern subs)
|
||||
(cond [(null? subs) (pat:any)] ;; shouldn't happen
|
||||
[(null? (cdr subs)) (car subs)]
|
||||
[else (pat:and subs)]))
|
||||
|
||||
(define (*append a b) (if (null? b) a (append a b)))
|
||||
|
||||
(define (stx-e x) (if (syntax? x) (syntax-e x) x))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (matrix->sexpr rows)
|
||||
(cond [(null? rows) ;; shouldn't happen
|
||||
'(FAIL)]
|
||||
[(null? (cdr rows))
|
||||
(pk->sexpr (car rows))]
|
||||
[else
|
||||
(cons 'TRY (map pk->sexpr rows))]))
|
||||
(define (pk->sexpr pk)
|
||||
(match pk
|
||||
[(pk1 pats k)
|
||||
(cons 'MATCH (map pattern->sexpr pats))]
|
||||
[(pk/same pat inner)
|
||||
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
|
||||
[(pk/pair inner)
|
||||
(list 'PAIR (matrix->sexpr inner))]
|
||||
[(pk/and inner)
|
||||
(list 'AND (matrix->sexpr inner))]))
|
||||
(define (pattern->sexpr p)
|
||||
(match p
|
||||
[(pat:any) '_]
|
||||
[(pat:integrated name pred desc _)
|
||||
(format-symbol "~a:~a" (or name '_) desc)]
|
||||
[(pat:svar name)
|
||||
(syntax-e name)]
|
||||
[(pat:var/p name parser _ _ _ _)
|
||||
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
|
||||
=> (lambda (m)
|
||||
(format-symbol "~a:~a" (or name '_) (cadr m)))]
|
||||
[else
|
||||
(if name (syntax-e name) '_)])]
|
||||
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))]
|
||||
[(pat:datum datum) datum]
|
||||
[(? pat:action?) 'ACTION]
|
||||
[(pat:pair head tail)
|
||||
(cons (pattern->sexpr head) (pattern->sexpr tail))]
|
||||
[(pat:head head tail)
|
||||
(cons (pattern->sexpr head) (pattern->sexpr tail))]
|
||||
[(pat:dots (list eh) tail)
|
||||
(list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
|
||||
[(ehpat _as hpat '#f _cn)
|
||||
(pattern->sexpr hpat)]
|
||||
[_ 'PATTERN]))
|
||||
31
6-90-0-29/racket/collects/syntax/parse.rkt
Normal file
31
6-90-0-29/racket/collects/syntax/parse.rkt
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/contract/base
|
||||
"parse/pre.rkt"
|
||||
"parse/experimental/provide.rkt"
|
||||
"parse/experimental/contract.rkt")
|
||||
(provide (except-out (all-from-out "parse/pre.rkt")
|
||||
static)
|
||||
expr/c)
|
||||
(provide-syntax-class/contract
|
||||
[static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])])
|
||||
|
||||
(begin-for-syntax
|
||||
(require racket/contract/base
|
||||
syntax/parse/private/residual-ct)
|
||||
(provide pattern-expander?
|
||||
(contract-out
|
||||
[pattern-expander
|
||||
(-> (-> syntax? syntax?) pattern-expander?)]
|
||||
[prop:pattern-expander
|
||||
(struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
|
||||
[syntax-local-syntax-parse-pattern-introduce
|
||||
(-> syntax? syntax?)]))
|
||||
|
||||
(require (only-in (for-template syntax/parse) pattern-expander))
|
||||
#;(define pattern-expander
|
||||
(let ()
|
||||
#;(struct pattern-expander (proc) #:transparent
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:pattern-expander (λ (this) (pattern-expander-proc this)))
|
||||
pattern-expander)))
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket/base
|
||||
(require stxparse-info/parse/pre
|
||||
"provide.rkt"
|
||||
syntax/contract
|
||||
(only-in stxparse-info/parse/private/residual ;; keep abs. path
|
||||
this-context-syntax
|
||||
this-role)
|
||||
racket/contract/base)
|
||||
|
||||
(define not-given (gensym))
|
||||
|
||||
(define-syntax-class (expr/c ctc-stx
|
||||
#:positive [pos-blame 'use-site]
|
||||
#:negative [neg-blame 'from-macro]
|
||||
#:macro [macro-name #f]
|
||||
#:name [expr-name not-given]
|
||||
#:context [ctx #f])
|
||||
#:attributes (c)
|
||||
#:commit
|
||||
(pattern y:expr
|
||||
#:with
|
||||
c (wrap-expr/c ctc-stx
|
||||
#'y
|
||||
#:positive pos-blame
|
||||
#:negative neg-blame
|
||||
#:name (if (eq? expr-name not-given)
|
||||
this-role
|
||||
expr-name)
|
||||
#:macro macro-name
|
||||
#:context (or ctx (this-context-syntax)))))
|
||||
|
||||
(provide-syntax-class/contract
|
||||
[expr/c (syntax-class/c (syntax?)
|
||||
(#:positive (or/c syntax? string? module-path-index?
|
||||
'from-macro 'use-site 'unknown)
|
||||
#:negative (or/c syntax? string? module-path-index?
|
||||
'from-macro 'use-site 'unknown)
|
||||
#:name (or/c identifier? string? symbol? #f)
|
||||
#:macro (or/c identifier? string? symbol? #f)
|
||||
#:context (or/c syntax? #f)))])
|
||||
430
6-90-0-29/racket/collects/syntax/parse/private/opt.rkt
Normal file
430
6-90-0-29/racket/collects/syntax/parse/private/opt.rkt
Normal file
|
|
@ -0,0 +1,430 @@
|
|||
#lang racket/base
|
||||
(require racket/syntax
|
||||
racket/pretty
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
syntax/parse/private/minimatch
|
||||
syntax/parse/private/rep-patterns
|
||||
syntax/parse/private/kws)
|
||||
(provide (struct-out pk1)
|
||||
(rename-out [optimize-matrix0 optimize-matrix]))
|
||||
|
||||
;; controls debugging output for optimization successes and failures
|
||||
(define DEBUG-OPT-SUCCEED #f)
|
||||
(define DEBUG-OPT-FAIL #f)
|
||||
|
||||
;; ----
|
||||
|
||||
;; A Matrix is a (listof PK) where each PK has same number of columns
|
||||
;; A PK is one of
|
||||
;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix
|
||||
;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out
|
||||
;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded
|
||||
;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded
|
||||
(struct pk1 (patterns k) #:prefab)
|
||||
(struct pk/same (pattern inner) #:prefab)
|
||||
(struct pk/pair (inner) #:prefab)
|
||||
(struct pk/and (inner) #:prefab)
|
||||
|
||||
(define (pk-columns pk)
|
||||
(match pk
|
||||
[(pk1 patterns k) (length patterns)]
|
||||
[(pk/same p inner) (add1 (pk-columns inner))]
|
||||
[(pk/pair inner) (sub1 (pk-columns inner))]
|
||||
[(pk/and inner) (sub1 (pk-columns inner))]))
|
||||
|
||||
;; Can factor pattern P given clauses like
|
||||
;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
|
||||
;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ]
|
||||
; [ P PN ... | eN] [ | [PN ... | eN] ]
|
||||
;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking)
|
||||
|
||||
;; Can unfold pair patterns as follows:
|
||||
;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
|
||||
;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ]
|
||||
;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
|
||||
|
||||
;; Can unfold ~and patterns similarly; ~and patterns can hide
|
||||
;; factoring opportunities.
|
||||
|
||||
;; ----
|
||||
|
||||
(define (optimize-matrix0 rows)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
|
||||
(eprintf "\n%% optimizing (~s):\n" (length rows))
|
||||
(pretty-write (matrix->sexpr rows) (current-error-port)))
|
||||
(define result (optimize-matrix rows))
|
||||
(define then (current-inexact-milliseconds))
|
||||
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
|
||||
(cond [(= (length result) (length rows))
|
||||
(eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
|
||||
[else
|
||||
(eprintf "==> (~s ms)\n" (floor (- then now)))
|
||||
(pretty-write (matrix->sexpr result) (current-error-port))
|
||||
(eprintf "\n")]))
|
||||
result)
|
||||
|
||||
;; optimize-matrix : (listof pk1) -> Matrix
|
||||
(define (optimize-matrix rows)
|
||||
(cond [(null? rows) null]
|
||||
[(null? (cdr rows)) rows] ;; no opportunities for 1 row
|
||||
[(null? (pk1-patterns (car rows))) rows]
|
||||
[else
|
||||
;; first unfold and-patterns
|
||||
(let-values ([(col1 col2)
|
||||
(for/lists (col1 col2) ([row (in-list rows)])
|
||||
(unfold-and (car (pk1-patterns row)) null))])
|
||||
(cond [(ormap pair? col2)
|
||||
(list
|
||||
(pk/and
|
||||
(optimize-matrix*
|
||||
(for/list ([row (in-list rows)]
|
||||
[col1 (in-list col1)]
|
||||
[col2 (in-list col2)])
|
||||
(pk1 (list* col1
|
||||
(make-and-pattern col2)
|
||||
(cdr (pk1-patterns row)))
|
||||
(pk1-k row))))))]
|
||||
[else (optimize-matrix* rows)]))]))
|
||||
|
||||
;; optimize-matrix* : (listof pk1) -> Matrix
|
||||
;; The matrix is nonempty, and first column has no unfoldable pat:and.
|
||||
;; Split into submatrixes (sequences of rows) starting with similar patterns,
|
||||
;; handle according to similarity, then recursively optimize submatrixes.
|
||||
(define (optimize-matrix* rows)
|
||||
(define row1 (car rows))
|
||||
(define pat1 (car (pk1-patterns row1)))
|
||||
(define k1 (pk1-k row1))
|
||||
;; Now accumulate rows starting with patterns like pat1
|
||||
(define-values (like? combine) (pattern->partitioner pat1))
|
||||
(let loop ([rows (cdr rows)] [rrows (list row1)])
|
||||
(cond [(null? rows)
|
||||
(cons (combine (reverse rrows)) null)]
|
||||
[else
|
||||
(define row1 (car rows))
|
||||
(define pat1 (car (pk1-patterns row1)))
|
||||
(cond [(like? pat1)
|
||||
(loop (cdr rows) (cons row1 rrows))]
|
||||
[else
|
||||
(cons (combine (reverse rrows))
|
||||
(optimize-matrix* rows))])])))
|
||||
|
||||
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
|
||||
(define (pattern->partitioner pat1)
|
||||
(match pat1
|
||||
[(pat:pair head tail)
|
||||
(values (lambda (p) (pat:pair? p))
|
||||
(lambda (rows)
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
|
||||
(cond [(> (length rows) 1)
|
||||
(pk/pair (optimize-matrix
|
||||
(for/list ([row (in-list rows)])
|
||||
(let* ([patterns (pk1-patterns row)]
|
||||
[pat1 (car patterns)])
|
||||
(pk1 (list* (pat:pair-head pat1)
|
||||
(pat:pair-tail pat1)
|
||||
(cdr patterns))
|
||||
(pk1-k row))))))]
|
||||
[else (car rows)])))]
|
||||
[(? pattern-factorable?)
|
||||
(values (lambda (pat2) (pattern-equal? pat1 pat2))
|
||||
(lambda (rows)
|
||||
(when DEBUG-OPT-SUCCEED
|
||||
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
|
||||
(cond [(> (length rows) 1)
|
||||
(pk/same pat1
|
||||
(optimize-matrix
|
||||
(for/list ([row (in-list rows)])
|
||||
(pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
|
||||
[else (car rows)])))]
|
||||
[_
|
||||
(values (lambda (pat2)
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (pattern-equal? pat1 pat2)
|
||||
(eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2))))
|
||||
#f)
|
||||
(lambda (rows)
|
||||
;; (length rows) = 1
|
||||
(car rows)))]))
|
||||
|
||||
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
|
||||
(define (unfold-and p onto)
|
||||
(match p
|
||||
[(pat:and subpatterns)
|
||||
;; pat:and is worth unfolding if first subpattern is not pat:action
|
||||
;; if first subpattern is also pat:and, keep unfolding
|
||||
(let* ([first-sub (car subpatterns)]
|
||||
[rest-subs (cdr subpatterns)])
|
||||
(cond [(not (pat:action? first-sub))
|
||||
(when #f ;; DEBUG-OPT-SUCCEED
|
||||
(eprintf ">> unfolding: ~e\n" p))
|
||||
(unfold-and first-sub (*append rest-subs onto))]
|
||||
[else (values p onto)]))]
|
||||
[_ (values p onto)]))
|
||||
|
||||
(define (pattern-factorable? p)
|
||||
;; Can factor out p if p can succeed at most once, does not cut
|
||||
;; - if p can succeed multiple times, then factoring changes success order
|
||||
;; - if p can cut, then factoring changes which choice points are discarded (too few)
|
||||
(match p
|
||||
[(pat:any) #t]
|
||||
[(pat:svar _n) #t]
|
||||
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
|
||||
;; commit? implies delimit-cut
|
||||
commit?]
|
||||
[(? pat:integrated?) #t]
|
||||
[(pat:literal _lit _ip _lp) #t]
|
||||
[(pat:datum _datum) #t]
|
||||
[(pat:action _act _pat) #f]
|
||||
[(pat:head head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:dots heads tail)
|
||||
;; Conservative approximation for common case: one head pattern
|
||||
;; In general, check if heads don't overlap, don't overlap with tail.
|
||||
(and (= (length heads) 1)
|
||||
(let ([head (car heads)])
|
||||
(and (pattern-factorable? head)))
|
||||
(equal? tail (pat:datum '())))]
|
||||
[(pat:and patterns)
|
||||
(andmap pattern-factorable? patterns)]
|
||||
[(pat:or patterns) #f]
|
||||
[(pat:not pattern) #f] ;; FIXME: ?
|
||||
[(pat:pair head tail)
|
||||
(and (pattern-factorable? head)
|
||||
(pattern-factorable? tail))]
|
||||
[(pat:vector pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:box pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:pstruct key pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:describe pattern _desc _trans _role)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:delimit pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:commit pattern) #t]
|
||||
[(? pat:reflect?) #f]
|
||||
[(pat:ord pattern _ _)
|
||||
(pattern-factorable? pattern)]
|
||||
[(pat:post pattern)
|
||||
(pattern-factorable? pattern)]
|
||||
;; ----
|
||||
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
|
||||
commit?]
|
||||
[(hpat:seq inner)
|
||||
(pattern-factorable? inner)]
|
||||
[(hpat:commit inner) #t]
|
||||
;; ----
|
||||
[(ehpat head repc)
|
||||
(and (equal? repc #f)
|
||||
(pattern-factorable? head))]
|
||||
;; ----
|
||||
[else #f]))
|
||||
|
||||
(define (subpatterns-equal? as bs)
|
||||
(and (= (length as) (length bs))
|
||||
(for/and ([a (in-list as)]
|
||||
[b (in-list bs)])
|
||||
(pattern-equal? a b))))
|
||||
|
||||
(define (pattern-equal? a b)
|
||||
(define result
|
||||
(cond [(and (pat:any? a) (pat:any? b)) #t]
|
||||
[(and (pat:svar? a) (pat:svar? b))
|
||||
(bound-identifier=? (pat:svar-name a) (pat:svar-name b))]
|
||||
[(and (pat:var/p? a) (pat:var/p? b))
|
||||
(and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
|
||||
(bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b))
|
||||
(equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b))
|
||||
(equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
|
||||
(expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
|
||||
[(and (pat:integrated? a) (pat:integrated? b))
|
||||
(and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b))
|
||||
(free-identifier=? (pat:integrated-predicate a)
|
||||
(pat:integrated-predicate b))
|
||||
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
|
||||
[(and (pat:literal? a) (pat:literal? b))
|
||||
;; literals are hard to compare, so compare gensyms attached to
|
||||
;; literal ids (see rep.rkt) instead
|
||||
(let ([ka (syntax-property (pat:literal-id a) 'literal)]
|
||||
[kb (syntax-property (pat:literal-id b) 'literal)])
|
||||
(and ka kb (eq? ka kb)))]
|
||||
[(and (pat:datum? a) (pat:datum? b))
|
||||
(equal? (pat:datum-datum a)
|
||||
(pat:datum-datum b))]
|
||||
[(and (pat:head? a) (pat:head? b))
|
||||
(and (pattern-equal? (pat:head-head a) (pat:head-head b))
|
||||
(pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
|
||||
[(and (pat:dots? a) (pat:dots? b))
|
||||
(and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
|
||||
(pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
|
||||
[(and (pat:and? a) (pat:and? b))
|
||||
(subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
|
||||
[(and (pat:or? a) (pat:or? b))
|
||||
(subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
|
||||
[(and (pat:not? a) (pat:not? b))
|
||||
(pattern-equal? (pat:not-pattern a) (pat:not-pattern b))]
|
||||
[(and (pat:pair? a) (pat:pair? b))
|
||||
(and (pattern-equal? (pat:pair-head a) (pat:pair-head b))
|
||||
(pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))]
|
||||
[(and (pat:vector? a) (pat:vector? b))
|
||||
(pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))]
|
||||
[(and (pat:box? a) (pat:box? b))
|
||||
(pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
|
||||
[(and (pat:pstruct? a) (pat:pstruct? b))
|
||||
(and (equal? (pat:pstruct-key a)
|
||||
(pat:pstruct-key b))
|
||||
(pattern-equal? (pat:pstruct-pattern a)
|
||||
(pat:pstruct-pattern b)))]
|
||||
[(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
|
||||
[(and (pat:delimit? a) (pat:delimit? b))
|
||||
(pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
|
||||
[(and (pat:commit? a) (pat:commit? b))
|
||||
(pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
|
||||
[(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
|
||||
[(and (pat:ord? a) (pat:ord? b))
|
||||
(and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b))
|
||||
(equal? (pat:ord-group a) (pat:ord-group b))
|
||||
(equal? (pat:ord-index a) (pat:ord-index b)))]
|
||||
[(and (pat:post? a) (pat:post? b))
|
||||
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
|
||||
;; ---
|
||||
[(and (hpat:var/p? a) (hpat:var/p? b))
|
||||
(and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
|
||||
(bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
|
||||
(equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b))
|
||||
(equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
|
||||
(expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
|
||||
[(and (hpat:seq? a) (hpat:seq? b))
|
||||
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
|
||||
;; ---
|
||||
[(and (ehpat? a) (ehpat? b))
|
||||
(and (equal? (ehpat-repc a) #f)
|
||||
(equal? (ehpat-repc b) #f)
|
||||
(pattern-equal? (ehpat-head a) (ehpat-head b)))]
|
||||
;; FIXME: more?
|
||||
[else #f]))
|
||||
(when DEBUG-OPT-FAIL
|
||||
(when (and (eq? result #f)
|
||||
(equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
|
||||
(eprintf "** pattern-equal? failed on ~e\n" a)))
|
||||
result)
|
||||
|
||||
(define (equal-iattrs? as bs)
|
||||
(and (= (length as) (length bs))
|
||||
;; assumes attrs in same order
|
||||
(for/and ([aa (in-list as)]
|
||||
[ba (in-list bs)])
|
||||
(and (bound-identifier=? (attr-name aa) (attr-name ba))
|
||||
(equal? (attr-depth aa) (attr-depth ba))
|
||||
(equal? (attr-syntax? aa) (attr-syntax? ba))))))
|
||||
|
||||
(define (expr-equal? a b)
|
||||
;; Expression equality is undecidable in general. Especially difficult for unexpanded
|
||||
;; code, but it would be very difficult to set up correct env for local-expand because of
|
||||
;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
|
||||
;; FIXME: any other common cases?
|
||||
(cond [(not (and (syntax? a) (syntax? b)))
|
||||
(equal? a b)]
|
||||
[(and (identifier? a) (identifier? b))
|
||||
;; note: "vars" might be identifier macros (unsafe to consider equal),
|
||||
;; so check var has no compile-time binding
|
||||
(and (free-identifier=? a b)
|
||||
(let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
|
||||
[(syntax-case (list a b) (quote)
|
||||
[((quote ad) (quote bd))
|
||||
(cons (syntax->datum #'ad) (syntax->datum #'bd))]
|
||||
[_ #f])
|
||||
=> (lambda (ad+bd)
|
||||
(equal? (car ad+bd) (cdr ad+bd)))]
|
||||
[else
|
||||
;; approx: equal? only if both simple data (bool, string, etc), no inner stx
|
||||
(let ([ad (syntax-e a)]
|
||||
[bd (syntax-e b)])
|
||||
(and (equal? ad bd)
|
||||
(free-identifier=? (datum->syntax a '#%datum) #'#%datum)
|
||||
(free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
|
||||
|
||||
(define (equal-argu? a b)
|
||||
(define (unwrap-arguments x)
|
||||
(match x
|
||||
[(arguments pargs kws kwargs)
|
||||
(values pargs kws kwargs)]))
|
||||
(define (list-equal? as bs inner-equal?)
|
||||
(and (= (length as) (length bs))
|
||||
(andmap inner-equal? as bs)))
|
||||
(let-values ([(apargs akws akwargs) (unwrap-arguments a)]
|
||||
[(bpargs bkws bkwargs) (unwrap-arguments b)])
|
||||
(and (list-equal? apargs bpargs expr-equal?)
|
||||
(equal? akws bkws)
|
||||
(list-equal? akwargs bkwargs expr-equal?))))
|
||||
|
||||
(define (free-id/f-equal? a b)
|
||||
(or (and (eq? a #f)
|
||||
(eq? b #f))
|
||||
(and (identifier? a)
|
||||
(identifier? b)
|
||||
(free-identifier=? a b))))
|
||||
|
||||
(define (bound-id/f-equal? a b)
|
||||
(or (and (eq? a #f)
|
||||
(eq? b #f))
|
||||
(and (identifier? a)
|
||||
(identifier? b)
|
||||
(bound-identifier=? a b))))
|
||||
|
||||
(define (make-and-pattern subs)
|
||||
(cond [(null? subs) (pat:any)] ;; shouldn't happen
|
||||
[(null? (cdr subs)) (car subs)]
|
||||
[else (pat:and subs)]))
|
||||
|
||||
(define (*append a b) (if (null? b) a (append a b)))
|
||||
|
||||
(define (stx-e x) (if (syntax? x) (syntax-e x) x))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (matrix->sexpr rows)
|
||||
(cond [(null? rows) ;; shouldn't happen
|
||||
'(FAIL)]
|
||||
[(null? (cdr rows))
|
||||
(pk->sexpr (car rows))]
|
||||
[else
|
||||
(cons 'TRY (map pk->sexpr rows))]))
|
||||
(define (pk->sexpr pk)
|
||||
(match pk
|
||||
[(pk1 pats k)
|
||||
(cons 'MATCH (map pattern->sexpr pats))]
|
||||
[(pk/same pat inner)
|
||||
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
|
||||
[(pk/pair inner)
|
||||
(list 'PAIR (matrix->sexpr inner))]
|
||||
[(pk/and inner)
|
||||
(list 'AND (matrix->sexpr inner))]))
|
||||
(define (pattern->sexpr p)
|
||||
(match p
|
||||
[(pat:any) '_]
|
||||
[(pat:integrated name pred desc _)
|
||||
(format-symbol "~a:~a" (or name '_) desc)]
|
||||
[(pat:svar name)
|
||||
(syntax-e name)]
|
||||
[(pat:var/p name parser _ _ _ _)
|
||||
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
|
||||
=> (lambda (m)
|
||||
(format-symbol "~a:~a" (or name '_) (cadr m)))]
|
||||
[else
|
||||
(if name (syntax-e name) '_)])]
|
||||
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))]
|
||||
[(pat:datum datum) datum]
|
||||
[(? pat:action?) 'ACTION]
|
||||
[(pat:pair head tail)
|
||||
(cons (pattern->sexpr head) (pattern->sexpr tail))]
|
||||
[(pat:head head tail)
|
||||
(cons (pattern->sexpr head) (pattern->sexpr tail))]
|
||||
[(pat:dots (list eh) tail)
|
||||
(list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
|
||||
[(ehpat _as hpat '#f _cn)
|
||||
(pattern->sexpr hpat)]
|
||||
[_ 'PATTERN]))
|
||||
77
7-0-0-20/racket/collects/racket/private/stxcase-scheme.rkt
Normal file
77
7-0-0-20/racket/collects/racket/private/stxcase-scheme.rkt
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
|
||||
;;----------------------------------------------------------------------
|
||||
;; #%stxcase-scheme: adds let-syntax, syntax-rules, and
|
||||
;; check-duplicate-identifier, and assembles everything we have so far
|
||||
|
||||
(module stxcase-scheme '#%kernel
|
||||
(#%require racket/private/small-scheme racket/private/stx "stxcase.rkt"
|
||||
"with-stx.rkt" (all-except racket/private/stxloc syntax/loc)
|
||||
(for-syntax '#%kernel racket/private/small-scheme
|
||||
racket/private/stx "stxcase.rkt"
|
||||
(all-except racket/private/stxloc syntax/loc)))
|
||||
|
||||
(-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 racket/private/stxloc)
|
||||
check-duplicate-identifier syntax-protect
|
||||
syntax-rules syntax-id-rules
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
390
7-0-0-20/racket/collects/racket/private/stxcase.rkt
Normal file
390
7-0-0-20/racket/collects/racket/private/stxcase.rkt
Normal file
|
|
@ -0,0 +1,390 @@
|
|||
;;----------------------------------------------------------------------
|
||||
;; syntax-case and syntax
|
||||
|
||||
(module stxcase '#%kernel
|
||||
(#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
|
||||
racket/private/ellipses
|
||||
stxparse-info/current-pvars
|
||||
(for-syntax racket/private/stx racket/private/small-scheme
|
||||
racket/private/gen-temp racket/private/member racket/private/sc '#%kernel
|
||||
auto-syntax-e/utils))
|
||||
|
||||
(-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-auto-pvar))
|
||||
;; 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
|
||||
(list (quote-syntax with-pvars)
|
||||
pattern-vars
|
||||
answer)
|
||||
do-try-next)
|
||||
(list (quote-syntax with-pvars)
|
||||
pattern-vars
|
||||
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)))))))
|
||||
|
||||
(#%require "template.rkt")
|
||||
(#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
|
||||
(for-syntax syntax-pattern-variable?)))
|
||||
59
7-0-0-20/racket/collects/racket/private/stxloc.rkt
Normal file
59
7-0-0-20/racket/collects/racket/private/stxloc.rkt
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
|
||||
;;----------------------------------------------------------------------
|
||||
;; syntax/loc
|
||||
|
||||
(module stxloc '#%kernel
|
||||
(#%require racket/private/qq-and-or "stxcase.rkt" racket/private/define-et-al
|
||||
(for-syntax '#%kernel "stxcase.rkt" racket/private/sc))
|
||||
|
||||
(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-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
|
||||
... _ ~? ~@))
|
||||
214
7-0-0-20/racket/collects/racket/private/syntax.rkt
Normal file
214
7-0-0-20/racket/collects/racket/private/syntax.rkt
Normal file
|
|
@ -0,0 +1,214 @@
|
|||
#lang racket/base
|
||||
(require (only-in "stxloc.rkt" syntax-case)
|
||||
stxparse-info/current-pvars
|
||||
(for-syntax racket/base
|
||||
racket/private/sc
|
||||
auto-syntax-e/utils))
|
||||
(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-auto-pvar 'depth (quote-syntax valvar)))
|
||||
...
|
||||
(define-pvars pvar ...))))]))
|
||||
;; 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))))
|
||||
|
||||
;; Included for backwards compatibility.
|
||||
(define (internal-definition-context-apply intdefs stx)
|
||||
; The old implementation of internal-definition-context-apply implicitly converted its stx argument
|
||||
; to syntax, which some things seem to (possibly unintentionally) rely on, so replicate that
|
||||
; behavior here:
|
||||
(internal-definition-context-introduce intdefs (datum->syntax #f stx) 'add))
|
||||
|
||||
(define (syntax-local-eval stx [intdefs '()])
|
||||
(let* ([name (generate-temporary)]
|
||||
[intdef (syntax-local-make-definition-context)])
|
||||
(syntax-local-bind-syntaxes (list name)
|
||||
#`(call-with-values (lambda () #,stx) list)
|
||||
intdef
|
||||
intdefs)
|
||||
(apply values
|
||||
(syntax-local-value (internal-definition-context-introduce intdef name)
|
||||
#f intdef))))
|
||||
|
||||
(define-syntax (with-syntax* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (cl) body ...) #'(with-syntax (cl) body ...)]
|
||||
[(_ (cl cls ...) body ...)
|
||||
#'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
|
||||
732
7-0-0-20/racket/collects/racket/private/template.rkt
Normal file
732
7-0-0-20/racket/collects/racket/private/template.rkt
Normal file
|
|
@ -0,0 +1,732 @@
|
|||
;; TODO: should either use directly the official "template.rkt",
|
||||
;; or import all the structs from there, to avoid having
|
||||
;; multiple definitions of the same struct.
|
||||
(module template '#%kernel
|
||||
(#%require racket/private/stx racket/private/small-scheme racket/private/performance-hint
|
||||
(rename racket/private/small-scheme define -define)
|
||||
(rename racket/private/small-scheme define-syntax -define-syntax)
|
||||
racket/private/ellipses
|
||||
(for-syntax racket/private/stx racket/private/small-scheme
|
||||
(rename racket/private/small-scheme define -define)
|
||||
(rename racket/private/small-scheme define-syntax -define-syntax)
|
||||
racket/private/member racket/private/sc '#%kernel
|
||||
racket/struct
|
||||
auto-syntax-e/utils))
|
||||
(#%provide syntax
|
||||
syntax/loc
|
||||
datum
|
||||
~? ~@
|
||||
~@! signal-absent-pvar
|
||||
(protect
|
||||
(for-syntax attribute-mapping
|
||||
attribute-mapping?
|
||||
attribute-mapping-name
|
||||
attribute-mapping-var
|
||||
attribute-mapping-depth
|
||||
attribute-mapping-check
|
||||
metafunction metafunction?)))
|
||||
|
||||
;; ============================================================
|
||||
;; Syntax of templates
|
||||
|
||||
;; A Template (T) is one of:
|
||||
;; - pattern-variable
|
||||
;; - constant (including () and non-pvar identifiers)
|
||||
;; - (metafunction . T)
|
||||
;; - (H . T)
|
||||
;; - (H ... . T), (H ... ... . T), etc
|
||||
;; - (... T) -- escapes inner ..., ~?, ~@
|
||||
;; - (~? T T)
|
||||
;; - #(T*) -- actually, vector->list interpreted as T
|
||||
;; - #s(prefab-struct-key T*) -- likewise
|
||||
|
||||
;; A HeadTemplate (H) is one of:
|
||||
;; - T
|
||||
;; - (~? H)
|
||||
;; - (~? H H)
|
||||
;; - (~@ . T)
|
||||
|
||||
(define-syntax ~@! #f) ;; private, escape-ignoring version of ~@, used by unsyntax-splicing
|
||||
|
||||
;; ============================================================
|
||||
;; Compile-time
|
||||
|
||||
;; Parse template syntax into a Guide (AST--the name is left over from
|
||||
;; when the "guide" was a data structure interpreted at run time).
|
||||
|
||||
;; The AST representation is designed to coincide with the run-time
|
||||
;; support, so compilation is just (datum->syntax #'here guide). The
|
||||
;; variants listed below are the ones recognized and treated specially
|
||||
;; by other functions (eg optimize-resyntax, relocate-guide).
|
||||
|
||||
;; A Guide (G) is one of:
|
||||
;; - (list 't-resyntax Expr Expr G)
|
||||
;; - (list 't-const Expr) ;; constant
|
||||
;; - (list 't-var Id) ;; trusted pattern variable
|
||||
;; - (list 't-list G ...)
|
||||
;; - (list 't-list* G ... G)
|
||||
;; - (list 't-append HG G)
|
||||
;; - (list 't-orelse G G)
|
||||
;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions
|
||||
;; -- where Subst = Nat ;; replace nth car with arg
|
||||
;; | 'tail Nat ;; replace nth cdr with arg
|
||||
;; | 'append Nat ;; replace nth car by appending arg
|
||||
;; | 'recur Nat ;; replace nth car by recurring on it with arg
|
||||
;; - other expression (must be pair!)
|
||||
|
||||
;; A HeadGuide (HG) is one of:
|
||||
;; - (list 'h-t G)
|
||||
;; - other expression (must be pair!)
|
||||
|
||||
;; A PVar is (pvar Id Id Id/#f Nat/#f)
|
||||
;;
|
||||
;; The first identifier (var) is from the syntax-mapping or attribute-binding.
|
||||
;; The second (lvar) is a local variable name used to hold its value (or parts
|
||||
;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a
|
||||
;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see
|
||||
;; below) if it needs to be checked.
|
||||
;;
|
||||
;; The depth-delta associated with a depth>0 pattern variable is the difference
|
||||
;; between the pattern variable's depth and the depth at which it is used. (For
|
||||
;; depth 0 pvars, it's #f.) For example, in
|
||||
;;
|
||||
;; (with-syntax ([x #'0]
|
||||
;; [(y ...) #'(1 2)]
|
||||
;; [((z ...) ...) #'((a b) (c d))])
|
||||
;; (template (((x y z) ...) ...)))
|
||||
;;
|
||||
;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta
|
||||
;; for z is 0. The depth-delta (or depth "delay") is also the depth of the
|
||||
;; ellipsis form where the variable begins to be iterated over. That is, the
|
||||
;; template above should be interpreted roughly as
|
||||
;;
|
||||
;; (let ([Lx (pvar-value-of x)]
|
||||
;; [Ly (pvar-value-of y)]
|
||||
;; [Lz (pvar-value-of z)])
|
||||
;; (for/list ([Lz (in-list Lz)]) ;; depth 0
|
||||
;; (for/list ([Ly (in-list Ly)] ;; depth 1
|
||||
;; [Lz (in-list Lz)])
|
||||
;; (___ Lx Ly Lz ___))))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define here-stx (quote-syntax here))
|
||||
|
||||
(define template-logger (make-logger 'template (current-logger)))
|
||||
|
||||
;; (struct pvar (var lvar check dd) #:prefab)
|
||||
(define-values (struct:pv pvar pvar? pvar-ref pvar-set!)
|
||||
(make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3)))
|
||||
(define (pvar-var pv) (pvar-ref pv 0))
|
||||
(define (pvar-lvar pv) (pvar-ref pv 1))
|
||||
(define (pvar-check pv) (pvar-ref pv 2))
|
||||
(define (pvar-dd pv) (pvar-ref pv 3))
|
||||
|
||||
;; An Attribute is an identifier statically bound to a syntax-mapping
|
||||
;; (see sc.rkt) whose valvar is an identifier statically bound to an
|
||||
;; attribute-mapping.
|
||||
|
||||
;; (struct attribute-mapping (var name depth check) ...)
|
||||
;; check : #f (trusted) or Id, ref to Checker
|
||||
;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) )
|
||||
(define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
|
||||
attribute-mapping-ref _attribute-mapping-set!)
|
||||
(make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector)
|
||||
(lambda (self stx)
|
||||
(if (attribute-mapping-check self)
|
||||
(let ([source-name
|
||||
(or (let loop ([p (syntax-property stx 'disappeared-use)])
|
||||
(cond [(identifier? p) p]
|
||||
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
||||
[else #f]))
|
||||
(attribute-mapping-name self))])
|
||||
(define code
|
||||
`(,(attribute-mapping-check self)
|
||||
,(attribute-mapping-var self)
|
||||
,(attribute-mapping-depth self)
|
||||
#t
|
||||
(quote-syntax ,source-name)))
|
||||
(datum->syntax here-stx code stx))
|
||||
(attribute-mapping-var self)))))
|
||||
(define (attribute-mapping-var a) (attribute-mapping-ref a 0))
|
||||
(define (attribute-mapping-name a) (attribute-mapping-ref a 1))
|
||||
(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
|
||||
(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
|
||||
|
||||
;; (struct metafunction (var))
|
||||
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
|
||||
(make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector)))
|
||||
(define (metafunction-var mf) (metafunction-ref mf 0))
|
||||
|
||||
(define (ht-guide? x)
|
||||
(if (and (pair? x) (eq? (car x) 'h-t)) #t #f))
|
||||
(define (ht-guide-t x)
|
||||
(if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f))
|
||||
|
||||
(define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list))))
|
||||
(define (const-guide-v x)
|
||||
(if (eq? (car x) 't-list)
|
||||
null
|
||||
(let ([e (cadr x)])
|
||||
(if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e)))))
|
||||
|
||||
(define (cons-guide g1 g2)
|
||||
(cond [(eq? (car g2) 't-list) (list* 't-list g1 (cdr g2))]
|
||||
[(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))]
|
||||
[else (list 't-list* g1 g2)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Parsing templates
|
||||
|
||||
;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id))
|
||||
(define (parse-template ctx t stx?)
|
||||
;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
|
||||
(define env (make-hasheq))
|
||||
|
||||
;; wrong-syntax : Syntax Format-String Any ... -> (error)
|
||||
(define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x))
|
||||
|
||||
;; disappeared-uses : (Listof Id)
|
||||
(define disappeared-uses null)
|
||||
;; disappeared! : Id -> Void
|
||||
(define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses)))
|
||||
|
||||
;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide)
|
||||
(define (parse-t t depth esc?)
|
||||
(cond [(stx-pair? t)
|
||||
(if (identifier? (stx-car t))
|
||||
(parse-t-pair/command t depth esc?)
|
||||
(parse-t-pair/dots t depth esc?))]
|
||||
[else (parse-t-nonpair t depth esc?)]))
|
||||
|
||||
;; parse-t-pair/command : Stx Nat Boolean -> ...
|
||||
;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc)
|
||||
(define (parse-t-pair/command t depth esc?)
|
||||
(cond [esc?
|
||||
(parse-t-pair/dots t depth esc?)]
|
||||
[(parse-form t (quote-syntax ...) 1)
|
||||
=> (lambda (t)
|
||||
(disappeared! (car t))
|
||||
(define-values (drivers guide) (parse-t (cadr t) depth #t))
|
||||
;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _)
|
||||
(values drivers `(t-escaped ,guide)))]
|
||||
[(parse-form t (quote-syntax ~?) 2)
|
||||
=> (lambda (t)
|
||||
(disappeared! (car t))
|
||||
(define t1 (cadr t))
|
||||
(define t2 (caddr t))
|
||||
(define-values (drivers1 guide1) (parse-t t1 depth esc?))
|
||||
(define-values (drivers2 guide2) (parse-t t2 depth esc?))
|
||||
(values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))]
|
||||
[(lookup-metafun (stx-car t))
|
||||
=> (lambda (mf)
|
||||
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
|
||||
(disappeared! (stx-car t))
|
||||
(define-values (drivers guide) (parse-t (stx-cdr t) depth esc?))
|
||||
(values drivers
|
||||
`(t-metafun ,(metafunction-var mf) ,guide
|
||||
(quote-syntax
|
||||
,(let ([tstx (and (syntax? t) t)])
|
||||
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx))))))]
|
||||
[else (parse-t-pair/dots t depth esc?)]))
|
||||
|
||||
;; parse-t-pair/dots : Stx Nat Boolean -> ...
|
||||
;; t is a stx pair; check for dots
|
||||
(define (parse-t-pair/dots t depth esc?)
|
||||
(define head (stx-car t))
|
||||
(define-values (tail nesting)
|
||||
(let loop ([tail (stx-cdr t)] [nesting 0])
|
||||
(if (and (not esc?) (stx-pair? tail)
|
||||
(let ([x (stx-car tail)])
|
||||
(and (identifier? x) (free-identifier=? x (quote-syntax ...)))))
|
||||
(begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting)))
|
||||
(values tail nesting))))
|
||||
(if (zero? nesting)
|
||||
(parse-t-pair/normal t depth esc?)
|
||||
(let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)]
|
||||
[(tdrivers tguide) (parse-t tail depth esc?)])
|
||||
(when (dset-empty? hdrivers)
|
||||
(wrong-syntax head "no pattern variables before ellipsis in template"))
|
||||
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
|
||||
(let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
|
||||
(stx-car (stx-drop nesting t))])
|
||||
;; FIXME: improve error message?
|
||||
(wrong-syntax bad-dots "too many ellipses in template")))
|
||||
;; hdrivers is (listof (dsetof pvar))
|
||||
(define hdriverss ;; per level
|
||||
(let loop ([i 0])
|
||||
(if (< i nesting)
|
||||
(cons (dset-filter hdrivers (pvar/dd<=? (+ depth i)))
|
||||
(loop (add1 i)))
|
||||
null)))
|
||||
(define at-stx (datum->syntax #f '... head))
|
||||
(define hg
|
||||
(let loop ([hdriverss hdriverss])
|
||||
(cond [(null? (cdr hdriverss))
|
||||
(let ([cons? (ht-guide? hguide)]
|
||||
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
|
||||
`(t-dots ,cons? ,hguide ,(car hdriverss)
|
||||
(quote ,head) (quote-syntax ,at-stx)))]
|
||||
[else (let ([inner (loop (cdr hdriverss))])
|
||||
`(t-dots #f ,inner ,(car hdriverss)
|
||||
(quote ,head) (quote-syntax ,at-stx)))])))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(if (equal? tguide '(t-list))
|
||||
(resyntax t hg)
|
||||
(resyntax t `(t-append ,hg ,tguide)))))))
|
||||
|
||||
;; parse-t-pair/normal : Stx Nat Boolean -> ...
|
||||
;; t is a normal stx pair
|
||||
(define (parse-t-pair/normal t depth esc?)
|
||||
(define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?))
|
||||
(define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(resyntax t
|
||||
(if (ht-guide? hguide)
|
||||
(let ([hguide (ht-guide-t hguide)])
|
||||
(if (and (const-guide? hguide) (const-guide? tguide))
|
||||
(const-guide t)
|
||||
(cons-guide hguide tguide)))
|
||||
(if (equal? tguide '(t-list))
|
||||
hguide
|
||||
`(t-append ,hguide ,tguide))))))
|
||||
|
||||
;; parse-t-nonpair : Syntax Nat Boolean -> ...
|
||||
;; PRE: t is not a stxpair
|
||||
(define (parse-t-nonpair t depth esc?)
|
||||
(define td (if (syntax? t) (syntax-e t) t))
|
||||
(cond [(identifier? t)
|
||||
(cond [(and (not esc?)
|
||||
(or (free-identifier=? t (quote-syntax ...))
|
||||
(free-identifier=? t (quote-syntax ~?))
|
||||
(free-identifier=? t (quote-syntax ~@))))
|
||||
(wrong-syntax t "illegal use")]
|
||||
[(lookup-metafun t)
|
||||
(wrong-syntax t "illegal use of syntax metafunction")]
|
||||
[(lookup t depth)
|
||||
=> (lambda (pvar)
|
||||
(disappeared! t)
|
||||
(values (dset pvar)
|
||||
(cond [(pvar-check pvar)
|
||||
=> (lambda (check)
|
||||
`(#%expression
|
||||
(,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))]
|
||||
[else `(t-var ,(pvar-lvar pvar))])))]
|
||||
[else (values (dset) (const-guide t))])]
|
||||
[(vector? td)
|
||||
(define-values (drivers guide) (parse-t (vector->list td) depth esc?))
|
||||
(values drivers
|
||||
(cond [(const-guide? guide) (const-guide t)]
|
||||
[else (resyntax t `(t-vector ,guide))]))]
|
||||
[(prefab-struct-key td)
|
||||
=> (lambda (key)
|
||||
(define-values (drivers guide)
|
||||
(let ([elems (cdr (vector->list (struct->vector td)))])
|
||||
(parse-t elems depth esc?)))
|
||||
(values drivers
|
||||
(cond [(const-guide? guide) (const-guide t)]
|
||||
[else (resyntax t `(t-struct (quote ,key) ,guide))])))]
|
||||
[(box? td)
|
||||
(define-values (drivers guide) (parse-t (unbox td) depth esc?))
|
||||
(values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))]
|
||||
[else (values (dset) (const-guide t))]))
|
||||
|
||||
;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide)
|
||||
(define (parse-h h depth esc?)
|
||||
(cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
|
||||
=> (lambda (h)
|
||||
(disappeared! (car h))
|
||||
(define-values (drivers guide) (parse-h (cadr h) depth esc?))
|
||||
(values drivers `(h-orelse ,guide null)))]
|
||||
[(and (not esc?) (parse-form h (quote-syntax ~?) 2))
|
||||
=> (lambda (h)
|
||||
(disappeared! (car h))
|
||||
(define-values (drivers1 guide1) (parse-h (cadr h) depth esc?))
|
||||
(define-values (drivers2 guide2) (parse-h (caddr h) depth esc?))
|
||||
(values (dset-union drivers1 drivers2)
|
||||
(if (and (ht-guide? guide1) (ht-guide? guide2))
|
||||
`(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
|
||||
`(h-orelse ,guide1 ,guide2))))]
|
||||
[(and (stx-pair? h)
|
||||
(let ([h-head (stx-car h)])
|
||||
(and (identifier? h-head)
|
||||
(or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?))
|
||||
(free-identifier=? h-head (quote-syntax ~@!))))))
|
||||
(disappeared! (stx-car h))
|
||||
(define-values (drivers guide) (parse-t (stx-cdr h) depth esc?))
|
||||
(values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))]
|
||||
[else
|
||||
(define-values (drivers guide) (parse-t h depth esc?))
|
||||
(values drivers `(h-t ,guide))]))
|
||||
|
||||
;; lookup : Identifier Nat -> PVar/#f
|
||||
(define (lookup id depth)
|
||||
(define (make-pvar var check pvar-depth)
|
||||
(cond [(zero? pvar-depth)
|
||||
(pvar var var check #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(pvar var (gentemp) check (- depth pvar-depth))]
|
||||
[(zero? depth)
|
||||
(wrong-syntax id "missing ellipsis with pattern variable in template")]
|
||||
[else
|
||||
(wrong-syntax id "too few ellipses for pattern variable in template")]))
|
||||
(define (hash-ref! h k proc)
|
||||
(let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*))))
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(define pvar-depth (syntax-mapping-depth v))
|
||||
(define attr
|
||||
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
|
||||
(and (attribute-mapping? attr) attr)))
|
||||
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
|
||||
(define check (and attr (attribute-mapping-check attr)))
|
||||
(make-pvar var check pvar-depth)))]
|
||||
[(s-exp-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(define pvar-depth (s-exp-mapping-depth v))
|
||||
(define var (s-exp-mapping-valvar v))
|
||||
(make-pvar var #f pvar-depth)))]
|
||||
[else
|
||||
;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute
|
||||
(for-each
|
||||
(lambda (pfx)
|
||||
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
|
||||
(if (and (syntax-pattern-variable? pfx-v)
|
||||
(let ([valvar (syntax-mapping-valvar pfx-v)])
|
||||
(attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
|
||||
(wrong-syntax id "undefined nested attribute of attribute `~a'"
|
||||
(syntax-e pfx))
|
||||
(void))))
|
||||
(dotted-prefixes id))
|
||||
#f])))
|
||||
|
||||
;; resyntax : Stx Guide -> Guide
|
||||
(define (resyntax t0 g)
|
||||
(if (and stx? (syntax? t0))
|
||||
(cond [(const-guide? g) (const-guide t0)]
|
||||
[else (optimize-resyntax t0 g)])
|
||||
g))
|
||||
|
||||
;; optimize-resyntax : Syntax Guide -> Guide
|
||||
(define (optimize-resyntax t0 g)
|
||||
(define HOLE (datum->syntax #f '_))
|
||||
(define (finish i rt rs re)
|
||||
(values (sub1 i) (reverse rs) (reverse re)
|
||||
(datum->syntax t0 (apply list* (reverse rt)) t0 t0)))
|
||||
(define (loop-gs list*? gs i rt rs re)
|
||||
(cond [(null? gs)
|
||||
(finish i (cons null rt) rs re)]
|
||||
[(and list*? (null? (cdr gs)))
|
||||
(loop-g (car gs) i rt rs re)]
|
||||
[else
|
||||
(define g0 (car gs))
|
||||
(cond [(const-guide? g0)
|
||||
(let ([const (const-guide-v g0)])
|
||||
(loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))]
|
||||
[(eq? (car g0) 't-subst) ;; (t-subst LOC STX <substs>)
|
||||
(let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _)
|
||||
[subargs (list-tail g0 3)])
|
||||
(loop-gs list*? (cdr gs) (add1 i) (cons subt rt)
|
||||
(list* i 'recur rs) (cons `(list . ,subargs) re)))]
|
||||
[else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt)
|
||||
(cons i rs) (cons g0 re))])]))
|
||||
(define (loop-g g i rt rs re)
|
||||
(cond [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)]
|
||||
[(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)]
|
||||
[(eq? (car g) 't-append)
|
||||
(loop-g (caddr g) (add1 i) (cons HOLE rt)
|
||||
(list* i 'append rs) (cons (cadr g) re))]
|
||||
[(eq? (car g) 't-const)
|
||||
(let ([const (const-guide-v g)])
|
||||
(finish i (cons const rt) rs re))]
|
||||
[else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))]))
|
||||
(define-values (npairs substs exprs t*) (loop-g g 0 null null null))
|
||||
(cond [(and substs
|
||||
;; Tunable condition for choosing whether to create a t-subst.
|
||||
;; Avoid creating useless (t-subst loc stx '(tail 0) g).
|
||||
(<= (length substs) (* 2 npairs)))
|
||||
#;(log-message template-logger 'debug
|
||||
(format "OPTIMIZED ~s" (syntax->datum t0)) #f)
|
||||
`(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)]
|
||||
[else
|
||||
#;(log-message template-logger 'debug
|
||||
(format "NOT opt ~s" (syntax->datum t0)) #f)
|
||||
(let ([rep (datum->syntax t0 'STX t0 t0)])
|
||||
`(t-resyntax #f (quote-syntax ,rep) ,g))]))
|
||||
|
||||
;; const-guide : Any -> Guide
|
||||
(define (const-guide x)
|
||||
(cond [(null? x) `(t-list)]
|
||||
[(not stx?) `(t-const (quote ,x))]
|
||||
[(syntax? x) `(t-const (quote-syntax ,x))]
|
||||
[else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))]))
|
||||
|
||||
(let-values ([(drivers guide) (parse-t t 0 #f)])
|
||||
(values (dset->list drivers) guide disappeared-uses)))
|
||||
|
||||
;; parse-form : Stx Id Nat -> (list[arity+1] Syntax)
|
||||
(define (parse-form stx form-id arity)
|
||||
(and (stx-pair? stx)
|
||||
(let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)])
|
||||
(and (identifier? stx-h) (free-identifier=? stx-h form-id)
|
||||
(let ([stx-tl (stx->list stx-t)])
|
||||
(and (list? stx-tl)
|
||||
(= (length stx-tl) arity)
|
||||
(cons stx-h stx-tl)))))))
|
||||
|
||||
;; lookup-metafun : Identifier -> Metafunction/#f
|
||||
(define (lookup-metafun id)
|
||||
(define v (syntax-local-value id (lambda () #f)))
|
||||
(and (metafunction? v) v))
|
||||
|
||||
(define (dotted-prefixes id)
|
||||
(let* ([id-string (symbol->string (syntax-e id))]
|
||||
[dot-locations
|
||||
(let loop ([i 0])
|
||||
(if (< i (string-length id-string))
|
||||
(if (eqv? (string-ref id-string i) #\.)
|
||||
(cons i (loop (add1 i)))
|
||||
(loop (add1 i)))
|
||||
null))])
|
||||
(map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc))))
|
||||
dot-locations)))
|
||||
|
||||
(define (pvar/dd<=? expected-dd)
|
||||
(lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))))
|
||||
|
||||
(define gentemp-counter 0)
|
||||
(define (gentemp)
|
||||
(set! gentemp-counter (add1 gentemp-counter))
|
||||
((make-syntax-introducer)
|
||||
(datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter)))))
|
||||
|
||||
(define (stx-drop n x)
|
||||
(if (zero? n) x (stx-drop (sub1 n) (stx-cdr x))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Deterministic Sets
|
||||
;; FIXME: detect big unions, use hash table
|
||||
|
||||
(define (dset . xs) xs)
|
||||
(define (dset-empty? ds) (null? ds))
|
||||
(define (dset-filter ds pred) (filter pred ds))
|
||||
(define (dset->list ds) ds)
|
||||
(define (dset-union ds1 ds2)
|
||||
(if (pair? ds1)
|
||||
(let ([elem (car ds1)])
|
||||
(if (member elem ds2)
|
||||
(dset-union (cdr ds1) ds2)
|
||||
(dset-union (cdr ds1) (cons (car ds1) ds2))))
|
||||
ds2))
|
||||
|
||||
(define (filter keep? xs)
|
||||
(if (pair? xs)
|
||||
(if (keep? (car xs))
|
||||
(cons (car xs) (filter keep? (cdr xs)))
|
||||
(filter keep? (cdr xs)))
|
||||
null))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Relocating (eg, syntax/loc)
|
||||
|
||||
;; Only relocate if relocation would affect a syntax pair originating
|
||||
;; from template structure. For example (x,y are pvars):
|
||||
;; (syntax/loc loc-stx (1 2 3)) => relocate
|
||||
;; (syntax/loc loc-stx y) => don't relocate
|
||||
;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x!
|
||||
;; Deciding whether to relocate after the fact is hard. But with explicit
|
||||
;; t-resyntax, it's much easier.
|
||||
|
||||
;; relocate-guide : Syntax Guide Id -> Guide
|
||||
(define (relocate-guide ctx g0 loc-id)
|
||||
(define (loop g)
|
||||
(define gtag (car g))
|
||||
(cond [(eq? gtag 't-resyntax)
|
||||
`(t-resyntax ,loc-id . ,(cddr g))]
|
||||
[(eq? gtag 't-const)
|
||||
`(t-relocate ,g ,loc-id)]
|
||||
[(eq? gtag 't-subst)
|
||||
`(t-subst ,loc-id . ,(cddr g))]
|
||||
;; ----
|
||||
[(eq? gtag 't-escaped)
|
||||
`(t-escaped ,(loop (cadr g)))]
|
||||
[(eq? gtag 't-orelse)
|
||||
`(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))]
|
||||
;; ----
|
||||
;; Nothing else should be relocated
|
||||
[else g]))
|
||||
(loop g0))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
|
||||
(define (do-template ctx tstx loc-id stx?)
|
||||
(define-values (pvars pre-guide disappeared-uses)
|
||||
(parse-template ctx tstx stx?))
|
||||
(define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
|
||||
(define ell-pvars (filter pvar-dd pvars))
|
||||
(define pre-code
|
||||
(if (const-guide? guide)
|
||||
(if stx? `(quote-syntax ,tstx) `(quote ,tstx))
|
||||
(let ([lvars (map pvar-lvar ell-pvars)]
|
||||
[valvars (map pvar-var ell-pvars)])
|
||||
`(let (,@(map list lvars valvars))
|
||||
,(datum->syntax here-stx guide)))))
|
||||
(define code (syntax-arm (datum->syntax here-stx pre-code ctx)))
|
||||
(syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses)))
|
||||
)
|
||||
|
||||
(define-syntax (syntax stx)
|
||||
(define s (syntax->list stx))
|
||||
(if (and (list? s) (= (length s) 2))
|
||||
(do-template stx (cadr s) #f #t)
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
|
||||
(define-syntax (syntax/loc stx)
|
||||
(define s (syntax->list stx))
|
||||
(if (and (list? s) (= (length s) 3))
|
||||
(let ([loc-id (quote-syntax loc)])
|
||||
(define code
|
||||
`(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))])
|
||||
,(do-template stx (caddr s) loc-id #t)))
|
||||
(syntax-arm (datum->syntax here-stx code stx)))
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
|
||||
(define-syntax (datum stx)
|
||||
(define s (syntax->list stx))
|
||||
(if (and (list? s) (= (length s) 2))
|
||||
(do-template stx (cadr s) #f #f)
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
|
||||
;; check-loc : Symbol Any -> (U Syntax #f)
|
||||
;; Raise exn if not syntax. Returns same syntax if suitable for srcloc
|
||||
;; (ie, if at least syntax-source or syntax-position set), #f otherwise.
|
||||
(define (check-loc who x)
|
||||
(if (syntax? x)
|
||||
(if (or (syntax-source x) (syntax-position x))
|
||||
x
|
||||
#f)
|
||||
(raise-argument-error who "syntax?" x)))
|
||||
|
||||
;; ============================================================
|
||||
;; Run-time support
|
||||
|
||||
;; (t-dots cons? hguide hdrivers) : Expr[(Listof Syntax)]
|
||||
(define-syntax (t-dots stx)
|
||||
(define s (syntax->list stx))
|
||||
(define cons? (syntax-e (list-ref s 1)))
|
||||
(define head (list-ref s 2))
|
||||
(define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar)
|
||||
(define in-stx (list-ref s 4))
|
||||
(define at-stx (list-ref s 5))
|
||||
(cond
|
||||
;; Case 1: (x ...) where x is trusted
|
||||
[(and cons? (let ([head-s (syntax->list head)])
|
||||
(and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var))))
|
||||
head]
|
||||
;; General case
|
||||
[else
|
||||
;; var-value-expr : Id Id/#'#f -> Expr[List]
|
||||
(define (var-value-expr lvar check)
|
||||
(if (syntax-e check) `(,check ,lvar 1 #f #f) lvar))
|
||||
(define lvars (map pvar-lvar drivers))
|
||||
(define checks (map pvar-check drivers))
|
||||
(define code
|
||||
`(let ,(map list lvars (map var-value-expr lvars checks))
|
||||
,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void))
|
||||
,(if cons?
|
||||
`(map (lambda ,lvars ,head) . ,lvars)
|
||||
`(apply append (map (lambda ,lvars ,head) . ,lvars)))))
|
||||
(datum->syntax here-stx code stx)]))
|
||||
|
||||
(define-syntaxes (t-orelse h-orelse)
|
||||
(let ()
|
||||
(define (orelse-transformer stx)
|
||||
(define s (syntax->list stx))
|
||||
(datum->syntax here-stx
|
||||
`(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s)))))
|
||||
(values orelse-transformer orelse-transformer)))
|
||||
|
||||
(#%require (rename '#%kernel t-const #%expression)
|
||||
(rename '#%kernel t-var #%expression)
|
||||
;; (rename '#%kernel t-append append)
|
||||
(rename '#%kernel t-list list)
|
||||
(rename '#%kernel t-list* list*)
|
||||
(rename '#%kernel t-escaped #%expression)
|
||||
(rename '#%kernel t-vector list->vector)
|
||||
(rename '#%kernel t-box box-immutable)
|
||||
(rename '#%kernel h-t list))
|
||||
|
||||
(begin-encourage-inline
|
||||
|
||||
(define (t-append xs ys) (if (null? ys) xs (append xs ys)))
|
||||
(define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx))
|
||||
(define (t-relocate g loc) (datum->syntax g (syntax-e g) (or loc g) g))
|
||||
(define (t-orelse* g1 g2)
|
||||
((let/ec escape
|
||||
(with-continuation-mark
|
||||
absent-pvar-escape-key
|
||||
(lambda () (escape g2))
|
||||
(let ([v (g1)]) (lambda () v))))))
|
||||
(define (t-struct key g) (apply make-prefab-struct key g))
|
||||
(define (t-metafun mf g stx)
|
||||
(mf (datum->syntax stx (cons (stx-car stx) g) stx stx)))
|
||||
(define (h-splice g in-stx at-stx)
|
||||
(if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx)))
|
||||
|
||||
#| end begin-encourage-inline |#)
|
||||
|
||||
;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax
|
||||
;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs)
|
||||
;; There is one arg for each index in substs. See also defn of Guide above.
|
||||
(define (t-subst loc stx substs . args)
|
||||
(define (loop/mode s i mode seek substs args)
|
||||
(cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))]
|
||||
[(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
|
||||
[(eq? mode 'tail) (car args)]
|
||||
[(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
|
||||
[(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args))
|
||||
(loop (cdr s) (add1 i) substs (cdr args)))]))
|
||||
(define (loop s i substs args)
|
||||
(cond [(null? substs) s]
|
||||
[(symbol? (car substs))
|
||||
(loop/mode s i (car substs) (cadr substs) (cddr substs) args)]
|
||||
[else (loop/mode s i #f (car substs) (cdr substs) args)]))
|
||||
(define v (loop (syntax-e stx) 0 substs args))
|
||||
(datum->syntax stx v (or loc stx) stx))
|
||||
|
||||
(define absent-pvar-escape-key (gensym 'absent-pvar-escape))
|
||||
|
||||
;; signal-absent-pvar : -> escapes or #f
|
||||
;; Note: Only escapes if in ~? form.
|
||||
(define (signal-absent-pvar)
|
||||
(let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)])
|
||||
(if escape (escape) #f)))
|
||||
|
||||
;; error/splice : Any Stx Stx -> (escapes)
|
||||
(define (error/splice r in-stx at-stx)
|
||||
(raise-syntax-error 'syntax
|
||||
(format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx))
|
||||
|
||||
;; check-same-length : Stx Stx List ... -> Void
|
||||
(define check-same-length
|
||||
(case-lambda
|
||||
[(in at a) (void)]
|
||||
[(in at a b)
|
||||
(if (= (length a) (length b))
|
||||
(void)
|
||||
(raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
|
||||
(list in '...) at))]
|
||||
[(in at a . bs)
|
||||
(define alen (length a))
|
||||
(for-each (lambda (b)
|
||||
(if (= alen (length b))
|
||||
(void)
|
||||
(raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
|
||||
(list in '...) at)))
|
||||
bs)]))
|
||||
|
||||
)
|
||||
100
7-0-0-20/racket/collects/racket/private/with-stx.rkt
Normal file
100
7-0-0-20/racket/collects/racket/private/with-stx.rkt
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
;;----------------------------------------------------------------------
|
||||
;; with-syntax, generate-temporaries
|
||||
|
||||
(module with-stx '#%kernel
|
||||
(#%require racket/private/stx racket/private/small-scheme "stxcase.rkt"
|
||||
(for-syntax '#%kernel racket/private/stx "stxcase.rkt"
|
||||
(all-except racket/private/stxloc syntax/loc) racket/private/sc
|
||||
racket/private/gen-temp racket/private/qq-and-or racket/private/cond))
|
||||
|
||||
(-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))
|
||||
31
7-0-0-20/racket/collects/syntax/parse.rkt
Normal file
31
7-0-0-20/racket/collects/syntax/parse.rkt
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/contract/base
|
||||
"parse/pre.rkt"
|
||||
"parse/experimental/provide.rkt"
|
||||
"parse/experimental/contract.rkt")
|
||||
(provide (except-out (all-from-out "parse/pre.rkt")
|
||||
static)
|
||||
expr/c)
|
||||
(provide-syntax-class/contract
|
||||
[static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])])
|
||||
|
||||
(begin-for-syntax
|
||||
(require racket/contract/base
|
||||
syntax/parse/private/residual-ct)
|
||||
(provide pattern-expander?
|
||||
(contract-out
|
||||
[pattern-expander
|
||||
(-> (-> syntax? syntax?) pattern-expander?)]
|
||||
[prop:pattern-expander
|
||||
(struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
|
||||
[syntax-local-syntax-parse-pattern-introduce
|
||||
(-> syntax? syntax?)]))
|
||||
|
||||
(require (only-in (for-template syntax/parse) pattern-expander))
|
||||
#;(define pattern-expander
|
||||
(let ()
|
||||
#;(struct pattern-expander (proc) #:transparent
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:pattern-expander (λ (this) (pattern-expander-proc this)))
|
||||
pattern-expander)))
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket/base
|
||||
(require stxparse-info/parse/pre
|
||||
"provide.rkt"
|
||||
syntax/contract
|
||||
(only-in stxparse-info/parse/private/residual ;; keep abs. path
|
||||
this-context-syntax
|
||||
this-role)
|
||||
racket/contract/base)
|
||||
|
||||
(define not-given (gensym))
|
||||
|
||||
(define-syntax-class (expr/c ctc-stx
|
||||
#:positive [pos-blame 'use-site]
|
||||
#:negative [neg-blame 'from-macro]
|
||||
#:macro [macro-name #f]
|
||||
#:name [expr-name not-given]
|
||||
#:context [ctx #f])
|
||||
#:attributes (c)
|
||||
#:commit
|
||||
(pattern y:expr
|
||||
#:with
|
||||
c (wrap-expr/c ctc-stx
|
||||
#'y
|
||||
#:positive pos-blame
|
||||
#:negative neg-blame
|
||||
#:name (if (eq? expr-name not-given)
|
||||
this-role
|
||||
expr-name)
|
||||
#:macro macro-name
|
||||
#:context (or ctx (this-context-syntax)))))
|
||||
|
||||
(provide-syntax-class/contract
|
||||
[expr/c (syntax-class/c (syntax?)
|
||||
(#:positive (or/c syntax? string? module-path-index?
|
||||
'from-macro 'use-site 'unknown)
|
||||
#:negative (or/c syntax? string? module-path-index?
|
||||
'from-macro 'use-site 'unknown)
|
||||
#:name (or/c identifier? string? symbol? #f)
|
||||
#:macro (or/c identifier? string? symbol? #f)
|
||||
#:context (or/c syntax? #f)))])
|
||||
156
7-0-0-20/racket/collects/syntax/parse/experimental/provide.rkt
Normal file
156
7-0-0-20/racket/collects/syntax/parse/experimental/provide.rkt
Normal file
|
|
@ -0,0 +1,156 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
racket/contract/combinator
|
||||
syntax/location
|
||||
(for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse/private/minimatch
|
||||
stxparse-info/parse/pre
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
syntax/parse/private/kws
|
||||
syntax/contract))
|
||||
(provide provide-syntax-class/contract
|
||||
syntax-class/c
|
||||
splicing-syntax-class/c)
|
||||
|
||||
;; FIXME:
|
||||
;; - seems to get first-requiring-module wrong, not surprising
|
||||
;; - extend to contracts on attributes?
|
||||
;; - syntax-class/c etc just a made-up name, for now
|
||||
;; (connect to dynamic syntax-classes, eventually)
|
||||
|
||||
(define-syntaxes (syntax-class/c splicing-syntax-class/c)
|
||||
(let ([nope
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))])
|
||||
(values nope nope)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab
|
||||
#:omit-define-syntaxes))
|
||||
|
||||
(begin-for-syntax
|
||||
;; do-one-contract : stx id stxclass ctcrec id -> stx
|
||||
(define (do-one-contract stx scname stxclass rec pos-module-source)
|
||||
;; First, is the contract feasible?
|
||||
(match (stxclass-arity stxclass)
|
||||
[(arity minpos maxpos minkws maxkws)
|
||||
(let* ([minpos* (length (ctcrec-mpcs rec))]
|
||||
[maxpos* (+ minpos* (length (ctcrec-opcs rec)))]
|
||||
[minkws* (sort (map syntax-e (ctcrec-mkws rec)) keyword<?)]
|
||||
[maxkws* (sort (append minkws* (map syntax-e (ctcrec-okws rec))) keyword<?)])
|
||||
(define (err msg . args)
|
||||
(apply wrong-syntax scname msg args))
|
||||
(unless (<= minpos minpos*)
|
||||
(err (string-append "expected a syntax class with at most ~a "
|
||||
"required positional arguments, got one with ~a")
|
||||
minpos* minpos))
|
||||
(unless (<= maxpos* maxpos)
|
||||
(err (string-append "expected a syntax class with at least ~a "
|
||||
"total positional arguments (required and optional), "
|
||||
"got one with ~a")
|
||||
maxpos* maxpos))
|
||||
(unless (null? (diff/sorted/eq minkws minkws*))
|
||||
(err (string-append "expected a syntax class with at most the "
|
||||
"required keyword arguments ~a, got one with ~a")
|
||||
(join-sep (map kw->string minkws*) "," "and")
|
||||
(join-sep (map kw->string minkws) "," "and")))
|
||||
(unless (null? (diff/sorted/eq maxkws* maxkws))
|
||||
(err (string-append "expected a syntax class with at least the optional "
|
||||
"keyword arguments ~a, got one with ~a")
|
||||
(join-sep (map kw->string maxkws*) "," "and")
|
||||
(join-sep (map kw->string maxkws) "," "and")))
|
||||
(with-syntax ([scname scname]
|
||||
[#s(stxclass name arity attrs parser splicing? opts inline)
|
||||
stxclass]
|
||||
[#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
|
||||
(opc ...) (okw ...) (okwc ...))
|
||||
rec]
|
||||
[arity* (arity minpos* maxpos* minkws* maxkws*)]
|
||||
[(parser-contract contracted-parser contracted-scname)
|
||||
(generate-temporaries #`(contract parser #,scname))])
|
||||
(with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))]
|
||||
[(mkwc-id ...) (generate-temporaries #'(mkwc ...))]
|
||||
[(opc-id ...) (generate-temporaries #'(opc ...))]
|
||||
[(okwc-id ...) (generate-temporaries #'(okwc ...))])
|
||||
(with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)]
|
||||
[((okw-c-part ...) ...) #'((okw okwc-id) ...)]
|
||||
[((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)]
|
||||
[((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)])
|
||||
#`(begin
|
||||
(define parser-contract
|
||||
(let ([mpc-id mpc] ...
|
||||
[mkwc-id mkwc] ...
|
||||
[opc-id opc] ...
|
||||
[okwc-id okwc] ...)
|
||||
(rename-contract
|
||||
(->* (any/c any/c any/c any/c any/c any/c any/c any/c any/c
|
||||
mpc-id ... mkw-c-part ... ...)
|
||||
(okw-c-part ... ...)
|
||||
any)
|
||||
`(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c)
|
||||
[,(contract-name mpc-id) ... mkw-name-part ... ...]
|
||||
[okw-name-part ... ...]))))
|
||||
(define-module-boundary-contract contracted-parser
|
||||
parser parser-contract #:pos-source #,pos-module-source)
|
||||
(define-syntax contracted-scname
|
||||
(make-stxclass
|
||||
(quote-syntax name)
|
||||
'arity*
|
||||
'attrs
|
||||
(quote-syntax contracted-parser)
|
||||
'splicing?
|
||||
'opts #f)) ;; must disable inlining
|
||||
(provide (rename-out [contracted-scname scname])))))))])))
|
||||
|
||||
(define-syntax (provide-syntax-class/contract stx)
|
||||
|
||||
(define-syntax-class stxclass-ctc
|
||||
#:description "syntax-class/c or splicing-syntax-class/c form"
|
||||
#:literals (syntax-class/c splicing-syntax-class/c)
|
||||
#:attributes (rec)
|
||||
#:commit
|
||||
(pattern ((~or syntax-class/c splicing-syntax-class/c)
|
||||
mand:ctclist
|
||||
(~optional opt:ctclist))
|
||||
#:attr rec (make-ctcrec (attribute mand.pc.c)
|
||||
(attribute mand.kw)
|
||||
(attribute mand.kwc.c)
|
||||
(or (attribute opt.pc.c) '())
|
||||
(or (attribute opt.kw) '())
|
||||
(or (attribute opt.kwc.c) '()))))
|
||||
|
||||
(define-syntax-class ctclist
|
||||
#:attributes ([pc.c 1] [kw 1] [kwc.c 1])
|
||||
#:commit
|
||||
(pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...)
|
||||
#:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))])
|
||||
(wrap-expr/c #'contract? pc-expr))
|
||||
#:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))])
|
||||
(wrap-expr/c #'contract? kwc-expr))))
|
||||
|
||||
(syntax-parse stx
|
||||
[(_ [scname c:stxclass-ctc] ...)
|
||||
#:declare scname (static stxclass? "syntax class")
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(with-disappeared-uses
|
||||
#`(begin (define pos-module-source (quote-module-name))
|
||||
#,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
|
||||
[stxclass (in-list (attribute scname.value))]
|
||||
[rec (in-list (attribute c.rec))])
|
||||
(do-one-contract stx scname stxclass rec #'pos-module-source)))))]))
|
||||
|
||||
;; Copied from unstable/contract,
|
||||
;; which requires racket/contract, not racket/contract/base
|
||||
|
||||
;; rename-contract : contract any/c -> contract
|
||||
;; If the argument is a flat contract, so is the result.
|
||||
(define (rename-contract ctc name)
|
||||
(let ([ctc (coerce-contract 'rename-contract ctc)])
|
||||
(if (flat-contract? ctc)
|
||||
(flat-named-contract name (flat-contract-predicate ctc))
|
||||
(let* ([ctc-fo (contract-first-order ctc)]
|
||||
[late-neg-proj (contract-late-neg-projection ctc)])
|
||||
(make-contract #:name name
|
||||
#:late-neg-projection late-neg-proj
|
||||
#:first-order ctc-fo)))))
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse/private/kws
|
||||
syntax/parse/private/rep-data
|
||||
"../private/rep.rkt")
|
||||
"../private/runtime.rkt")
|
||||
(provide define-syntax-class/specialize)
|
||||
|
||||
(define-syntax (define-syntax-class/specialize stx)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(dscs header sc-expr)
|
||||
(with-disappeared-uses
|
||||
(let-values ([(name formals arity)
|
||||
(let ([p (check-stxclass-header #'header stx)])
|
||||
(values (car p) (cadr p) (caddr p)))]
|
||||
[(target-scname argu)
|
||||
(let ([p (check-stxclass-application #'sc-expr stx)])
|
||||
(values (car p) (cdr p)))])
|
||||
(let* ([pos-count (length (arguments-pargs argu))]
|
||||
[kws (arguments-kws argu)]
|
||||
[target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
|
||||
(with-syntax ([name name]
|
||||
[formals formals]
|
||||
[parser (generate-temporary (format-symbol "parser-~a" #'name))]
|
||||
[splicing? (stxclass-splicing? target)]
|
||||
[arity arity]
|
||||
[attrs (stxclass-attrs target)]
|
||||
[opts (stxclass-opts target)]
|
||||
[target-parser (stxclass-parser target)]
|
||||
[argu argu])
|
||||
#`(begin (define-syntax name
|
||||
(stxclass 'name 'arity 'attrs
|
||||
(quote-syntax parser)
|
||||
'splicing?
|
||||
'opts #f))
|
||||
(define-values (parser)
|
||||
(lambda (x cx pr es undos fh0 cp0 rl success . formals)
|
||||
(app-argu target-parser x cx pr es undos fh0 cp0 rl success argu))))))))])))
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
stxparse-info/parse
|
||||
racket/lazy-require
|
||||
syntax/parse/private/kws)
|
||||
stxparse-info/parse/private/residual) ;; keep abs. path
|
||||
(provide define-primitive-splicing-syntax-class)
|
||||
|
||||
(begin-for-syntax
|
||||
(lazy-require
|
||||
[syntax/parse/private/rep-attrs
|
||||
(sort-sattrs)]))
|
||||
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
|
||||
;; Without this, dependencies don't get collected.
|
||||
(require racket/runtime-path (for-meta 2 '#%kernel))
|
||||
(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-attrs)
|
||||
|
||||
(define-syntax (define-primitive-splicing-syntax-class stx)
|
||||
|
||||
(define-syntax-class attr
|
||||
#:commit
|
||||
(pattern name:id
|
||||
#:with depth #'0)
|
||||
(pattern [name:id depth:nat]))
|
||||
|
||||
(syntax-parse stx
|
||||
[(dssp (name:id param:id ...)
|
||||
(~or (~once (~seq #:attributes (a:attr ...))
|
||||
#:name "attributes declaration")
|
||||
(~once (~seq #:description description)
|
||||
#:name "description declaration")) ...
|
||||
proc:expr)
|
||||
#'(begin
|
||||
(define (get-description param ...)
|
||||
description)
|
||||
(define parser
|
||||
(let ([permute (mk-permute '(a.name ...))])
|
||||
(lambda (x cx pr es undos fh _cp rl success param ...)
|
||||
(let ([stx (datum->syntax cx x cx)])
|
||||
(let ([result
|
||||
(let/ec escape
|
||||
(cons 'ok
|
||||
(proc stx
|
||||
(lambda ([msg #f] [stx #f])
|
||||
(escape (list 'error msg stx))))))])
|
||||
(case (car result)
|
||||
((ok)
|
||||
(apply success
|
||||
((mk-check-result pr 'name (length '(a.name ...)) permute x cx undos fh)
|
||||
(cdr result))))
|
||||
((error)
|
||||
(let ([es
|
||||
(es-add-message (cadr result)
|
||||
(es-add-thing pr (get-description param ...) #f rl es))])
|
||||
(fh undos (failure pr es))))))))))
|
||||
(define-syntax name
|
||||
(stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
|
||||
(sort-sattrs '(#s(attr a.name a.depth #f) ...))
|
||||
(quote-syntax parser)
|
||||
#t
|
||||
(scopts (length '(a.name ...)) #t #t #f)
|
||||
#f)))]))
|
||||
|
||||
(define (mk-permute unsorted-attrs)
|
||||
(let ([sorted-attrs
|
||||
(sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)])
|
||||
(if (equal? unsorted-attrs sorted-attrs)
|
||||
values
|
||||
(let* ([pos-table
|
||||
(for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)])
|
||||
(values a i))]
|
||||
[indexes
|
||||
(for/vector ([a (in-list sorted-attrs)])
|
||||
(hash-ref pos-table a))])
|
||||
(lambda (result)
|
||||
(for/list ([index (in-vector indexes)])
|
||||
(list-ref result index)))))))
|
||||
|
||||
(define (mk-check-result pr name attr-count permute x cx undos fh)
|
||||
(lambda (result)
|
||||
(unless (list? result)
|
||||
(error name "parser returned non-list"))
|
||||
(let ([rlength (length result)])
|
||||
(unless (= rlength (+ 1 attr-count))
|
||||
(error name "parser returned list of wrong length; expected length ~s, got ~e"
|
||||
(+ 1 attr-count)
|
||||
result))
|
||||
(let ([skip (car result)])
|
||||
;; Compute rest-x & rest-cx from skip
|
||||
(unless (exact-nonnegative-integer? skip)
|
||||
(error name "expected exact nonnegative integer for first element of result list, got ~e"
|
||||
skip))
|
||||
(let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
|
||||
(list* fh undos rest-x rest-cx (ps-add-cdr pr skip)
|
||||
(permute (cdr result))))))))
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/struct
|
||||
auto-syntax-e/utils)
|
||||
(only-in racket/private/template
|
||||
metafunction))
|
||||
(provide (rename-out [syntax template]
|
||||
[syntax/loc template/loc]
|
||||
[quasisyntax quasitemplate]
|
||||
[quasisyntax/loc quasitemplate/loc]
|
||||
[~? ??]
|
||||
[~@ ?@])
|
||||
define-template-metafunction
|
||||
syntax-local-template-metafunction-introduce)
|
||||
|
||||
;; ============================================================
|
||||
;; Metafunctions
|
||||
|
||||
;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use
|
||||
;; the exported prop:template-metafunction, template-metafunction? and
|
||||
;; template-metafunction-accessor.
|
||||
(define-syntax (define-template-metafunction stx)
|
||||
(syntax-case stx ()
|
||||
[(dsm (id arg ...) . body)
|
||||
#'(dsm id (lambda (arg ...) . body))]
|
||||
[(dsm id expr)
|
||||
(identifier? #'id)
|
||||
(with-syntax ([(internal-id) (generate-temporaries #'(id))])
|
||||
#'(begin (define internal-id (make-hygienic-metafunction expr))
|
||||
(define-syntax id (metafunction (quote-syntax internal-id)))))]))
|
||||
|
||||
(define current-template-metafunction-introducer
|
||||
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
|
||||
|
||||
|
||||
(define old-template-metafunction-introducer
|
||||
(make-parameter #f))
|
||||
|
||||
(define (syntax-local-template-metafunction-introduce stx)
|
||||
(let ([mark (current-template-metafunction-introducer)]
|
||||
[old-mark (old-template-metafunction-introducer)])
|
||||
(unless old-mark
|
||||
(error 'syntax-local-template-metafunction-introduce
|
||||
"must be called within the dynamic extent of a template metafunction"))
|
||||
(mark (old-mark stx))))
|
||||
|
||||
(define ((make-hygienic-metafunction transformer) stx)
|
||||
(define mark (make-syntax-introducer))
|
||||
(define old-mark (current-template-metafunction-introducer))
|
||||
(parameterize ((current-template-metafunction-introducer mark)
|
||||
(old-template-metafunction-introducer old-mark))
|
||||
(define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
|
||||
(unless (syntax? r)
|
||||
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
|
||||
(old-mark (mark r))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user