suzanne.soy/stxparse-info
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Include upstream updates up until 37dde6dc1e23b22f63acaa75ae1ab4f6fb7ee675 (inclusive)

Browse Source
This commit is contained in:
Georges Dupéron 2018-05-23 22:22:25 +02:00
parent 02fc8c8cea
commit dda653e350
51 changed files with 8288 additions and 1094 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
case/stxcase-scheme.rkt
View File

@ -1,77 +1,12 @@
;;----------------------------------------------------------------------
;; #%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?)))
#lang racket/base
(#%require version-case
(for-syntax (only racket/base version)
(only racket/base #%app #%datum))
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
(my-include "stxcase-scheme.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "stxcase-scheme.rkt-6-11")]
[else
(my-include "stxcase-scheme.rkt-6-90-0-29")])

77
case/stxcase-scheme.rkt-6-11 Normal file
View 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?)))

77
case/stxcase-scheme.rkt-6-90-0-29 Normal file
View 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?)))

622
case/stxcase.rkt
View File

@ -1,610 +1,12 @@
;;----------------------------------------------------------------------
;; 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?)))
#lang racket/base
(#%require version-case
(for-syntax (only racket/base version)
(only racket/base #%app #%datum))
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
(my-include "stxcase.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "stxcase.rkt-6-11")]
[else
(my-include "stxcase.rkt-6-90-0-29")])

610
case/stxcase.rkt-6-11 Normal file
View 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?)))

390
case/stxcase.rkt-6-90-0-29 Normal file
View 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/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?)))

92
case/stxloc.rkt
View File

@ -1,80 +1,12 @@
;;----------------------------------------------------------------------
;; 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 ... _))
#lang racket/base
(#%require version-case
(for-syntax (only racket/base version)
(only racket/base #%app #%datum))
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
(my-include "stxloc.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "stxloc.rkt-6-11")]
[else
(my-include "stxloc.rkt-6-90-0-29")])

80
case/stxloc.rkt-6-11 Normal file
View 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 ... _))

59
case/stxloc.rkt-6-90-0-29 Normal file
View 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
... _ ~? ~@))

222
case/syntax.rkt
View File

@ -1,212 +1,12 @@
#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 ...))]))
(#%require version-case
(for-syntax (only racket/base version)
(only racket/base #%app #%datum))
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
(my-include "syntax.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "syntax.rkt-6-11")]
[else
(my-include "syntax.rkt-6-90-0-29")])

212
case/syntax.rkt-6-11 Normal file
View 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 ...))]))

214
case/syntax.rkt-6-90-0-29 Normal file
View 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 ...))]))

12
case/template.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang racket/base
(#%require version-case
(for-syntax (only racket/base version)
(only racket/base #%app #%datum))
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
(begin)]
[(version< (version) "6.90.0.29")
(begin)]
[else
(my-include "template.rkt-6-90-0-29")])

732
case/template.rkt-6-90-0-29 Normal file
View 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)]))
)

112
case/with-stx.rkt
View File

@ -1,100 +1,12 @@
;;----------------------------------------------------------------------
;; 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))
#lang racket/base
(#%require version-case
(for-syntax (only racket/base version)
(only racket/base #%app #%datum))
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
(my-include "with-stx.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "with-stx.rkt-6-11")]
[else
(my-include "with-stx.rkt-6-90-0-29")])

100
case/with-stx.rkt-6-11 Normal file
View 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))

100
case/with-stx.rkt-6-90-0-29 Normal file
View 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/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))

4
parse/debug.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "debug.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "debug.rkt-6-12")]
[else
(my-include "debug.rkt-6-12")])
(my-include "debug.rkt-6-90-0-29")])

127
parse/debug.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,127 @@
#lang racket/base
(require (for-syntax racket/base
syntax/stx
racket/syntax
syntax/parse/private/rep-data
"private/rep.rkt"
syntax/parse/private/kws)
racket/list
racket/pretty
"../parse.rkt"
(except-in stxparse-info/parse/private/residual
prop:pattern-expander syntax-local-syntax-parse-pattern-introduce)
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"
syntax/parse/private/kws)
;; No lazy loading for this module's dependencies.
(provide syntax-class-parse
syntax-class-attributes
syntax-class-arity
syntax-class-keywords
debug-rhs
debug-pattern
debug-parse
debug-syntax-parse!)
(define-syntax (syntax-class-parse stx)
(syntax-case stx ()
[(_ s x arg ...)
(parameterize ((current-syntax-context stx))
(with-disappeared-uses
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
[stxclass
(get-stxclass/check-arity #'s stx
(length (arguments-pargs argu))
(arguments-kws argu))]
[attrs (stxclass-attrs stxclass)])
(with-syntax ([parser (stxclass-parser stxclass)]
[argu argu]
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (fs) fs)])
(app-argu parser x x (ps-empty x x) #f null fh fh #f
(lambda (fh undos . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu))))))]))
(define-syntaxes (syntax-class-attributes
syntax-class-arity
syntax-class-keywords)
(let ()
(define ((mk handler) stx)
(syntax-case stx ()
[(_ s)
(parameterize ((current-syntax-context stx))
(with-disappeared-uses
(handler (get-stxclass #'s))))]))
(values (mk (lambda (s)
(let ([attrs (stxclass-attrs s)])
(with-syntax ([(a ...) (map attr-name attrs)]
[(d ...) (map attr-depth attrs)])
#'(quote ((a d) ...))))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a)))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(values '#,(arity-minkws a) '#,(arity-maxkws a))))))))
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f #f #:context stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p . rest)
(let-values ([(rest pattern defs)
(parse-pattern+sides #'p #'rest
#:splicing? #f
#:decls (new-declenv null)
#:context stx)])
(unless (stx-null? rest)
(raise-syntax-error #f "unexpected terms" stx rest))
#`(quote ((definitions . #,defs)
(pattern #,pattern))))]))
(define-syntax-rule (debug-parse x p ...)
(let/ec escape
(parameterize ((current-failure-handler
(lambda (_ fs)
(define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
(escape
`(parse-failure
#:raw-failures
,raw-fs-sexpr
#:maximal-failures
,maximal-fs-sexpr)))))
(syntax-parse x [p 'success] ...))))
(define (fs->sexprs fs)
(let* ([raw-fs (map invert-failure (reverse (flatten fs)))]
[selected-groups (maximal-failures raw-fs)])
(values (failureset->sexpr raw-fs)
(let ([selected (map (lambda (fs)
(cons 'progress-class
(map failure->sexpr fs)))
selected-groups)])
(if (= (length selected) 1)
(car selected)
(cons 'union selected))))))
(define (debug-syntax-parse!)
(define old-failure-handler (current-failure-handler))
(current-failure-handler
(lambda (ctx fs)
(define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
(eprintf "*** syntax-parse debug info ***\n")
(eprintf "Raw failures:\n")
(pretty-write raw-fs-sexpr (current-error-port))
(eprintf "Maximal failures:\n")
(pretty-write maximal-fs-sexpr (current-error-port))
(old-failure-handler ctx fs))))

2
parse/experimental/private/substitute.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "substitute.rkt-6-11")]
[(version< (version) "6.90.0.29")
(begin)]
[else
(begin)])

4
parse/experimental/provide.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "provide.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "provide.rkt-6-12")]
[else
(my-include "provide.rkt-6-12")])
(my-include "provide.rkt-6-90-0-29")])

156
parse/experimental/provide.rkt-6-90-0-29 Normal file
View 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)))))

4
parse/experimental/reflect.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "reflect.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "reflect.rkt-6-12")]
[else
(my-include "reflect.rkt-6-12")])
(my-include "reflect.rkt-6-90-0-29")])

149
parse/experimental/reflect.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,149 @@
#lang racket/base
(require (for-syntax racket/base
racket/lazy-require
racket/syntax
syntax/parse/private/residual-ct) ;; keep abs.path
racket/contract/base
racket/contract/combinator
syntax/parse/private/minimatch
syntax/parse/private/keywords
"../private/runtime-reflect.rkt"
syntax/parse/private/kws)
(begin-for-syntax
(lazy-require
[syntax/parse/private/rep-data ;; keep abs. path
(get-stxclass)]))
;; 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-data)
(define-syntax (reify-syntax-class stx)
(if (eq? (syntax-local-context) 'expression)
(syntax-case stx ()
[(rsc sc)
(with-disappeared-uses
(let* ([stxclass (get-stxclass #'sc)]
[splicing? (stxclass-splicing? stxclass)])
(unless (scopts-delimit-cut? (stxclass-opts stxclass))
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
stx #'sc))
(with-syntax ([name (stxclass-name stxclass)]
[parser (stxclass-parser stxclass)]
[arity (stxclass-arity stxclass)]
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
[ctor
(if splicing?
#'reified-splicing-syntax-class
#'reified-syntax-class)])
#'(ctor 'name parser 'arity '((aname adepth) ...)))))])
#`(#%expression #,stx)))
(define (reified-syntax-class-arity r)
(match (reified-arity r)
[(arity minpos maxpos _ _)
(to-procedure-arity minpos maxpos)]))
(define (reified-syntax-class-keywords r)
(match (reified-arity r)
[(arity _ _ minkws maxkws)
(values minkws maxkws)]))
(define (reified-syntax-class-attributes r)
(reified-signature r))
(define reified-syntax-class-curry
(make-keyword-procedure
(lambda (kws1 kwargs1 r . rest1)
(match r
[(reified name parser arity1 sig)
(let ()
(check-curry arity1 (length rest1) kws1
(lambda (msg)
(raise-mismatch-error 'reified-syntax-class-curry
(string-append msg ": ") r)))
(let* ([curried-arity
(match arity1
[(arity minpos maxpos minkws maxkws)
(let* ([rest1-length (length rest1)]
[minpos* (- minpos rest1-length)]
[maxpos* (- maxpos rest1-length)]
[minkws* (sort (remq* kws1 minkws) keyword<?)]
[maxkws* (sort (remq* kws1 maxkws) keyword<?)])
(arity minpos* maxpos* minkws* maxkws*))])]
[curried-parser
(make-keyword-procedure
(lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
(keyword-apply parser kws kwargs x cx pr es undos fh cp rl success
(append rest1 rest2)))))]
[ctor
(cond [(reified-syntax-class? r)
reified-syntax-class]
[(reified-splicing-syntax-class? r)
reified-splicing-syntax-class]
[else
(error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])])
(ctor name curried-parser curried-arity sig)))]))))
(define (merge2 kws1 kws2 kwargs1 kwargs2)
(cond [(null? kws1)
(values kws2 kwargs2)]
[(null? kws2)
(values kws1 kwargs1)]
[(keyword<? (car kws1) (car kws2))
(let-values ([(m-kws m-kwargs)
(merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)])
(values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))]
[else
(let-values ([(m-kws m-kwargs)
(merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))])
(values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))]))
;; ----
(provide reify-syntax-class
~reflect
~splicing-reflect)
(provide/contract
[reified-syntax-class?
(-> any/c boolean?)]
[reified-splicing-syntax-class?
(-> any/c boolean?)]
[reified-syntax-class-attributes
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
(listof (list/c symbol? exact-nonnegative-integer?)))]
[reified-syntax-class-arity
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
procedure-arity?)]
[reified-syntax-class-keywords
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
(values (listof keyword?)
(listof keyword?)))]
[reified-syntax-class-curry
(make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c))
(#:<kw> any/c ...)
#:rest list?
(or/c reified-syntax-class? reified-splicing-syntax-class/c))
#:late-neg-projection
(lambda (blame)
(let ([check-reified
((contract-late-neg-projection
(or/c reified-syntax-class? reified-splicing-syntax-class?))
(blame-swap blame))])
(lambda (f neg-party)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(make-keyword-procedure
(lambda (kws kwargs r . args)
(keyword-apply f kws kwargs (check-reified r neg-party) args)))
(raise-blame-error
blame #:missing-party neg-party
f
"expected a procedure of at least one argument, given ~e"
f)))))
#:first-order
(lambda (f)
(and (procedure? f) (procedure-arity-includes? f))))])

4
parse/experimental/specialize.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "specialize.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "specialize.rkt-6-12")]
[else
(my-include "specialize.rkt-6-12")])
(my-include "specialize.rkt-6-90-0-29")])

40
parse/experimental/specialize.rkt-6-90-0-29 Normal file
View File

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

4
parse/experimental/splicing.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "splicing.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "splicing.rkt-6-12")]
[else
(my-include "splicing.rkt-6-12")])
(my-include "splicing.rkt-6-90-0-29")])

95
parse/experimental/splicing.rkt-6-90-0-29 Normal file
View File

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

4
parse/experimental/template.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "template.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "template.rkt-6-12")]
[else
(my-include "template.rkt-6-12")])
(my-include "template.rkt-6-90-0-29")])

55
parse/experimental/template.rkt-6-90-0-29 Normal file
View File

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

4
parse/pre.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "pre.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "pre.rkt-6-12")]
[else
(my-include "pre.rkt-6-12")])
(my-include "pre.rkt-6-90-0-29")])

50
parse/pre.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,50 @@
#lang racket/base
(require "private/sc.rkt"
"private/litconv.rkt"
"private/lib.rkt"
"private/residual.rkt")
(provide (except-out (all-from-out "private/sc.rkt")
define-integrable-syntax-class
syntax-parser/template
parser/rhs)
(all-from-out "private/litconv.rkt")
(all-from-out "private/lib.rkt")
syntax-parse-state-ref
syntax-parse-state-set!
syntax-parse-state-update!
syntax-parse-state-cons!
syntax-parse-track-literals)
(define not-given (gensym))
(define (state-ref who key default)
(define state (current-state))
(if (eq? default not-given)
(if (hash-has-key? state key)
(hash-ref state key)
(error who "no value found for key\n key: ~e" key))
(hash-ref state key default)))
(define (syntax-parse-state-ref key [default not-given])
(state-ref 'syntax-parse-state-ref key default))
(define (check-update who)
(unless (current-state-writable?)
(error who "cannot update syntax-parse state outside of ~~do/#:do block")))
(define (syntax-parse-state-set! key value)
(check-update 'syntax-parse-state-set!)
(current-state (hash-set (current-state) key value)))
(define (syntax-parse-state-update! key update [default not-given])
(check-update 'syntax-parse-state-update!)
(define old (state-ref 'syntax-parse-state-update! key default))
(current-state (hash-set (current-state) key (update old))))
(define (syntax-parse-state-cons! key value [default null])
(check-update 'syntax-parse-state-cons!)
(define old (hash-ref (current-state) key default))
(current-state (hash-set (current-state) key (cons value old))))
(define (syntax-parse-track-literals stx #:introduce? [introduce? #t])
(track-literals 'syntax-parse-track-literals stx #:introduce? introduce?))

4
parse/private/lib.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "lib.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "lib.rkt-6-12")]
[else
(my-include "lib.rkt-6-12")])
(my-include "lib.rkt-6-90-0-29")])

88
parse/private/lib.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,88 @@
#lang racket/base
(require "sc.rkt"
syntax/parse/private/keywords
(only-in "residual.rkt" state-cons!)
(for-syntax syntax/parse/private/residual-ct)
(for-syntax racket/base))
(provide identifier
boolean
str
character
keyword
number
integer
exact-integer
exact-nonnegative-integer
exact-positive-integer
id
nat
char
expr
static)
(define (expr-stx? x)
(not (keyword-stx? x)))
(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x))))
(define keyword-stx? (stxof keyword?))
(define boolean-stx? (stxof boolean?))
(define string-stx? (stxof string?))
(define bytes-stx? (stxof bytes?))
(define char-stx? (stxof char?))
(define number-stx? (stxof number?))
(define integer-stx? (stxof integer?))
(define exact-integer-stx? (stxof exact-integer?))
(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?))
(define exact-positive-integer-stx? (stxof exact-positive-integer?))
;; == Integrable syntax classes ==
(define-integrable-syntax-class identifier (quote "identifier") identifier?)
(define-integrable-syntax-class expr (quote "expression") expr-stx?)
(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?)
(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?)
(define-integrable-syntax-class character (quote "character") char-stx?)
(define-integrable-syntax-class number (quote "number") number-stx?)
(define-integrable-syntax-class integer (quote "integer") integer-stx?)
(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?)
(define-integrable-syntax-class exact-nonnegative-integer
(quote "exact-nonnegative-integer")
exact-nonnegative-integer-stx?)
(define-integrable-syntax-class exact-positive-integer
(quote "exact-positive-integer")
exact-positive-integer-stx?)
(define-integrable-syntax-class -string (quote "string") string-stx?)
(define-integrable-syntax-class -bytes (quote "bytes") bytes-stx?)
(begin-for-syntax
(set-box! alt-stxclass-mapping
(list (cons #'string (syntax-local-value #'-string))
(cons #'bytes (syntax-local-value #'-bytes)))))
;; Aliases
(define-syntax id (make-rename-transformer #'identifier))
(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
(define-syntax char (make-rename-transformer #'character))
(define-syntax str (make-rename-transformer #'-string))
;; == Normal syntax classes ==
(define notfound (box 'notfound))
(define-syntax-class (static pred [name #f])
#:attributes (value)
#:description name
#:commit
(pattern x:id
#:fail-unless (syntax-transforming?)
"not within the dynamic extent of a macro transformation"
#:attr value (syntax-local-value #'x (lambda () notfound))
#:fail-when (eq? (attribute value) notfound) #f
#:fail-unless (pred (attribute value)) #f
#:do [(state-cons! 'literals #'x)]))

2
parse/private/parse-aux.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "parse-aux.rkt-6-11")]
[(version< (version) "6.90.0.29")
(begin)]
[else
(begin)])

4
parse/private/parse.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "parse.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "parse.rkt-6-12")]
[else
(my-include "parse.rkt-6-12")])
(my-include "parse.rkt-6-90-0-29")])

1243
parse/private/parse.rkt-6-90-0-29 Normal file
View File

File diff suppressed because it is too large Load Diff

4
parse/private/rep.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "rep.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "rep.rkt-6-12")]
[else
(my-include "rep.rkt-6-12")])
(my-include "rep.rkt-6-90-0-29")])

1674
parse/private/rep.rkt-6-90-0-29 Normal file
View File

File diff suppressed because it is too large Load Diff

4
parse/private/residual.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "residual.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "residual.rkt-6-12")]
[else
(my-include "residual.rkt-6-12")])
(my-include "residual.rkt-6-90-0-29")])

302
parse/private/residual.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,302 @@
#lang racket/base
(require (for-syntax racket/base)
racket/stxparam
racket/lazy-require
racket/private/promise)
;; ============================================================
;; Compile-time
(require (for-syntax racket/private/sc syntax/parse/private/residual-ct))
(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
(require racket/private/template)
(provide (for-syntax attribute-mapping attribute-mapping?))
;; ============================================================
;; Run-time
(require "runtime-progress.rkt"
"3d-stx.rkt"
auto-syntax-e
syntax/stx
stxparse-info/current-pvars)
(provide (all-from-out "runtime-progress.rkt")
this-syntax
this-role
this-context-syntax
attribute
attribute-binding
check-attr-value
stx-list-take
stx-list-drop/cx
datum->syntax/with-clause
check-literal*
error/null-eh-match
begin-for-syntax/once
name->too-few/once
name->too-few
name->too-many
normalize-context
syntax-patterns-fail)
;; == from runtime.rkt
;; this-syntax
;; Bound to syntax being matched inside of syntax class
(define-syntax-parameter this-syntax
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
(define-syntax-parameter this-role
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
;; this-context-syntax
;; Bound to (expression that extracts) context syntax (bottom frame in progress)
(define-syntax-parameter this-context-syntax
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
(define-syntax (attribute stx)
(syntax-case stx ()
[(attribute name)
(identifier? #'name)
(let ([mapping (syntax-local-value #'name (lambda () #f))])
(unless (syntax-pattern-variable? mapping)
(raise-syntax-error #f "not bound as a pattern variable" stx #'name))
(let ([var (syntax-mapping-valvar mapping)])
(let ([attr (syntax-local-value var (lambda () #f))])
(unless (attribute-mapping? attr)
(raise-syntax-error #f "not bound as an attribute" stx #'name))
(syntax-property (attribute-mapping-var attr)
'disappeared-use
(list (syntax-local-introduce #'name))))))]))
;; (attribute-binding id)
;; mostly for debugging/testing
(define-syntax (attribute-binding stx)
(syntax-case stx ()
[(attribute-bound? name)
(identifier? #'name)
(let ([value (syntax-local-value #'name (lambda () #f))])
(if (syntax-pattern-variable? value)
(let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
(if (attribute-mapping? value)
#`(quote #,(make-attr (attribute-mapping-name value)
(attribute-mapping-depth value)
(if (attribute-mapping-check value) #f #t)))
#'(quote #f)))
#'(quote #f)))]))
;; stx-list-take : stxish nat -> syntax
(define (stx-list-take stx n)
(datum->syntax #f
(let loop ([stx stx] [n n])
(if (zero? n)
null
(cons (stx-car stx)
(loop (stx-cdr stx) (sub1 n)))))))
;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
(define (stx-list-drop/cx x cx n)
(let loop ([x x] [cx cx] [n n])
(if (zero? n)
(values x
(if (syntax? x) x cx))
(loop (stx-cdr x)
(if (syntax? x) x cx)
(sub1 n)))))
;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any))
(define (check-attr-value v0 depth0 base? ctx)
(define (bad kind v)
(raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx))
(define (depthloop depth v)
(if (zero? depth)
(if base? (baseloop v) v)
(let listloop ([v v] [root? #t])
(cond [(null? v) null]
[(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))]
[new-cdr (listloop (cdr v) #f)])
(cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v]
[else (cons new-car new-cdr)]))]
[(promise? v) (listloop (force v) root?)]
[(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))]
[else (bad 'list v)]))))
(define (baseloop v)
(cond [(syntax? v) v]
[(promise? v) (baseloop (force v))]
[(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))]
[else (bad 'syntax v)]))
(depthloop depth0 v0))
;; datum->syntax/with-clause : any -> syntax
(define (datum->syntax/with-clause x)
(cond [(syntax? x) x]
[(2d-stx? x #:traverse-syntax? #f)
(datum->syntax #f x #f)]
[else
(error 'datum->syntax/with-clause
(string-append
"implicit conversion to 3D syntax\n"
" right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n"
" value: ~e")
x)]))
;; check-literal* : id phase phase (listof phase) stx -> void
(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
(unless (or (memv (and used-phase (- used-phase mod-phase))
ok-phases/ct-rel)
(identifier-binding id used-phase))
(raise-syntax-error
#f
(format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
used-phase
(and used-phase (- used-phase mod-phase)))
ctx id)))
;; error/null-eh-match : -> (escapes)
(define (error/null-eh-match)
(error 'syntax-parse "an ellipsis-head pattern matched an empty sequence"))
;; (begin-for-syntax/once expr/phase1 ...)
;; evaluates in pass 2 of module/intdefs expansion
(define-syntax (begin-for-syntax/once stx)
(syntax-case stx ()
[(bfs/o e ...)
(cond [(list? (syntax-local-context))
#`(define-values ()
(begin (begin-for-syntax/once e ...)
(values)))]
[else
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
(m))])]))
;; == parse.rkt
(define (name->too-few/once name)
(and name (format "missing required occurrence of ~a" name)))
(define (name->too-few name)
(and name (format "too few occurrences of ~a" name)))
(define (name->too-many name)
(and name (format "too many occurrences of ~a" name)))
;; == parse.rkt
;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax)
(define (normalize-context who ctx stx)
(cond [(syntax? ctx)
(list #f ctx)]
[(symbol? ctx)
(list ctx stx)]
[(eq? ctx #f)
(list #f stx)]
[(and (list? ctx)
(= (length ctx) 2)
(or (symbol? (car ctx)) (eq? #f (car ctx)))
(syntax? (cadr ctx)))
ctx]
[else (error who "bad #:context argument\n expected: ~s\n given: ~e"
'(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?))
ctx)]))
;; == parse.rkt
(lazy-require
["runtime-report.rkt"
(call-current-failure-handler ctx fs)])
;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes
(define ((syntax-patterns-fail ctx) undos fs)
(unwind-to undos null)
(call-current-failure-handler ctx fs))
;; == specialized ellipsis parser
;; returns (values 'ok attr-values) or (values 'fail failure)
(provide predicate-ellipsis-parser)
(define (predicate-ellipsis-parser x cx pr es pred? desc rl)
(let ([elems (stx->list x)])
(if (and elems (list? elems) (andmap pred? elems))
(values 'ok elems)
(let loop ([x x] [cx cx] [i 0])
(cond [(syntax? x)
(loop (syntax-e x) x i)]
[(pair? x)
(if (pred? (car x))
(loop (cdr x) cx (add1 i))
(let* ([pr (ps-add-cdr pr i)]
[pr (ps-add-car pr)]
[es (es-add-thing pr desc #t rl es)])
(values 'fail (failure pr es))))]
[else ;; not null, because stx->list failed
(let ([pr (ps-add-cdr pr i)]
#|
;; Don't extend es! That way we don't get spurious "expected ()"
;; that *should* have been cancelled out by ineffable pair failures.
|#)
(values 'fail (failure pr es)))])))))
(provide illegal-cut-error)
(define (illegal-cut-error . _)
(error 'syntax-parse "illegal use of cut"))
;; ----
(provide unwind-to
maybe-add-state-undo
current-state
current-state-writable?
state-cons!
track-literals)
(define (unwind-to undos base)
;; PRE: undos = (list* proc/hash ... base)
(unless (eq? undos base)
(let ([top-undo (car undos)])
(cond [(procedure? top-undo) (top-undo)]
[(hash? top-undo) (current-state top-undo)]))
(unwind-to (cdr undos) base)))
(define (maybe-add-state-undo init-state new-state undos)
(if (eq? init-state new-state)
undos
(cons init-state undos)))
;; To make adding undos to rewind current-state simpler, only allow updates
;; in a few contexts:
;; - literals (handled automatically)
;; - in ~do/#:do blocks (sets current-state-writable? = #t)
(define current-state (make-parameter (hasheq)))
(define current-state-writable? (make-parameter #f))
(define (state-cons! key value)
(define state (current-state))
(current-state (hash-set state key (cons value (hash-ref state key null)))))
(define (track-literals who v #:introduce? [introduce? #t])
(unless (syntax? v)
(raise-argument-error who "syntax?" v))
(let* ([literals (hash-ref (current-state) 'literals '())])
(if (null? literals)
v
(let ([literals* (if (and introduce? (syntax-transforming?) (list? literals))
(for/list ([literal (in-list literals)])
(if (identifier? literal)
(syntax-local-introduce literal)
literal))
literals)]
[old-val (syntax-property v 'disappeared-use)])
(syntax-property v 'disappeared-use
(if old-val
(cons literals* old-val)
literals*))))))

4
parse/private/runtime-reflect.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "runtime-reflect.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "runtime-reflect.rkt-6-12")]
[else
(my-include "runtime-reflect.rkt-6-12")])
(my-include "runtime-reflect.rkt-6-90-0-29")])

96
parse/private/runtime-reflect.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,96 @@
#lang racket/base
(require "residual.rkt"
(only-in syntax/parse/private/residual-ct attr-name attr-depth)
syntax/parse/private/kws)
(provide reflect-parser
(struct-out reified)
(struct-out reified-syntax-class)
(struct-out reified-splicing-syntax-class))
#|
A Reified is
(reified symbol ParserFunction nat (listof (list symbol nat)))
|#
(require (only-in syntax/parse/private/runtime-reflect
reified
reified?
reified-parser
reified-arity
reified-signature
make-reified
struct:reified
reified-syntax-class
reified-syntax-class?
make-reified-syntax-class
struct:reified-syntax-class
reified-splicing-syntax-class
reified-splicing-syntax-class?
make-reified-splicing-syntax-class
struct:reified-splicing-syntax-class))
#;(define-struct reified-base (name) #:transparent)
#;(define-struct (reified reified-base) (parser arity signature))
#;(define-struct (reified-syntax-class reified) ())
#;(define-struct (reified-splicing-syntax-class reified) ())
(define (reflect-parser obj e-arity e-attrs splicing?)
;; e-arity represents single call; min and max are same
(define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
(if splicing?
(unless (reified-splicing-syntax-class? obj)
(raise-type-error who "reified splicing-syntax-class" obj))
(unless (reified-syntax-class? obj)
(raise-type-error who "reified syntax-class" obj)))
(check-params who e-arity (reified-arity obj) obj)
(adapt-parser who
(for/list ([a (in-list e-attrs)])
(list (attr-name a) (attr-depth a)))
(reified-signature obj)
(reified-parser obj)
splicing?))
(define (check-params who e-arity r-arity obj)
(let ([e-pos (arity-minpos e-arity)]
[e-kws (arity-minkws e-arity)])
(check-arity r-arity e-pos e-kws (lambda (msg) (error who "~a" msg)))))
(define (adapt-parser who esig0 rsig0 parser splicing?)
(if (equal? esig0 rsig0)
parser
(let ([indexes
(let loop ([esig esig0] [rsig rsig0] [index 0])
(cond [(null? esig)
null]
[(and (pair? rsig) (eq? (caar esig) (caar rsig)))
(unless (= (cadar esig) (cadar rsig))
(wrong-depth who (car esig) (car rsig)))
(cons index (loop (cdr esig) (cdr rsig) (add1 index)))]
[(and (pair? rsig)
(string>? (symbol->string (caar esig))
(symbol->string (caar rsig))))
(loop esig (cdr rsig) (add1 index))]
[else
(error who "reified syntax-class is missing declared attribute `~s'"
(caar esig))]))])
(define (take-indexes result indexes)
(let loop ([result result] [indexes indexes] [i 0])
(cond [(null? indexes) null]
[(= (car indexes) i)
(cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))]
[else
(loop (cdr result) indexes (add1 i))])))
(make-keyword-procedure
(lambda (kws kwargs x cx pr es undos fh cp rl success . rest)
(keyword-apply parser kws kwargs x cx pr es undos fh cp rl
(if splicing?
(lambda (fh undos x cx pr . result)
(apply success fh undos x cx pr (take-indexes result indexes)))
(lambda (fh undos . result)
(apply success fh undos (take-indexes result indexes))))
rest))))))
(define (wrong-depth who a b)
(error who
"reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead"
(car a) (cadr a) (cadr b)))

4
parse/private/runtime-report.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "runtime-report.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "runtime-report.rkt-6-12")]
[else
(my-include "runtime-report.rkt-6-12")])
(my-include "runtime-report.rkt-6-90-0-29")])

815
parse/private/runtime-report.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,815 @@
#lang racket/base
(require racket/list
racket/format
syntax/stx
racket/struct
syntax/srcloc
syntax/parse/private/minimatch
stxparse-info/parse/private/residual
syntax/parse/private/kws)
(provide call-current-failure-handler
current-failure-handler
invert-failure
maximal-failures
invert-ps
ps->stx+index)
#|
TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
simplify to (expect:thing _ D _ #f)
thus, "expected D" rather than "expected D or D for R" (?)
|#
#|
Note: there is a cyclic dependence between residual.rkt and this module,
broken by a lazy-require of this module into residual.rkt
|#
(define (call-current-failure-handler ctx fs)
(call-with-values (lambda () ((current-failure-handler) ctx fs))
(lambda vals
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e"
(case (length vals)
((1) (car vals))
(else (cons 'values vals)))))))
(define (default-failure-handler ctx fs)
(handle-failureset ctx fs))
(define current-failure-handler
(make-parameter default-failure-handler))
;; ============================================================
;; Processing failure sets
#|
We use progress to select the maximal failures and determine the syntax
they're complaining about. After that, we no longer care about progress.
Old versions of syntax-parse (through 6.4) grouped failures into
progress-equivalence-classes and generated reports by class, but only showed
one report. New syntax-parse just mixes all maximal failures together and
deals with the fact that they might not be talking about the same terms.
|#
;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
(define (handle-failureset ctx fs)
(define inverted-fs (map invert-failure (reverse (flatten fs))))
(define maximal-classes (maximal-failures inverted-fs))
(define ess (map failure-expectstack (append* maximal-classes)))
(define report (report/sync-shared ess))
;; Hack: alternative to new (primitive) phase-crossing exn type is to store
;; extra information in exn continuation marks. Currently for debugging only.
(with-continuation-mark 'syntax-parse-error
(hasheq 'raw-failures fs
'maximal maximal-classes)
(error/report ctx report)))
;; An RFailure is (failure IPS RExpectList)
;; invert-failure : Failure -> RFailure
(define (invert-failure f)
(match f
[(failure ps es)
(failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))]))
;; A Report is (report String (Listof String) Syntax/#f Syntax/#f)
(define-struct report (message context stx within-stx) #:prefab)
;; Sometimes the point where an error occurred does not correspond to
;; a syntax object within the original term being matched. We use one
;; or two syntax objects to identify where an error occurred:
;; - the "at" term is the specific point of error, coerced to a syntax
;; object if it isn't already
;; - the "within" term is the closest enclosing original syntax object,
;; dropped (#f) if same as "at" term
;; Examples (AT is pre-coercion):
;; TERM PATTERN => AT WITHIN
;; #'(1) (a:id) #'1 -- ;; the happy case
;; #'(1) (a b) () #'(1) ;; tail of syntax list, too short
;; #'(1 . ()) (a b) #'() -- ;; tail is already syntax
;; #'#(1) #(a b) () #'#(1) ;; "tail" of syntax vector
;; #'#s(X 1) #s(X a b) () #'#s(X 1) ;; "tail" of syntax prefab
;; #'(1 2) (a) (#'2) #'(1 2) ;; tail of syntax list, too long
;; ============================================================
;; Progress
;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure))
(define (maximal-failures fs)
(maximal/progress
(for/list ([f (in-list fs)])
(cons (failure-progress f) f))))
#|
Progress ordering
-----------------
Nearly a lexicographic generalization of partial order on frames.
(( CAR < CDR ) || stx ) < POST )
- stx incomparable except with self
But ORD prefixes are sorted out (and discarded) before comparison with
rest of progress. Like post, ord comparable only w/in same group:
- (ord g n1) < (ord g n2) if n1 < n2
- (ord g1 n1) || (ord g2 n2) when g1 != g2
Progress equality
-----------------
If ps1 = ps2 then both must "blame" the same term,
ie (ps->stx+index ps1) = (ps->stx+index ps2).
|#
;; An Inverted PS (IPS) is a PS inverted for easy comparison.
;; An IPS may not contain any 'opaque frames.
;; invert-ps : PS -> IPS
;; Reverse and truncate at earliest 'opaque frame.
(define (invert-ps ps)
(reverse (ps-truncate-opaque ps)))
;; ps-truncate-opaque : PS -> PS
;; Returns maximal tail with no 'opaque frame.
(define (ps-truncate-opaque ps)
(let loop ([ps ps] [acc ps])
;; acc is the biggest tail that has not been seen to contain 'opaque
(cond [(null? ps) acc]
[(eq? (car ps) 'opaque)
(loop (cdr ps) (cdr ps))]
[else (loop (cdr ps) acc)])))
;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A))
;; Eliminates As with non-maximal progress, then groups As into
;; equivalence classes according to progress.
(define (maximal/progress items)
(cond [(null? items)
null]
[(null? (cdr items))
(list (list (cdr (car items))))]
[else
(let loop ([items items] [non-ORD-items null])
(define-values (ORD non-ORD)
(partition (lambda (item) (ord? (item-first-prf item))) items))
(cond [(pair? ORD)
(loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))]
[else
(maximal/prf1 (append non-ORD non-ORD-items))]))]))
;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A))
(define (maximal/prf1 items)
(define-values (POST rest1)
(partition (lambda (item) (eq? 'post (item-first-prf item))) items))
(cond [(pair? POST)
(maximal/progress (map item-pop-prf POST))]
[else
(define-values (STX rest2)
(partition (lambda (item) (syntax? (item-first-prf item))) rest1))
(define-values (CDR rest3)
(partition (lambda (item) (exact-integer? (item-first-prf item))) rest2))
(define-values (CAR rest4)
(partition (lambda (item) (eq? 'car (item-first-prf item))) rest3))
(define-values (NULL rest5)
(partition (lambda (item) (eq? '#f (item-first-prf item))) rest4))
(unless (null? rest5)
(error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5))
(cond [(pair? CDR)
(define leastCDR (apply min (map item-first-prf CDR)))
(append
(maximal/stx STX)
(maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))]
[(pair? CAR)
(append
(maximal/stx STX)
(maximal/progress (map item-pop-prf CAR)))]
[(pair? STX)
(maximal/stx STX)]
[(pair? NULL)
(list (map cdr NULL))]
[else null])]))
;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A))
;; PRE: each item has ORD first frame
;; Keep only maximal by first frame and pop first frame from each item.
(define (maximal-prf1/ord items)
;; groups : (NEListof (NEListof (cons A IPS)))
(define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items))
(append*
(for/list ([group (in-list groups)])
(define group* (filter-max group (lambda (item) (ord-index (item-first-prf item)))))
(map item-pop-prf group*))))
;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A))
;; PRE: Each IPS starts with a stx frame.
(define (maximal/stx items)
;; groups : (Listof (Listof (cons IPS A)))
(define groups (group-by item-first-prf items))
(append*
(for/list ([group (in-list groups)])
(maximal/progress (map item-pop-prf group)))))
;; filter-max : (Listof X) (X -> Nat) -> (Listof X)
(define (filter-max xs x->nat)
(let loop ([xs xs] [nmax -inf.0] [r-keep null])
(cond [(null? xs)
(reverse r-keep)]
[else
(define n0 (x->nat (car xs)))
(cond [(> n0 nmax)
(loop (cdr xs) n0 (list (car xs)))]
[(= n0 nmax)
(loop (cdr xs) nmax (cons (car xs) r-keep))]
[else
(loop (cdr xs) nmax r-keep)])])))
;; item-first-prf : (cons IPS A) -> prframe/#f
(define (item-first-prf item)
(define ips (car item))
(and (pair? ips) (car ips)))
;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A))
(define (item-split-ord item)
(define ips (car item))
(define a (cdr item))
(define-values (rest-ips r-ord)
(let loop ([ips ips] [r-ord null])
(cond [(and (pair? ips) (ord? (car ips)))
(loop (cdr ips) (cons (car ips) r-ord))]
[else (values ips r-ord)])))
(list* (reverse r-ord) rest-ips a))
;; item-pop-prf : (cons IPS A) -> (cons IPS A)
(define (item-pop-prf item)
(let ([ips (car item)]
[a (cdr item)])
(cons (cdr ips) a)))
;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A)
;; Assumes first frame is nat > ncdrs.
(define (item-pop-prf-ncdrs item ncdrs)
(let ([ips (car item)]
[a (cdr item)])
(cond [(= (car ips) ncdrs) (cons (cdr ips) a)]
[else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)])))
;; StxIdx = (cons Syntax Nat), the "within" term and offset (#cdrs) of "at" subterm
;; ps->stx+index : Progress -> StxIdx
;; Gets the innermost stx that should have a real srcloc, and the offset
;; (number of cdrs) within that where the progress ends.
(define (ps->stx+index ps)
(define (interp ps top?)
;; if top?: first frame is 'car, must return Syntax, don't unwrap vector/struct
(match ps
[(cons (? syntax? stx) _) stx]
[(cons 'car parent)
(let* ([x (interp parent #f)]
[d (if (syntax? x) (syntax-e x) x)])
(cond [(pair? d) (car d)]
[(vector? d)
(if top? x (vector->list d))]
[(box? d) (unbox d)]
[(prefab-struct-key d)
(if top? x (struct->list d))]
[else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
[(cons (? exact-positive-integer? n) parent)
(for/fold ([stx (interp parent #f)]) ([i (in-range n)])
(stx-cdr stx))]
[(cons (? ord?) parent)
(interp parent top?)]
[(cons 'post parent)
(interp parent top?)]))
(let loop ([ps (ps-truncate-opaque ps)])
(match ps
[(cons (? syntax? stx) _)
(cons stx 0)]
[(cons 'car _)
(cons (interp ps #t) 0)]
[(cons (? exact-positive-integer? n) parent)
(match (loop parent)
[(cons stx m) (cons stx (+ m n))])]
[(cons (? ord?) parent)
(loop parent)]
[(cons 'post parent)
(loop parent)])))
;; stx+index->at+within : StxIdx -> (values Syntax Syntax/#f)
(define (stx+index->at+within stx+index)
(define within-stx (car stx+index))
(define index (cdr stx+index))
(cond [(zero? index)
(values within-stx #f)]
[else
(define d (syntax-e within-stx))
(define stx*
(cond [(vector? d) (vector->list d)]
[(prefab-struct-key d) (struct->list d)]
[else within-stx]))
(define at-stx*
(for/fold ([x stx*]) ([_i (in-range index)]) (stx-cdr x)))
(values (datum->syntax within-stx at-stx* within-stx)
within-stx)]))
;; ============================================================
;; Expectation simplification
;; normalize-expectstack : ExpectStack StxIdx -> ExpectList
;; Converts to list, converts expect:thing term rep, and truncates
;; expectstack after opaque (ie, transparent=#f) frames.
(define (normalize-expectstack es stx+index [truncate-opaque? #t])
(reverse (invert-expectstack es stx+index truncate-opaque?)))
;; invert-expectstack : ExpectStack StxIdx -> RExpectList
;; Converts to reversed list, converts expect:thing term rep,
;; and truncates expectstack after opaque (ie, transparent=#f) frames.
(define (invert-expectstack es stx+index [truncate-opaque? #t])
(let loop ([es es] [acc null])
(match es
['#f acc]
['#t acc]
[(expect:thing ps desc tr? role rest-es)
(cond [(and truncate-opaque? (not tr?))
(loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]
[else
(loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc))])]
[(expect:message message rest-es)
(loop rest-es (cons (expect:message message stx+index) acc))]
[(expect:atom atom rest-es)
(loop rest-es (cons (expect:atom atom stx+index) acc))]
[(expect:literal literal rest-es)
(loop rest-es (cons (expect:literal literal stx+index) acc))]
[(expect:proper-pair first-desc rest-es)
(loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))])))
;; expect->stxidx : Expect -> StxIdx
(define (expect->stxidx e)
(cond [(expect:thing? e) (expect:thing-next e)]
[(expect:message? e) (expect:message-next e)]
[(expect:atom? e) (expect:atom-next e)]
[(expect:literal? e) (expect:literal-next e)]
[(expect:proper-pair? e) (expect:proper-pair-next e)]
[(expect:disj? e) (expect:disj-next e)]))
#| Simplification
A list of ExpectLists represents a tree, with shared tails meaning shared
branches of the tree. We need a "reasonable" way to simplify it to a list to
show to the user. Here we develop "reasonable" by example. (It would be nice,
of course, to also have some way of exploring the full failure trees.)
Notation: [A B X] means an ExpectList with class/description A at root and X
at leaf. If the term sequences differ, write [t1:A ...] etc.
Options:
(o) = "old behavior (through 6.4)"
(f) = "first divergence"
(s) = "sync on shared"
Case 1: [A B X], [A B Y]
This is nearly the ideal situation: report as
expected X or Y, while parsing B, while parsing A
Case 2: [A X], [A]
For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()],
but we don't want to see "expected ()".
So simplify to [A]---that is, drop X.
But there are other cases that are more problematic.
Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y]
Could report as:
(o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors)
(f) expected B or C for t2, while parsing t1 as A
(x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A
(o) is not good
(b) loses the most specific error information
(x) implies spurious contexts (eg, X while parsing C)
I like (b) best for this situation, but ...
Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y]
Could report as:
(f') expected B or C, while parsing t1 as A
(s) expected X or Y for t4, while ..., while parsing t1 as A
(f) expected A for t1
(f') is problematic, since terms are different!
(s) okay, but nothing good to put in that ... space
(f) loses a lot of information
Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y]
Only feasible choice (no other sync points):
(f,s) expected A for t1
Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y]
Could report as:
(s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A
(s) expected X or Y for t3, while ..., while parsing t1 as A
(s') again implies spurious contexts, bad
(s) okay
Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _]
Same frames show up in different orders. (Can this really happen? Probably,
with very weird uses of ~parse.)
--
This suggests the following new algorithm based on (s):
- Step 1: emit an intermediate "unified" expectstack (extended with "..." markers)
- make a list (in order) of frames shared by all expectstacks
- emit those frames with "..." markers if (sometimes) unshared stuff between
- continue processing with the tails after the last shared frame:
- find the last term shared by all expectstacks (if any)
- find the last frame for that term for each expectstack
- combine in expect:disj and emit
- Step 2:
- remove trailing and collapse adjacent "..." markers
|#
;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList)
;; -> Report
(define (report* ess handle-divergence)
(define es ;; ExpectList
(let loop ([ess ess] [acc null])
(cond [(ormap null? ess) acc]
[else
(define groups (group-by car ess))
(cond [(singleton? groups)
(define group (car groups))
(define frame (car (car group)))
(loop (map cdr group) (cons frame acc))]
[else ;; found point of divergence
(append (handle-divergence groups) acc)])])))
(define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0)))
(report/expectstack (clean-up es) stx+index))
;; clean-up : ExpectList -> ExpectList
;; Remove leading and collapse adjacent '... markers
(define (clean-up es)
(if (and (pair? es) (eq? (car es) '...))
(clean-up (cdr es))
(let loop ([es es])
(cond [(null? es) null]
[(eq? (car es) '...)
(cons '... (clean-up es))]
[else (cons (car es) (loop (cdr es)))]))))
;; --
;; report/first-divergence : (NEListof RExpectList) -> Report
;; Generate a single report, using frames from root to first divergence.
(define (report/first-divergence ess)
(report* ess handle-divergence/first))
;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList
(define (handle-divergence/first ess-groups)
(define representative-ess (map car ess-groups))
(define first-frames (map car representative-ess))
;; Do all of the first frames talk about the same term?
(cond [(all-equal? (map expect->stxidx first-frames))
(list (expect:disj first-frames #f))]
[else null]))
;; --
;; report/sync-shared : (NEListof RExpectList) -> Report
;; Generate a single report, syncing on shared frames (and later, terms).
(define (report/sync-shared ess)
(report* ess handle-divergence/sync-shared))
;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList
(define (handle-divergence/sync-shared ess-groups)
(define ess (append* ess-groups)) ;; (NEListof RExpectList)
(define shared-frames (get-shared ess values))
;; rsegs : (NEListof (Rev2n+1-Listof RExpectList))
(define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames)))
(define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames
(define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList))
(append (hd/sync-shared/final final-seg)
(hd/sync-shared/ctx ctx-rsegs)))
;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList
;; PRE: ess has no shared frames, but may have shared terms.
(define (hd/sync-shared/final ess0)
(define ess (remove-extensions ess0))
(define shared-terms (get-shared ess expect->stxidx))
(cond [(null? shared-terms) null]
[else
;; split at the last shared term
(define rsegs ;; (NEListof (3-Listof RExpectList))
(for/list ([es (in-list ess)])
(rsplit es expect->stxidx (list (last shared-terms)))))
;; only care about the got segment and pre, not post
(define last-term-ess ;; (NEListof RExpectList)
(map cadr rsegs))
(define pre-term-ess ;; (NEListof RExpectList)
(map caddr rsegs))
;; last is most specific
(append
(list (expect:disj (remove-duplicates (reverse (map last last-term-ess)))
(last shared-terms)))
(if (ormap pair? pre-term-ess) '(...) '()))]))
;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList
;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most.
;; We want leaf-most-first, so just process naturally.
(define (hd/sync-shared/ctx rsegs)
(let loop ([rsegs rsegs])
(cond [(null? rsegs) null]
[(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")]
[else (append
;; shared frame: possible for duplicate ctx frames, but unlikely
(let ([ess (car rsegs)]) (list (car (car ess))))
;; inter frames:
(let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '()))
;; recur
(loop (cddr rsegs)))])))
;; transpose : (Listof (Listof X)) -> (Listof (Listof X))
(define (transpose xss)
(cond [(ormap null? xss) null]
[else (cons (map car xss) (transpose (map cdr xss)))]))
;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y)
;; Return a list of Ys s.t. occur in order in (map of) each xs in xss.
(define (get-shared xss get-y)
(cond [(null? xss) null]
[else
(define yhs ;; (Listof (Hash Y => Nat))
(for/list ([xs (in-list xss)])
(for/hash ([x (in-list xs)] [i (in-naturals 1)])
(values (get-y x) i))))
(remove-duplicates
(let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)])
;; last is list of indexes of last accepted y; only accept next if occurs
;; after last in every sequence (see Case 7 above)
(cond [(null? xs) null]
[else
(define y (get-y (car xs)))
(define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1)))
(cond [(andmap > curr last)
(cons y (loop (cdr xs) curr))]
[else (loop (cdr xs) last)])])))]))
;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X))
;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1].
;; Thus the result has 2N+1 elements. The sublists are in original order.
(define (rsplit xs get-y ys)
(define (loop xs ys segsacc)
(cond [(null? ys) (cons xs segsacc)]
[else (pre-loop xs ys segsacc null)]))
(define (pre-loop xs ys segsacc preacc)
(cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
(got-loop (cdr xs) ys segsacc preacc (list (car xs)))]
[else
(pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))]))
(define (got-loop xs ys segsacc preacc gotacc)
(cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
(got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))]
[else
(loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))]))
(loop xs ys null))
;; singleton? : list -> boolean
(define (singleton? x) (and (pair? x) (null? (cdr x))))
;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X))
;; Remove any element that is an extension of another.
(define (remove-extensions xss)
(cond [(null? xss) null]
[else
(let loop ([xss xss])
(cond [(singleton? xss) xss]
[(ormap null? xss) (list null)]
[else
(define groups (group-by car xss))
(append*
(for/list ([group (in-list groups)])
(define group* (loop (map cdr group)))
(map (lambda (x) (cons (caar group) x)) group*)))]))]))
;; all-equal? : (Listof Any) -> Boolean
(define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs))))
;; ============================================================
;; Reporting
;; report/expectstack : ExpectList StxIdx -> Report
(define (report/expectstack es stx+index)
(define frame-expect (and (pair? es) (car es)))
(define context-frames (if (pair? es) (cdr es) null))
(define context (append* (map context-prose-for-expect context-frames)))
(cond [(not frame-expect)
(report "bad syntax" context #f #f)]
[else
(define-values (frame-stx within-stx) (stx+index->at+within stx+index))
(cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f])
(stx-pair? frame-stx))
(report "unexpected term" context (stx-car frame-stx) #f)]
[(expect:disj? frame-expect)
(report (prose-for-expects (expect:disj-expects frame-expect))
context frame-stx within-stx)]
[else
(report (prose-for-expects (list frame-expect))
context frame-stx within-stx)])]))
;; prose-for-expects : (listof Expect) -> string
(define (prose-for-expects expects)
(define msgs (filter expect:message? expects))
(define things (filter expect:thing? expects))
(define literal (filter expect:literal? expects))
(define atom/symbol
(filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects))
(define atom/nonsym
(filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects))
(define proper-pairs (filter expect:proper-pair? expects))
(join-sep
(append (map prose-for-expect (append msgs things))
(prose-for-expects/literals literal "identifiers")
(prose-for-expects/literals atom/symbol "literal symbols")
(prose-for-expects/literals atom/nonsym "literals")
(prose-for-expects/pairs proper-pairs))
";" "or"))
(define (prose-for-expects/literals expects whats)
(cond [(null? expects) null]
[(singleton? expects) (map prose-for-expect expects)]
[else
(define (prose e)
(match e
[(expect:atom (? symbol? atom) _)
(format "`~s'" atom)]
[(expect:atom atom _)
(format "~s" atom)]
[(expect:literal literal _)
(format "`~s'" (syntax-e literal))]))
(list (string-append "expected one of these " whats ": "
(join-sep (map prose expects) "," "or")))]))
(define (prose-for-expects/pairs expects)
(if (pair? expects) (list (prose-for-proper-pair-expects expects)) null))
;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
(match e
[(expect:thing _ description transparent? role _)
(if role
(format "expected ~a for ~a" description role)
(format "expected ~a" description))]
[(expect:atom (? symbol? atom) _)
(format "expected the literal symbol `~s'" atom)]
[(expect:atom atom _)
(format "expected the literal ~s" atom)]
[(expect:literal literal _)
(format "expected the identifier `~s'" (syntax-e literal))]
[(expect:message message _)
message]
[(expect:proper-pair '#f _)
"expected more terms"]))
;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
(define (prose-for-proper-pair-expects es)
(define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
(cond [(for/or ([desc descs]) (equal? desc #f))
;; FIXME: better way to indicate unknown ???
"expected more terms"]
[else
(format "expected more terms starting with ~a"
(join-sep (map prose-for-first-desc descs)
"," "or"))]))
;; prose-for-first-desc : FirstDesc -> string
(define (prose-for-first-desc desc)
(match desc
[(? string?) desc]
[(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
[(list 'literal id) (format "the identifier `~s'" id)]
[(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)]
[(list 'datum d) (format "the literal ~s" d)]))
;; context-prose-for-expect : (U '... expect:thing) -> (listof string)
(define (context-prose-for-expect e)
(match e
['...
(list "while parsing different things...")]
[(expect:thing '#f description transparent? role stx+index)
(let-values ([(stx _within-stx) (stx+index->at+within stx+index)])
(cons (~a "while parsing " description
(if role (~a " for " role) ""))
(if (error-print-source-location)
(list (~a " term: "
(~s (syntax->datum stx)
#:limit-marker "..."
#:max-width 50))
(~a " location: "
(or (source-location->string stx) "not available")))
null)))]))
;; ============================================================
;; Raise exception
(define (error/report ctx report)
(let* ([message (report-message report)]
[context (report-context report)]
[stx (cadr ctx)]
[who (or (car ctx) (infer-who stx))]
[sub-stx (report-stx report)]
[within-stx (report-within-stx report)]
[message
(format "~a: ~a~a~a~a~a"
who message
(format-if "at" (stx-if-loc sub-stx))
(format-if "within" (stx-if-loc within-stx))
(format-if "in" (stx-if-loc stx))
(if (null? context)
""
(apply string-append
"\n parsing context: "
(for/list ([c (in-list context)])
(format "\n ~a" c)))))]
[message
(if (error-print-source-location)
(let ([source-stx (or stx sub-stx within-stx)])
(string-append (source-location->prefix source-stx) message))
message)])
(raise
(exn:fail:syntax message (current-continuation-marks)
(map syntax-taint
(cond [within-stx (list within-stx)]
[sub-stx (list sub-stx)]
[stx (list stx)]
[else null]))))))
(define (format-if prefix val)
(if val
(format "\n ~a: ~a" prefix val)
""))
(define (stx-if-loc stx)
(and (syntax? stx)
(error-print-source-location)
(format "~.s" (syntax->datum stx))))
(define (infer-who stx)
(let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
(if (identifier? maybe-id) (syntax-e maybe-id) '?)))
(define (comma-list items)
(join-sep items "," "or"))
(define (improper-stx->list stx)
(syntax-case stx ()
[(a . b) (cons #'a (improper-stx->list #'b))]
[() null]
[rest (list #'rest)]))
;; ============================================================
;; Debugging
(provide failureset->sexpr
failure->sexpr
expectstack->sexpr
expect->sexpr)
(define (failureset->sexpr fs)
(let ([fs (flatten fs)])
(case (length fs)
((1) (failure->sexpr (car fs)))
(else `(union ,@(map failure->sexpr fs))))))
(define (failure->sexpr f)
(match f
[(failure progress expectstack)
`(failure ,(progress->sexpr progress)
#:expected ,(expectstack->sexpr expectstack))]))
(define (expectstack->sexpr es)
(map expect->sexpr es))
(define (expect->sexpr e) e)
(define (progress->sexpr ps)
(for/list ([pf (in-list ps)])
(match pf
[(? syntax? stx) 'stx]
[_ pf])))

4
parse/private/runtime.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "runtime.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "runtime.rkt-6-12")]
[else
(my-include "runtime.rkt-6-12")])
(my-include "runtime.rkt-6-90-0-29")])

235
parse/private/runtime.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,235 @@
#lang racket/base
(require racket/stxparam
stxparse-info/parse/private/residual ;; keep abs. path
stxparse-info/current-pvars
(for-syntax racket/base
racket/list
syntax/kerncase
syntax/strip-context
racket/private/sc
auto-syntax-e/utils
racket/syntax
syntax/parse/private/rep-data))
(provide with
fail-handler
cut-prompt
undo-stack
wrap-user-code
fail
try
let-attributes
let-attributes*
let/unpack
defattrs/unpack
check-literal
no-shadow
curried-stxclass-parser
app-argu)
#|
TODO: rename file
This file contains "runtime" (ie, phase 0) auxiliary *macros* used in
expansion of syntax-parse etc. This file must not contain any
reference that persists in a compiled program; those must go in
residual.rkt.
|#
;; == with ==
(define-syntax (with stx)
(syntax-case stx ()
[(with ([stxparam expr] ...) . body)
(with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))])
(syntax/loc stx
(let ([var expr] ...)
(syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var)))
...)
. body))))]))
;; == Control information ==
(define-syntax-parameter fail-handler
(lambda (stx)
(wrong-syntax stx "internal error: fail-handler used out of context")))
(define-syntax-parameter cut-prompt
(lambda (stx)
(wrong-syntax stx "internal error: cut-prompt used out of context")))
(define-syntax-parameter undo-stack
(lambda (stx)
(wrong-syntax stx "internal error: undo-stack used out of context")))
(define-syntax-rule (wrap-user-code e)
(with ([fail-handler #f]
[cut-prompt #t]
[undo-stack null])
e))
(define-syntax-rule (fail fs)
(fail-handler undo-stack fs))
(define-syntax (try stx)
(syntax-case stx ()
[(try e0 e ...)
(with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
(with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
(with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)])
#'(let* ([fh (lambda (undos1 fs1)
(with ([fail-handler
(lambda (undos2 fs2)
(unwind-to undos2 undos1)
(next-fh undos1 (cons fs1 fs2)))]
[undo-stack undos1])
re))]
...)
(with ([fail-handler
(lambda (undos2 fs2)
(unwind-to undos2 undo-stack)
(last-fh undo-stack fs2))]
[undo-stack undo-stack])
e0)))))]))
;; == Attributes
(define-for-syntax (parse-attr x)
(syntax-case x ()
[#s(attr name depth syntax?) #'(name depth syntax?)]))
(define-syntax (let-attributes stx)
(syntax-case stx ()
[(let-attributes ([a value] ...) . body)
(with-syntax ([((name depth syntax?) ...)
(map parse-attr (syntax->list #'(a ...)))])
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
[(stmp ...) (generate-temporaries #'(name ...))])
#'(letrec-syntaxes+values
([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth
(if 'syntax? #f (quote-syntax check-attr-value)))]
...)
([(vtmp) value] ...)
(letrec-syntaxes+values
([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...)
()
(with-pvars (name ...)
. body)))))]))
;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
;; Special case: empty attrs need not match number of value exprs.
(define-syntax let-attributes*
(syntax-rules ()
[(la* (() _) . body)
(let () . body)]
[(la* ((a ...) (val ...)) . body)
(let-attributes ([a val] ...) . body)]))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])
(let-attributes ([a tmp] ...) body)))]))
(define-syntax (defattrs/unpack stx)
(syntax-case stx ()
[(defattrs (a ...) packed)
(with-syntax ([((name depth syntax?) ...)
(map parse-attr (syntax->list #'(a ...)))])
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
[(stmp ...) (generate-temporaries #'(name ...))])
#'(begin (define-values (vtmp ...) (apply values packed))
(define-syntax stmp
(attribute-mapping (quote-syntax vtmp) 'name 'depth
(if 'syntax? #f (quote-syntax check-attr-value))))
...
(define-syntax name (make-auto-pvar 'depth (quote-syntax stmp)))
...
(define-pvars name ...))))]))
(define-syntax-rule (phase-of-enclosing-module)
(variable-reference->module-base-phase
(#%variable-reference)))
;; (check-literal id phase-level-expr ctx) -> void
(define-syntax (check-literal stx)
(syntax-case stx ()
[(check-literal id used-phase-expr ctx)
(let* ([ok-phases/ct-rel
;; id is bound at each of ok-phases/ct-rel
;; (phase relative to the compilation of the module in which the
;; 'syntax-parse' (or related) form occurs)
(filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))])
;; so we can avoid run-time call to identifier-binding if
;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase
(with-syntax ([ok-phases/ct-rel ok-phases/ct-rel])
#`(check-literal* (quote-syntax id)
used-phase-expr
(phase-of-enclosing-module)
'ok-phases/ct-rel
;; If context is not stripped, racket complains about
;; being unable to restore bindings for compiled code;
;; and all we want is the srcloc, etc.
(quote-syntax #,(strip-context #'ctx)))))]))
;; ====
(begin-for-syntax
(define (check-shadow def)
(syntax-case def ()
[(_def (x ...) . _)
(parameterize ((current-syntax-context def))
(for ([x (in-list (syntax->list #'(x ...)))])
(let ([v (syntax-local-value x (lambda _ #f))])
(when (syntax-pattern-variable? v)
(wrong-syntax
x
;; FIXME: customize "~do pattern" vs "#:do block" as appropriate
"definition in ~~do pattern must not shadow attribute binding")))))])))
(define-syntax (no-shadow stx)
(syntax-case stx ()
[(no-shadow e)
(let ([ee (local-expand #'e (syntax-local-context)
(kernel-form-identifier-list))])
(syntax-case ee (begin define-values define-syntaxes)
[(begin d ...)
#'(begin (no-shadow d) ...)]
[(define-values . _)
(begin (check-shadow ee)
ee)]
[(define-syntaxes . _)
(begin (check-shadow ee)
ee)]
[_
ee]))]))
(define-syntax (curried-stxclass-parser stx)
(syntax-case stx ()
[(_ class argu)
(with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu])
(let ([sc (get-stxclass/check-arity #'class #'class
(length (syntax->list #'(parg ...)))
(syntax->datum #'(kw ...)))])
(with-syntax ([parser (stxclass-parser sc)])
#'(lambda (x cx pr es undos fh cp rl success)
(app-argu parser x cx pr es undos fh cp rl success argu)))))]))
(define-syntax (app-argu stx)
(syntax-case stx ()
[(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...)))
#|
Use keyword-apply directly?
#'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null)
If so, create separate no-keyword clause.
|#
;; For now, let #%app handle it.
(with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)])
#'(proc kw-part ... ... extra-parg ... parg ...))]))

4
parse/private/sc.rkt
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "sc.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "sc.rkt-6-12")]
[else
(my-include "sc.rkt-6-12")])
(my-include "sc.rkt-6-90-0-29")])

34
parse/private/sc.rkt-6-90-0-29 Normal file
View File

@ -0,0 +1,34 @@
#lang racket/base
(require racket/lazy-require
syntax/parse/private/keywords
"residual.rkt")
(lazy-require-syntax
["parse.rkt"
(define-syntax-class
define-splicing-syntax-class
define-integrable-syntax-class
syntax-parse
syntax-parser
define/syntax-parse
syntax-parser/template
parser/rhs
define-eh-alternative-set)])
(provide define-syntax-class
define-splicing-syntax-class
define-integrable-syntax-class
syntax-parse
syntax-parser
define/syntax-parse
(except-out (all-from-out syntax/parse/private/keywords)
~reflect
~splicing-reflect
~eh-var)
attribute
this-syntax
syntax-parser/template
parser/rhs
define-eh-alternative-set)

4
scribblings/stxparse-info.scrbl
View File

@ -6,5 +6,7 @@
(version-case
[(version< (version) "6.11.0.900")
(my-include "stxparse-info.scrbl-6-11")]
[(version< (version) "6.90.0.29")
(my-include "stxparse-info.scrbl-6-12")]
[else
(my-include "stxparse-info.scrbl-6-12")])
(my-include "stxparse-info.scrbl-6-90-0-29")])

355
scribblings/stxparse-info.scrbl-6-90-0-29 Normal file
View File

@ -0,0 +1,355 @@
#lang scribble/manual
@require[racket/require
@for-label[stxparse-info/parse
stxparse-info/parse/experimental/template
stxparse-info/case
stxparse-info/current-pvars
(subtract-in racket/syntax stxparse-info/case)
(subtract-in racket/base stxparse-info/case)]
version-case
@for-syntax[racket/base]
"ovl.rkt"]
@; Circumvent https://github.com/racket/scribble/issues/79
@(require scribble/struct
scribble/decode)
@(define (nested-inset . vs)
(nested #:style 'inset vs))
@(version-case
[(version< (version) "6.4")
]
[else
(require scribble/example)
(define ev ((make-eval-factory '(racket))))])
@title{@racketmodname[stxparse-info]: Track @racket[syntax-parse] and @racket[syntax-case] pattern vars}
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
Source code: @url{https://github.com/jsmaniac/stxparse-info}
@defmodule[stxparse-info]
This library provides some patched versions of @orig:syntax-parse and of the
@orig:syntax-case family. These patched versions track which syntax pattern
variables are bound. This allows some libraries to change the way syntax
pattern variables work.
For example, @tt{subtemplate} automatically derives temporary
identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ] is a
pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …]
identifiers must be derived, @tt{subtemplate} needs to know which
syntax pattern variables are within scope.
@section{Tracking currently-bound pattern variables with @racket[syntax-parse]}
@defmodule[stxparse-info/parse]
The module @racketmodname[stxparse-info/parse] provides patched versions of
@orig:syntax-parse, @orig:syntax-parser and @orig:define/syntax-parse which
track which syntax pattern variables are bound.
@(ovl syntax/parse
syntax-parse
syntax-parser
define/syntax-parse)
Additionally, the following identifiers are overridden as they are part of the
duplicated implementation of @racketmodname[syntax/parse].
@(ovl #:wrapper nested-inset
syntax/parse
...+
attribute
boolean
char
character
define-conventions
define-eh-alternative-set
define-literal-set
define-splicing-syntax-class
define-syntax-class
exact-integer
exact-nonnegative-integer
exact-positive-integer
expr
expr/c
id
identifier
integer
kernel-literals
keyword
literal-set->predicate
nat
number
pattern
static
str
syntax-parse-state-cons!
syntax-parse-state-ref
syntax-parse-state-set!
syntax-parse-state-update!
this-syntax
~!
~and
~between
~bind
~commit
~datum
~delimit-cut
~describe
~do
~fail
~literal
~not
~once
~optional
~or
~parse
~peek
~peek-not
~post
~rest
~seq
~undo
~var)
@(version-case
[(version>= (version) "6.9.0.6")
(ovl #:wrapper nested-inset
syntax/parse
~alt
~or*)]
[else (begin)])
@(ovl #:wrapper nested-inset
#:require (for-template syntax/parse)
syntax/parse
pattern-expander?
pattern-expander
prop:pattern-expander
syntax-local-syntax-parse-pattern-introduce)
@section{Tracking currently-bound pattern variables with @racket[syntax-case]}
@defmodule[stxparse-info/case]
The module @racketmodname[stxparse-info/case] provides patched versions of
@orig:syntax-case, @orig:syntax-case*, @orig:with-syntax,
@orig:define/with-syntax, @orig:datum-case and @orig:with-datum which
track which syntax or datum pattern variables are bound.
@(ovl racket/base
syntax-case
syntax-case*
with-syntax)
@(ovl syntax/datum
datum-case
with-datum)
@(ovl racket/syntax
define/with-syntax)
@section{Reading and updating the list of currently-bound pattern variables}
@defmodule[stxparse-info/current-pvars]
@defproc[#:kind "procedure at phase 1"
(current-pvars) (listof identifier?)]{
This for-syntax procedure returns the list of syntax pattern variables which
are known to be bound. The most recently bound variables are at the beginning
of the list.
It is the responsibility of the reader to check that the identifiers are
bound, and that they are bound to syntax pattern variables, for example using
@racket[identifier-binding] and @racket[syntax-pattern-variable?]. This allows
libraries to also track variables bound by match-like forms, for example.}
@defproc[#:kind "procedure at phase 1"
(current-pvars+unique) (listof (pairof identifier? identifier?))]{
This for-syntax procedure works like @racket[current-pvars], but associates
each syntax pattern variable with an identifier containing a unique symbol
which is generated at each execution of the code recording the pattern
variable via @racket[with-pvars] or @racket[define-pvars].
The @racket[car] of each pair in the returned list is the syntax pattern
variable (as produced by @racket[current-pvars]). It is the responsibility of
the reader to check that the identifiers present in the @racket[car] of each
element of the returned list are bound, and that they are bound to syntax
pattern variables, for example using @racket[identifier-binding] and
@racket[syntax-pattern-variable?]. This allows libraries to also track
variables bound by match-like forms, for example.
The @racket[cdr] of each pair is the identifier of a temporary variable.
Reading that temporary variable produces a @racket[gensym]-ed symbol, which
was generated at run-time at the point where @racket[with-pvars] or
@racket[define-pvars] was used to record the corresponding pattern variable.
This can be used to associate run-time data with each syntax pattern
variable, via a weak hash table created with @racket[make-weak-hasheq]. For
example, the @tt{subtemplate} library implicitly derives
identifiers (similarly to @racket[generate-temporaries]) for uses of
@racket[yᵢ ...] from a @racket[xᵢ] pattern variable bearing the same
subscript. The generated identifiers are associated with @racket[xᵢ] via this
weak hash table mechanism, so that two uses of @racket[yᵢ ...] within the
scope of the same @racket[xᵢ] binding derive the same identifiers.
The code @racket[(with-pvars (v) body)] roughly expands to:
@racketblock[
(let-values ([(tmp) (gensym 'v)])
(letrec-syntaxes+values ([(shadow-current-pvars)
(list* (cons (quote-syntax v)
(quote-syntax tmp))
old-current-pvars)])
body))]
@bold{Caveat:} this entails that the fresh symbol stored in @racket[tmp] is
generated when @racket[with-pvars] or @racket[define-pvars] is called, not
when the syntax pattern variable is actually bound. For example:
@RACKETBLOCK[
(define-syntax (get-current-pvars+unique stx)
#`'#,(current-pvars+unique))
(require racket/private/sc)
(let ([my-valvar (quote-syntax x)])
(let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
(with-pvars (x)
(get-current-pvars+unique)) (code:comment "'([x . g123])")
(with-pvars (x)
(get-current-pvars+unique)))) (code:comment "'([x . g124])")]
Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
be called immediately after binding the syntax pattern variable, but the code
above shows that it is technically possible to do otherwise.
This caveat is not meant to dissuade the use of
@racket[current-pvars+unique], it rather serves as an explanation of the
behaviour encountered when @racket[with-pvars] or @racket[define-pvars] are
incorrectly used more than once to record the same pattern variable.}
@defform[(with-pvars (pvar ...) . body)
#:contracts ([pvar identifier?])]{
Prepends the given @racket[pvar ...] to the list of pattern variables which
are known to be bound. The @racket[pvar ...] are prepended in reverse order,
so within the body of
@racketblock[(with-pvars (v₁ v₂ v₃) . body)]
a call to the for-syntax function @racket[(current-pvars)] returns:
@racketblock[(list* (quote-syntax v₃) (quote-syntax v₂) (quote-syntax v₁)
old-current-pvars)]
This can be used to implement macros which work similarly to
@racket[syntax-parse] or @racket[syntax-case], and have them record the syntax
pattern variables which they bind.
Note that the identifiers @racket[pvar ...] must already be bound to syntax
pattern variables when @racket[with-pvars] is used, e.g.
@racketblock[
(let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))]
[v₂ (make-syntax-mapping depth (quote-syntax valvar))])
(with-pvars (v₁ v₂)
code))]
instead of:
@racketblock[
(with-pvars (v₁ v₂)
(let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))]
[v₂ (make-syntax-mapping depth (quote-syntax valvar))])
code))]}
@defform[(define-pvars pvar ...)
#:contracts ([pvar identifier?])]{
Prepends the given @racket[pvar ...] to the list of pattern variables which
are known to be bound, in the same way as @racket[with-pvars]. Whereas
@racket[with-pvars] makes the modified list visible in the @racket[_body],
@racket[define-pvars] makes the modified list visible in the statements
following @racket[define-pvars]. @racket[define-pvars] can be used multiple
times within the same @racket[let] or equivalent.
This can be used to implement macros which work similarly to
@racket[define/syntax-parse] or @racket[define/with-syntax], and have them
record the syntax pattern variables which they bind.
@(version-case
[(version< (version) "6.4")
@RACKETBLOCK[
(let ()
(code:comment "Alternate version of define/syntax-parse which")
(code:comment "contains (define-pvars x) in its expanded form.")
(define/syntax-parse x #'1)
(define/syntax-parse y #'2)
(define-syntax (get-pvars stx)
#`'#,(current-pvars))
(get-pvars))
(code:comment "=> '(y x)")]]
[else
@examples[
#:eval ev
#:hidden
(require stxparse-info/parse
stxparse-info/current-pvars
racket/syntax
(for-syntax racket/base))]
@examples[
#:eval ev
#:escape UNSYNTAX
(eval:check
(let ()
(code:comment "Alternate version of define/syntax-parse which")
(code:comment "contains (define-pvars x) in its expanded form.")
(define/syntax-parse x #'1)
(define/syntax-parse y #'2)
(define-syntax (get-pvars stx)
#`'#,(current-pvars))
(get-pvars))
'(y x))]])}
@section{Extensions to @racketmodname[syntax/parse/experimental/template]}
@defmodule[stxparse-info/parse/experimental/template]
@(orig syntax/parse/experimental/template
define-template-metafunction)
@defidform[define-template-metafunction]{
Overloaded version of @orig:define-template-metafunction from
@racketmodname[syntax/parse/experimental/template].
Note that currently, template metafunctions defined via
@racketmodname[stxparse-info/parse/experimental/template] are not compatible
with the forms from @racketmodname[syntax/parse/experimental/template], and
vice versa. There is a pending Pull Request which would make the necessary
primitives from @racketmodname[syntax/parse/experimental/template] public, so
hopefully this problem will be solved in future versions.}
@defform[(syntax-local-template-metafunction-introduce stx)]{
Like @racket[syntax-local-introduce], but for
@tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{template metafunctions}.
This change is also available in the package
@racketmodname{backport-template-pr1514}. It has been submitted as a Pull
Request to Racket, but can already be used in
@racketmodname[stxparse-info/parse/experimental/template] right now.}
@(ovl syntax/parse/experimental/template
template
quasitemplate
template/loc
quasitemplate/loc)
Additionally, the following identifiers are overridden as they are part of the
duplicated implementation of @racketmodname[syntax/parse].
@(ovl #:wrapper nested-inset
syntax/parse/experimental/template
??
?@)