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

Merge Racket ≤ 6.11 and Racket ≥ 6.12, using version-case (part 2: add old 6.11 files)

Browse Source
This commit is contained in:
Georges Dupéron 2018-03-25 23:59:28 +02:00
parent 3083001da9
commit 2d866bec01
18 changed files with 6543 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
parse/debug.rkt-6-11 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 fh fh #f
(lambda (fh . 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))))

500
parse/experimental/private/substitute.rkt-6-11 Normal file
View File

@ -0,0 +1,500 @@
#lang racket/base
(require syntax/parse/private/minimatch
racket/private/promise
racket/private/stx) ;; syntax/stx
(provide translate
syntax-local-template-metafunction-introduce)
#|
;; Doesn't seem to make much difference.
(require (rename-in racket/unsafe/ops
[unsafe-vector-ref vector-ref]
[unsafe-vector-set! vector-set!]
[unsafe-car car]
[unsafe-cdr cdr]))
|#
;; ============================================================
#|
A Guide (G) is one of:
- '_
- VarRef ;; no syntax check
- (vector 'check VarRef) ;; check value is syntax
- (cons G G)
- (vector 'vector G)
- (vector 'struct G)
- (vector 'box G)
- (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G)
- (vector 'app HG G)
- (vector 'escaped G)
- (vector 'orelse G G)
- (vector 'metafun integer G)
- (vector 'copy-props G (listof symbol))
- (vector 'set-props G (listof (cons symbol any)))
- (vector 'unsyntax VarRef)
- (vector 'relocate G)
A HeadGuide (HG) is one of:
- G
- (vector 'app-opt H)
- (vector 'orelse-h H H)
- (vector 'splice G)
- (vector 'unsyntax-splicing VarRef)
An VarRef is one of
- positive-exact-integer ;; represents depth=0 pvar ref or metafun ref
- negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis)
|#
(define (head-guide? x)
(match x
[(vector 'app-opt g) #t]
[(vector 'splice g) #t]
[(vector 'orelse-h g1 g2) #t]
[(vector 'unsyntax-splicing var) #t]
[_ #f]))
;; ============================================================
;; Used to indicate absent pvar in template; ?? catches
;; Note: not an exn, don't need continuation marks
(require (only-in rackunit require/expose))
#;(require/expose syntax/parse/experimental/private/substitute
(absent-pvar
absent-pvar?
absent-pvar-ctx
absent-pvar-v
absent-pvar-wanted-list?))
;; this struct is only used in this file, and is not exported, so I guess it's
;; ok to not steal the struct from syntax/parse/experimental/private/substitute
;; Furthermore, the require/expose above does not work reliably.
(struct absent-pvar (ctx v wanted-list?))
;; ============================================================
;; A translated-template is (vector loop-env -> syntax)
;; A loop-env is either a vector of values or a single value,
;; depending on lenv-mode of enclosing ellipsis ('dots) form.
(define (translate stx g env-length)
(let ([f (translate-g stx stx g env-length 0)])
(lambda (env lenv)
(unless (>= (vector-length env) env-length)
(error 'template "internal error: environment too short"))
(with-handlers ([absent-pvar?
(lambda (ap)
(err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))])
(f env lenv)))))
;; lenv-mode is one of
;; - 'one ;; lenv is single value; address as -1
;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env
(define (translate-g stx0 stx g env-length lenv-mode)
(define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
(define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
(define (get index env lenv) (get-var index env lenv lenv-mode))
(match g
['_ (lambda (env lenv) stx)]
[(? exact-integer? index)
(check-var index env-length lenv-mode)
(lambda (env lenv) (get index env lenv))]
[(vector 'check index)
(check-var index env-length lenv-mode)
(lambda (env lenv) (check-stx stx (get index env lenv)))]
[(cons g1 g2)
(let ([f1 (loop (stx-car stx) g1)]
[f2 (loop (stx-cdr stx) g2)])
(cond [(syntax? stx)
(lambda (env lenv)
(restx stx (cons (f1 env lenv) (f2 env lenv))))]
[(eq? g1 '_)
(let ([c1 (stx-car stx)])
(lambda (env lenv)
(cons c1 (f2 env lenv))))]
[(eq? g2 '_)
(let ([c2 (stx-cdr stx)])
(lambda (env lenv)
(cons (f1 env lenv) c2)))]
[else
(lambda (env lenv)
(cons (f1 env lenv) (f2 env lenv)))]))]
[(vector 'dots ghead henv nesting uptos gtail)
;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed.
;; An alternative would be to have a list of henvs, but that would inhibit
;; the nice simple vector reuse via vector-car/cdr!.
(let* ([lenv*-len (vector-length henv)]
[ghead-is-hg? (head-guide? ghead)]
[ftail (loop (stx-drop (add1 nesting) stx) gtail)])
(for ([var (in-vector henv)])
(check-var var env-length lenv-mode))
(unless (= nesting (length uptos))
(error 'template "internal error: wrong number of uptos"))
(let ([last-upto
(for/fold ([last 1]) ([upto (in-list uptos)])
(unless (<= upto lenv*-len)
(error 'template "internal error: upto is too big"))
(unless (>= upto last)
(error 'template "internal error: uptos decreased: ~e" uptos))
upto)])
(unless (= lenv*-len last-upto)
(error 'template "internal error: last upto was not full env")))
(cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)
(equal? ghead '-1))
;; Fast path for (pvar ... . T) template
;; - no list? or syntax? checks needed (because ghead is just raw varref,
;; no 'check' wrapper)
;; - avoid trivial map, just append
(let ([var-index (vector-ref henv 0)])
(lambda (env lenv)
(let ([lenv* (get var-index env lenv)])
(restx stx (append lenv* (ftail env lenv))))))]
[(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?))
;; Fast path for (T ... . T) template
;; - specialize lenv to avoid vector allocation/mutation
;; - body is deforested (append (map _ _) _) preserving eval order
;; - could try to eliminate 'check-list', but probably not worth the bother
(let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]
[var-index (vector-ref henv 0)])
(lambda (env lenv)
(restx stx
(let ([lenv* (check-list/depth stx (get var-index env lenv) 1)])
(let dotsloop ([lenv* lenv*])
(if (null? lenv*)
(ftail env lenv)
(cons (fhead env (car lenv*))
(dotsloop (cdr lenv*)))))))))]
[else
;; Slow/general path for (H ...^n . T)
(let ([fhead (if ghead-is-hg?
(translate-hg stx0 (stx-car stx) ghead env-length lenv*-len)
(translate-g stx0 (stx-car stx) ghead env-length lenv*-len))])
(lambda (env lenv)
#|
The template is "driven" by pattern variables bound to (listof^n syntax).
For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)),
and we need a doubly-nested loop, like
(for/list ([stxlist^1 (in-list stxlist^2)])
(for/list ([stx (in-list stxlist^1)])
___ fhead ___))
Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur
over ellipsis levels and 'dotsloop' recur over the contents of the pattern
variables' (listof^n syntax) values.
Also, we reuse lenv vectors to reduce allocation. There is one aux lenv
vector per nesting level, preallocated in aux-lenvs. For continuation-safety
we must install a continuation barrier around metafunction applications.
|#
(define (nestloop lenv* nesting uptos aux-lenvs)
(cond [(zero? nesting)
(fhead env lenv*)]
[else
(let ([iters (check-lenv/get-iterations stx lenv*)])
(let ([lenv** (car aux-lenvs)]
[aux-lenvs** (cdr aux-lenvs)]
[upto** (car uptos)]
[uptos** (cdr uptos)])
(let dotsloop ([iters iters])
(if (zero? iters)
null
(begin (vector-car/cdr! lenv** lenv* upto**)
(let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)])
(cons row (dotsloop (sub1 iters)))))))))]))
(define initial-lenv*
(vector-map (lambda (index) (get index env lenv)) henv))
(define aux-lenvs
(for/list ([depth (in-range nesting)]) (make-vector lenv*-len)))
;; Check initial-lenv* contains lists of right depths.
;; At each nesting depth, indexes [0,upto) of lenv* vary;
;; uptos is monotonic nondecreasing (every variable varies in inner
;; loop---this is always counterintuitive to me).
(let checkloop ([depth nesting] [uptos uptos] [start 0])
(when (pair? uptos)
(for ([v (in-vector initial-lenv* start (car uptos))])
(check-list/depth stx v depth))
(checkloop (sub1 depth) (cdr uptos) (car uptos))))
(define head-results
;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
;; otherwise, is (listof^nesting stx)
(nestloop initial-lenv* nesting uptos aux-lenvs))
(define tail-result (ftail env lenv))
(restx stx
(nested-append head-results
(if ghead-is-hg? nesting (sub1 nesting))
tail-result))))]))]
[(vector 'app ghead gtail)
(let ([fhead (loop-h (stx-car stx) ghead)]
[ftail (loop (stx-cdr stx) gtail)])
(lambda (env lenv)
(restx stx (append (fhead env lenv) (ftail env lenv)))))]
[(vector 'escaped g1)
(loop (stx-cadr stx) g1)]
[(vector 'orelse g1 g2)
(let ([f1 (loop (stx-cadr stx) g1)]
[f2 (loop (stx-caddr stx) g2)])
(lambda (env lenv)
(with-handlers ([absent-pvar?
(lambda (_e)
(f2 env lenv))])
(f1 env lenv))))]
[(vector 'metafun index g1)
(let ([f1 (loop (stx-cdr stx) g1)])
(check-var index env-length lenv-mode)
(lambda (env lenv)
(let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))]
[mark (make-syntax-introducer)]
[old-mark (current-template-metafunction-introducer)]
[mf (get index env lenv)])
(parameterize ((current-template-metafunction-introducer mark)
(old-template-metafunction-introducer old-mark))
(let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))])
(unless (syntax? r)
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
(restx stx (old-mark (mark r))))))))]
[(vector 'vector g1)
(let ([f1 (loop (vector->list (syntax-e stx)) g1)])
(lambda (env lenv)
(restx stx (list->vector (f1 env lenv)))))]
[(vector 'struct g1)
(let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)]
[key (prefab-struct-key (syntax-e stx))])
(lambda (env lenv)
(restx stx (apply make-prefab-struct key (f1 env lenv)))))]
[(vector 'box g1)
(let ([f1 (loop (unbox (syntax-e stx)) g1)])
(lambda (env lenv)
(restx stx (box (f1 env lenv)))))]
[(vector 'copy-props g1 keys)
(let ([f1 (loop stx g1)])
(lambda (env lenv)
(for/fold ([v (f1 env lenv)]) ([key (in-list keys)])
(let ([pvalue (syntax-property stx key)])
(if pvalue
(syntax-property v key pvalue)
v)))))]
[(vector 'set-props g1 props-alist)
(let ([f1 (loop stx g1)])
(lambda (env lenv)
(for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)])
(syntax-property v (car entry) (cdr entry)))))]
[(vector 'unsyntax var)
(let ([f1 (loop stx var)])
(lambda (env lenv)
(restx stx (f1 env lenv))))]
[(vector 'relocate g1 var)
(let ([f1 (loop stx g1)])
(lambda (env lenv)
(let ([result (f1 env lenv)]
[loc (get var env lenv)])
(if (or (syntax-source loc)
(syntax-position loc))
(datum->syntax result (syntax-e result) loc result)
result))))]))
(define (translate-hg stx0 stx hg env-length lenv-mode)
(define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
(define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
(define (get index env lenv) (get-var index env lenv lenv-mode))
(match hg
[(vector 'app-opt hg1)
(let ([f1 (loop-h (stx-cadr stx) hg1)])
(lambda (env lenv)
(with-handlers ([absent-pvar? (lambda (_e) null)])
(f1 env lenv))))]
[(vector 'orelse-h hg1 hg2)
(let ([f1 (loop-h (stx-cadr stx) hg1)]
[f2 (loop-h (stx-caddr stx) hg2)])
(lambda (env lenv)
(with-handlers ([absent-pvar?
(lambda (_e)
(f2 env lenv))])
(f1 env lenv))))]
[(vector 'splice g1)
(let ([f1 (loop (stx-cdr stx) g1)])
(lambda (env lenv)
(let* ([v (f1 env lenv)]
[v* (stx->list v)])
(unless (list? v*)
(raise-syntax-error 'template
"splicing template did not produce a syntax list"
stx))
v*)))]
[(vector 'unsyntax-splicing index)
(check-var index env-length lenv-mode)
(lambda (env lenv)
(let* ([v (get index env lenv)]
[v* (stx->list v)])
(unless (list? v*)
(raise-syntax-error 'template
"unsyntax-splicing expression did not produce a syntax list"
stx))
v*))]
[_
(let ([f (loop stx hg)])
(lambda (env lenv)
(list (f env lenv))))]))
(define (get-var index env lenv lenv-mode)
(cond [(positive? index)
(vector-ref env (sub1 index))]
[(negative? index)
(case lenv-mode
((one) lenv)
(else (vector-ref lenv (- -1 index))))]))
(define (check-var index env-length lenv-mode)
(cond [(positive? index)
(unless (< (sub1 index) env-length)
(error/bad-index index))]
[(negative? index)
(unless (< (- -1 index)
(case lenv-mode
((one) 1)
(else lenv-mode)))
(error/bad-index))]))
(define (check-lenv/get-iterations stx lenv)
(unless (list? (vector-ref lenv 0))
(error 'template "pattern variable used in ellipsis pattern is not defined"))
(let ([len0 (length (vector-ref lenv 0))])
(for ([v (in-vector lenv)])
(unless (list? v)
(error 'template "pattern variable used in ellipsis pattern is not defined"))
(unless (= len0 (length v))
(raise-syntax-error 'template
"incompatible ellipsis match counts for template"
stx)))
len0))
;; ----
(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 (stx-cadr x) (stx-car (stx-cdr x)))
(define (stx-cddr x) (stx-cdr (stx-cdr x)))
(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
(define (stx-drop n x)
(cond [(zero? n) x]
[else (stx-drop (sub1 n) (stx-cdr x))]))
(define (restx basis val)
(if (syntax? basis)
(datum->syntax basis val basis)
val))
;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
;; (Actually, in practice onto is stx, so this is an improper append.)
(define (nested-append lst nesting onto)
(cond [(zero? nesting) (append lst onto)]
[(null? lst) onto]
[else (nested-append (car lst) (sub1 nesting)
(nested-append (cdr lst) nesting onto))]))
(define (check-stx ctx v)
(let loop ([v v])
(cond [(syntax? v)
v]
[(promise? v)
(loop (force v))]
[(eq? v #f)
(raise (absent-pvar ctx v #f))]
[else (err/not-syntax ctx v)])))
(define (check-list/depth ctx v0 depth0)
(let depthloop ([v v0] [depth depth0])
(cond [(zero? depth) v]
[(and (= depth 1) (list? v)) v]
[else
(let loop ([v v])
(cond [(null? v)
null]
[(pair? v)
(let ([new-car (depthloop (car v) (sub1 depth))]
[new-cdr (loop (cdr v))])
;; Don't copy unless necessary
(if (and (eq? new-car (car v)) (eq? new-cdr (cdr v)))
v
(cons new-car new-cdr)))]
[(promise? v)
(loop (force v))]
[(eq? v #f)
(raise (absent-pvar ctx v0 #t))]
[else
(err/not-syntax ctx v0)]))])))
;; Note: slightly different from error msg in syntax/parse/private/residual:
;; here says "contains" instead of "is bound to", because might be within list
(define (err/not-syntax ctx v)
(raise-syntax-error #f
(format "attribute contains non-syntax value\n value: ~e" v)
ctx))
(define (error/bad-index index)
(error 'template "internal error: bad index: ~e" index))
(define (vector-car/cdr! dest-v src-v upto)
(let ([len (vector-length dest-v)])
(let loop ([i 0])
(when (< i upto)
(let ([p (vector-ref src-v i)])
(vector-set! dest-v i (car p))
(vector-set! src-v i (cdr p)))
(loop (add1 i))))
(let loop ([j upto])
(when (< j len)
(vector-set! dest-v j (vector-ref src-v j))
(loop (add1 j))))))
(define (vector-map f src-v)
(let* ([len (vector-length src-v)]
[dest-v (make-vector len)])
(let loop ([i 0])
(when (< i len)
(vector-set! dest-v i (f (vector-ref src-v i)))
(loop (add1 i))))
dest-v))

156
parse/experimental/provide.rkt-6-11 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
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)))))

149
parse/experimental/reflect.rkt-6-11 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 fh cp rl success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
(keyword-apply parser kws kwargs x cx pr es 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))))])

40
parse/experimental/specialize.rkt-6-11 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 fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))

95
parse/experimental/splicing.rkt-6-11 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 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 fh)
(cdr result))))
((error)
(let ([es
(es-add-message (cadr result)
(es-add-thing pr (get-description param ...) #f rl es))])
(fh (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 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 rest-x rest-cx (ps-add-cdr pr skip)
(permute (cdr result))))))))

684
parse/experimental/template.rkt-6-11 Normal file
View File

@ -0,0 +1,684 @@
#lang racket/base
(require (for-syntax racket/base
"dset.rkt"
racket/syntax
syntax/parse/private/minimatch
racket/private/stx ;; syntax/stx
racket/private/sc
racket/struct
auto-syntax-e/utils)
stxparse-info/parse/private/residual
"private/substitute.rkt")
(provide template
template/loc
quasitemplate
quasitemplate/loc
define-template-metafunction
syntax-local-template-metafunction-introduce
??
?@
(for-syntax template-metafunction?))
#|
To do:
- improve error messages
|#
#|
A Template (T) is one of:
- pvar
- const (including () and non-pvar identifiers)
- (metafunction . T)
- (H . T)
- (H ... . T), (H ... ... . T), etc
- (?? T T)
- #(T*)
- #s(prefab-struct-key T*)
* (unquote expr)
A HeadTemplate (H) is one of:
- T
- (?? H)
- (?? H H)
- (?@ . T)
* (unquote-splicing expr)
|#
(begin-for-syntax
(define (do-template ctx tstx quasi? loc-id)
(with-disappeared-uses
(parameterize ((current-syntax-context ctx)
(quasi (and quasi? (box null))))
(let*-values ([(guide deps props-guide) (parse-template tstx loc-id)]
[(vars)
(for/list ([dep (in-vector deps)])
(cond [(pvar? dep) (pvar-var dep)]
[(template-metafunction? dep)
(template-metafunction-var dep)]
[else
(error 'template
"internal error: bad environment entry: ~e"
dep)]))])
(with-syntax ([t tstx])
(syntax-arm
(cond [(equal? guide '1)
;; was (template pvar), implies props-guide = '_
(car vars)]
[(and (equal? guide '_) (equal? props-guide '_))
#'(quote-syntax t)]
[else
(with-syntax ([guide guide]
[props-guide props-guide]
[vars-vector
(if (pair? vars)
#`(vector . #,vars)
#''#())]
[((un-var . un-form) ...)
(if quasi? (reverse (unbox (quasi))) null)])
#'(let ([un-var (handle-unsyntax un-form)] ...)
(substitute (quote-syntax t)
'props-guide
'guide
vars-vector)))]))))))))
(define-syntax (template stx)
(syntax-case stx ()
[(template t)
(do-template stx #'t #f #f)]
[(template t #:properties (prop ...))
(andmap identifier? (syntax->list #'(prop ...)))
(parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
(props-to-transfer (syntax->datum #'(prop ...))))
(do-template stx #'t #f #f))]))
(define-syntax (quasitemplate stx)
(syntax-case stx ()
[(quasitemplate t)
(do-template stx #'t #t #f)]
[(quasitemplate t #:properties (prop ...))
(andmap identifier? (syntax->list #'(prop ...)))
(parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
(props-to-transfer (syntax->datum #'(prop ...))))
;; Same as above
(do-template stx #'t #t #f))]))
(define-syntaxes (template/loc quasitemplate/loc)
;; FIXME: better to replace unsyntax form, shrink template syntax constant
(let ([make-tx
(lambda (quasi?)
(lambda (stx)
(syntax-case stx ()
[(?/loc loc-expr t)
(syntax-arm
(with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
#'(let ([loc-stx (handle-loc '?/loc loc-expr)])
main-expr)))]
[(?/loc loc-expr t #:properties (prop ...))
(andmap identifier? (syntax->list #'(prop ...)))
(parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
(props-to-transfer (syntax->datum #'(prop ...))))
;; Same as above
(syntax-arm
(with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
#'(let ([loc-stx (handle-loc '?/loc loc-expr)])
main-expr))))])))])
(values (make-tx #f) (make-tx #t))))
(define (handle-loc who x)
(if (syntax? x)
x
(raise-argument-error who "syntax?" x)))
;; FIXME: what lexical context should result of expr get if not syntax?
(define-syntax handle-unsyntax
(syntax-rules (unsyntax unsyntax-splicing)
[(handle-syntax (unsyntax expr)) expr]
[(handle-syntax (unsyntax-splicing expr)) expr]))
;; substitute-table : hash[stx => translated-template]
;; Cache for closure-compiled templates. Key is just syntax of
;; template, since eq? templates must have equal? guides.
(define substitute-table (make-weak-hasheq))
;; props-syntax-table : hash[stx => stx]
(define props-syntax-table (make-weak-hasheq))
(define (substitute stx props-guide g main-env)
(let* ([stx (if (eq? props-guide '_)
stx
(or (hash-ref props-syntax-table stx #f)
(let* ([pf (translate stx props-guide 0)]
[pstx (pf '#() #f)])
(hash-set! props-syntax-table stx pstx)
pstx)))]
[f (or (hash-ref substitute-table stx #f)
(let ([f (translate stx g (vector-length main-env))])
(hash-set! substitute-table stx f)
f))])
(f main-env #f)))
;; ----
(define-syntaxes (?? ?@)
(let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))])
(values tx tx)))
;; ============================================================
#|
See private/substitute for definition of Guide (G) and HeadGuide (HG).
A env-entry is one of
- (pvar syntax-mapping attribute-mapping/#f depth-delta)
- template-metafunction
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) ...) ...)))
the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for
z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis
form at which the variable should be moved to the loop-env. That is, the
template above should be interpreted as roughly similar to
(let ([x (pvar-value-of x)]
[y (pvar-value-of y)]
[z (pvar-value-of z)])
(for ([Lz (in-list z)]) ;; depth 0
(for ([Ly (in-list y)] ;; depth 1
[Lz (in-list Lz)])
(___ x Ly Lz ___))))
A Pre-Guide is like a Guide but with env-entry and (setof env-entry)
instead of integers and integer vectors.
|#
(begin-for-syntax
(struct pvar (sm attr dd) #:prefab))
;; ============================================================
;; 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 expr)
(define-syntax id
(template-metafunction (quote-syntax internal-id)))))]))
(begin-for-syntax
(struct template-metafunction (var)))
;; ============================================================
(begin-for-syntax
;; props-to-serialize determines what properties are saved even when
;; code is compiled. (Unwritable values are dropped.)
;; props-to-transfer determines what properties are transferred from
;; template to stx constructed.
;; If a property is in props-to-transfer but not props-to-serialize,
;; compiling the module may have caused the property to disappear.
;; If a property is in props-to-serialize but not props-to-transfer,
;; it will show up only in constant subtrees.
;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape).
;; props-to-serialize : (parameterof (listof symbol))
(define props-to-serialize (make-parameter '()))
;; props-to-transfer : (parameterof (listof symbol))
(define props-to-transfer (make-parameter '(paren-shape)))
;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs))))
;; each list wrapper represents nested quasi wrapping
;; QuasiPairs = (listof (cons/c identifier syntax))
(define quasi (make-parameter #f))
;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide)
(define (parse-template t loc-id)
(let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)]
[(drivers pre-guide)
(if loc-id
(let* ([loc-sm (make-auto-pvar 0 loc-id)]
[loc-pvar (pvar loc-sm #f #f)])
(values (dset-add drivers loc-pvar)
(relocate-guide pre-guide loc-pvar)))
(values drivers pre-guide))])
(let* ([main-env (dset->env drivers (hash))]
[guide (guide-resolve-env pre-guide main-env)])
(values guide
(index-hash->vector main-env)
props-guide))))
;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
(define (dset->env drivers init-env)
(for/fold ([env init-env])
([pvar (in-list (dset->list drivers))]
[n (in-naturals (+ 1 (hash-count init-env)))])
(hash-set env pvar n)))
;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide
(define (guide-resolve-env g0 main-env)
(define (loop g loop-env)
(define (get-index x)
(let ([loop-index (hash-ref loop-env x #f)])
(if loop-index
(- loop-index)
(hash-ref main-env x))))
(match g
['_ '_]
[(cons g1 g2)
(cons (loop g1 loop-env) (loop g2 loop-env))]
[(? pvar? pvar)
(if (pvar-check? pvar)
(vector 'check (get-index pvar))
(get-index pvar))]
[(vector 'dots head new-hdrivers/level nesting '#f tail)
(let-values ([(sub-loop-env r-uptos)
(for/fold ([env (hash)] [r-uptos null])
([new-hdrivers (in-list new-hdrivers/level)])
(let ([new-env (dset->env new-hdrivers env)])
(values new-env (cons (hash-count new-env) r-uptos))))])
(let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)])
(vector 'dots
(loop head sub-loop-env)
sub-loop-vector
nesting
(reverse r-uptos)
(loop tail loop-env))))]
[(vector 'app head tail)
(vector 'app (loop head loop-env) (loop tail loop-env))]
[(vector 'escaped g1)
(vector 'escaped (loop g1 loop-env))]
[(vector 'orelse g1 g2)
(vector 'orelse (loop g1 loop-env) (loop g2 loop-env))]
[(vector 'orelse-h g1 g2)
(vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))]
[(vector 'metafun mf g1)
(vector 'metafun
(get-index mf)
(loop g1 loop-env))]
[(vector 'vector g1)
(vector 'vector (loop g1 loop-env))]
[(vector 'struct g1)
(vector 'struct (loop g1 loop-env))]
[(vector 'box g1)
(vector 'box (loop (unbox g) loop-env))]
[(vector 'copy-props g1 keys)
(vector 'copy-props (loop g1 loop-env) keys)]
[(vector 'set-props g1 props-alist)
(vector 'set-props (loop g1 loop-env) props-alist)]
[(vector 'app-opt g1)
(vector 'app-opt (loop g1 loop-env))]
[(vector 'splice g1)
(vector 'splice (loop g1 loop-env))]
[(vector 'unsyntax var)
(vector 'unsyntax (get-index var))]
[(vector 'unsyntax-splicing var)
(vector 'unsyntax-splicing (get-index var))]
[(vector 'relocate g1 var)
(vector 'relocate (loop g1 loop-env) (get-index var))]
[else (error 'template "internal error: bad pre-guide: ~e" g)]))
(loop g0 '#hash()))
;; ----------------------------------------
;; relocate-gude : stx guide -> guide
(define (relocate-guide g0 loc-pvar)
(define (relocate g)
(vector 'relocate g loc-pvar))
(define (error/no-relocate)
(wrong-syntax #f "cannot apply syntax location to template"))
(define (loop g)
(match g
['_
(relocate g)]
[(cons g1 g2)
(relocate g)]
[(? pvar? g)
g]
[(vector 'dots head new-hdrivers/level nesting '#f tail)
;; Ideally, should error. For perfect backwards compatability,
;; should relocate. But if there are zero iterations, that
;; means we'd relocate tail (which might be bad). Making
;; relocation depend on number of iterations would be
;; complicated. So just ignore.
g]
[(vector 'escaped g1)
(vector 'escaped (loop g1))]
[(vector 'vector g1)
(relocate g)]
[(vector 'struct g1)
(relocate g)]
[(vector 'box g1)
(relocate g)]
[(vector 'copy-props g1 keys)
(vector 'copy-props (loop g1) keys)]
[(vector 'unsyntax var)
g]
;; ----
[(vector 'app ghead gtail)
(match ghead
[(vector 'unsyntax-splicing _) g]
[_ (error/no-relocate)])]
;; ----
[(vector 'orelse g1 g2)
(error/no-relocate)]
[(vector 'orelse-h g1 g2)
(error/no-relocate)]
[(vector 'metafun mf g1)
(error/no-relocate)]
[(vector 'app-opt g1)
(error/no-relocate)]
[(vector 'splice g1)
(error/no-relocate)]
[(vector 'unsyntax-splicing var)
g]
[else (error 'template "internal error: bad guide for relocation: ~e" g0)]))
(loop g0))
;; ----------------------------------------
(define (wrap-props stx env-set pre-guide props-guide)
(let ([saved-prop-values
(if (syntax? stx)
(for/fold ([entries null]) ([prop (in-list (props-to-serialize))])
(let ([v (syntax-property stx prop)])
(if (and v (quotable? v))
(cons (cons prop v) entries)
entries)))
null)]
[copy-props
(if (syntax? stx)
(for/list ([prop (in-list (props-to-transfer))]
#:when (syntax-property stx prop))
prop)
null)])
(values env-set
(cond [(eq? pre-guide '_)
;; No need to copy props; already on constant
'_]
[(pair? copy-props)
(vector 'copy-props pre-guide copy-props)]
[else pre-guide])
(if (pair? saved-prop-values)
(vector 'set-props props-guide saved-prop-values)
props-guide))))
(define (quotable? v)
(or (null? v)
(string? v)
(bytes? v)
(number? v)
(boolean? v)
(char? v)
(keyword? v)
(regexp? v)
(byte-regexp? v)
(and (box? v) (quotable? (unbox v)))
(and (symbol? v) (symbol-interned? v))
(and (pair? v) (quotable? (car v)) (quotable? (cdr v)))
(and (vector? v) (andmap quotable? (vector->list v)))
(and (hash? v) (andmap quotable? (hash->list v)))
(and (prefab-struct-key v) (andmap quotable? (struct->list v)))))
(define (cons-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2)))
(define (list-guide . gs)
(foldr cons-guide '_ gs))
;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide)
(define (parse-t t depth esc?)
(syntax-case t (?? ?@ unsyntax quasitemplate)
[id
(identifier? #'id)
(cond [(or (and (not esc?)
(or (free-identifier=? #'id (quote-syntax ...))
(free-identifier=? #'id (quote-syntax ??))
(free-identifier=? #'id (quote-syntax ?@))))
(and (quasi)
(or (free-identifier=? #'id (quote-syntax unsyntax))
(free-identifier=? #'id (quote-syntax unsyntax-splicing)))))
(wrong-syntax #'id "illegal use")]
[else
(let ([pvar (lookup #'id depth)])
(cond [(pvar? pvar)
(values (dset pvar) pvar '_)]
[(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")]
[else
(wrap-props #'id (dset) '_ '_)]))])]
[(mf . template)
(and (not esc?)
(identifier? #'mf)
(template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
[(drivers guide props-guide) (parse-t #'template depth esc?)])
(values (dset-add drivers mf)
(vector 'metafun mf guide)
(cons-guide '_ props-guide)))]
[(unsyntax t1)
(quasi)
(let ([qval (quasi)])
(cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))])
(set-box! qval (cons (cons #'tmp t) (unbox qval)))
(let* ([fake-sm (make-auto-pvar 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))]
[else
(parameterize ((quasi (car qval)))
(let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
(wrap-props t
drivers
(list-guide '_ guide)
(list-guide '_ props-guide))))]))]
[(quasitemplate t1)
;; quasitemplate escapes inner unsyntaxes
(quasi)
(parameterize ((quasi (list (quasi))))
(let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
(wrap-props t
drivers
(list-guide '_ guide)
(list-guide '_ props-guide))))]
[(DOTS template)
(and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(let-values ([(drivers guide props-guide) (parse-t #'template depth #t)])
(values drivers (vector 'escaped guide)
(list-guide '_ props-guide)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)]
[(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)])
(values (dset-union drivers1 drivers2)
(vector 'orelse guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(head DOTS . tail)
(and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(let-values ([(nesting tail)
(let loop ([nesting 1] [tail #'tail])
(syntax-case tail ()
[(DOTS . tail)
(and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(loop (add1 nesting) #'tail)]
[else (values nesting tail)]))])
(let-values ([(hdrivers _hsplice? hguide hprops-guide)
(parse-h #'head (+ depth nesting) esc?)]
[(tdrivers tguide tprops-guide)
(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)))
;; FIXME: improve error message?
(let ([bad-dots
;; select the nestingth (last) ellipsis as the bad one
(stx-car (stx-drop nesting t))])
(wrong-syntax bad-dots "too many ellipses in template")))
(wrap-props t
(dset-union hdrivers tdrivers)
;; pre-guide hdrivers is (listof (setof pvar))
;; set of pvars new to each level
(let* ([hdrivers/level
(for/list ([i (in-range nesting)])
(dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
[new-hdrivers/level
(let loop ([raw hdrivers/level] [last (dset)])
(cond [(null? raw) null]
[else
(cons (dset-subtract (car raw) last)
(loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide))
(cons-guide hprops-guide (cons-guide '_ tprops-guide)))))]
[(head . tail)
(let-values ([(hdrivers hsplice? hguide hprops-guide)
(parse-h #'head depth esc?)]
[(tdrivers tguide tprops-guide)
(parse-t #'tail depth esc?)])
(wrap-props t
(dset-union hdrivers tdrivers)
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
[hsplice? (vector 'app hguide tguide)]
[else (cons hguide tguide)])
(cons-guide hprops-guide tprops-guide)))]
[vec
(vector? (syntax-e #'vec))
(let-values ([(drivers guide props-guide)
(parse-t (vector->list (syntax-e #'vec)) depth esc?)])
(wrap-props t drivers
(if (eq? guide '_) '_ (vector 'vector guide))
(if (eq? props-guide '_) '_ (vector 'vector props-guide))))]
[pstruct
(prefab-struct-key (syntax-e #'pstruct))
(let-values ([(drivers guide props-guide)
(parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
(wrap-props t drivers
(if (eq? guide '_) '_ (vector 'struct guide))
(if (eq? props-guide '_) '_ (vector 'struct props-guide))))]
[#&template
(let-values ([(drivers guide props-guide)
(parse-t #'template depth esc?)])
(wrap-props t drivers
(if (eq? guide '_) '_ (vector 'box guide))
(if (eq? props-guide '_) '_ (vector 'box props-guide))))]
[const
(wrap-props t (dset) '_ '_)]))
;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide)
(define (parse-h h depth esc?)
(syntax-case h (?? ?@ unsyntax-splicing)
[(?? t)
(not esc?)
(let-values ([(drivers splice? guide props-guide)
(parse-h #'t depth esc?)])
(values drivers #t
(vector 'app-opt guide)
(list-guide '_ props-guide)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)]
[(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)])
(values (dset-union drivers1 drivers2)
(or splice?1 splice?2)
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(?@ . t)
(not esc?)
(let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
(values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))]
[(unsyntax-splicing t1)
(quasi)
(let ([qval (quasi)])
(cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
(set-box! qval (cons (cons #'tmp h) (unbox qval)))
(let* ([fake-sm (make-auto-pvar 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))]
[else
(parameterize ((quasi (car qval)))
(let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]
[(drivers guide props-guide)
(wrap-props h
drivers
(list-guide '_ guide)
(list-guide '_ props-guide))])
(values drivers #f guide props-guide)))]))]
[t
(let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
(values drivers #f guide props-guide))]))
(define (lookup id depth)
(let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v)
(template-metafunction? v))))])
(cond [(syntax-pattern-variable? v)
(let* ([pvar-depth (syntax-mapping-depth v)]
[attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]
[attr (and (attribute-mapping? attr) attr)])
(cond [(not depth) ;; not looking for pvars, only for metafuns
#f]
[(zero? pvar-depth)
(pvar v attr #f)]
[(>= depth pvar-depth)
(pvar v attr (- depth pvar-depth))]
[else
(wrong-syntax id "missing ellipses with pattern variable in template")]))]
[(template-metafunction? v)
v]
[else
;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute
(for ([pfx (in-list (dotted-prefixes id))])
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
(when (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)))))
#f])))
(define (dotted-prefixes id)
(let* ([id-string (symbol->string (syntax-e id))]
[dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))])
(for/list ([loc (in-list dot-locations)])
(datum->syntax id (string->symbol (substring id-string 0 loc))))))
(define (index-hash->vector hash [f values])
(let ([vec (make-vector (hash-count hash))])
(for ([(value index) (in-hash hash)])
(vector-set! vec (sub1 index) (f value)))
vec))
(define ((pvar/dd<=? expected-dd) x)
(match x
[(pvar sm attr dd) (and dd (<= dd expected-dd))]
[_ #f]))
(define (pvar-var x)
(match x
[(pvar sm '#f dd) (syntax-mapping-valvar sm)]
[(pvar sm attr dd) (attribute-mapping-var attr)]))
(define (pvar-check? x)
(match x
[(pvar sm '#f dd) #f]
[(pvar sm attr dd) (not (attribute-mapping-syntax? attr))]))
(define (stx-drop n x)
(cond [(zero? n) x]
[else (stx-drop (sub1 n) (stx-cdr x))]))
)

10
parse/pre.rkt-6-11 Normal file
View File

@ -0,0 +1,10 @@
#lang racket/base
(require "private/sc.rkt"
"private/litconv.rkt"
"private/lib.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"))

75
parse/private/lib.rkt-6-11 Normal file
View File

@ -0,0 +1,75 @@
#lang racket/base
(require "sc.rkt"
syntax/parse/private/keywords
(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 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 str (quote "string") string-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?)
;; Aliases
(define-syntax id (make-rename-transformer #'identifier))
(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
(define-syntax char (make-rename-transformer #'character))
;; == 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))

21
parse/private/parse-aux.rkt-6-11 Normal file
View File

@ -0,0 +1,21 @@
#lang racket/base
(require (for-template "parse.rkt"))
(provide id:define-syntax-class
id:define-splicing-syntax-class
id:define-integrable-syntax-class
id:syntax-parse
id:syntax-parser
id:define/syntax-parse
id:syntax-parser/template
id:parser/rhs
id:define-eh-alternative-set)
(define (id:define-syntax-class) #'define-syntax-class)
(define (id:define-splicing-syntax-class) #'define-splicing-syntax-class)
(define (id:define-integrable-syntax-class) #'define-integrable-syntax-class)
(define (id:syntax-parse) #'syntax-parse)
(define (id:syntax-parser) #'syntax-parser)
(define (id:define/syntax-parse) #'define/syntax-parse)
(define (id:syntax-parser/template) #'syntax-parser/template)
(define (id:parser/rhs) #'parser/rhs)
(define (id:define-eh-alternative-set) #'define-eh-alternative-set)

1199
parse/private/parse.rkt-6-11 Normal file
View File

File diff suppressed because it is too large Load Diff

1646
parse/private/rep.rkt-6-11 Normal file
View File

File diff suppressed because it is too large Load Diff

311
parse/private/residual.rkt-6-11 Normal file
View File

@ -0,0 +1,311 @@
#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)))
(begin-for-syntax
;; == from runtime.rkt
(provide make-attribute-mapping
attribute-mapping?
attribute-mapping-var
attribute-mapping-name
attribute-mapping-depth
attribute-mapping-syntax?)
(require (only-in (for-template syntax/parse/private/residual)
make-attribute-mapping
attribute-mapping?
attribute-mapping-var
attribute-mapping-name
attribute-mapping-depth
attribute-mapping-syntax?))
#;(define-struct attribute-mapping (var name depth syntax?)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
(if (attribute-mapping-syntax? self)
#`(#%expression #,(attribute-mapping-var 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))])
#`(let ([value #,(attribute-mapping-var self)])
(if (syntax-list^depth? '#,(attribute-mapping-depth self) value)
value
(check/force-syntax-list^depth '#,(attribute-mapping-depth self)
value
(quote-syntax #,source-name))))))))
)
;; ============================================================
;; 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
stx-list-take
stx-list-drop/cx
datum->syntax/with-clause
check/force-syntax-list^depth
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)
(attribute-mapping-syntax? value)))
#'(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/force-syntax-list^depth : nat any id -> (listof^depth syntax)
;; Checks that value is (listof^depth syntax); forces promises.
;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already.
(define (check/force-syntax-list^depth depth value0 source-id)
(define (bad sub-depth sub-value)
(attribute-not-syntax-error depth value0 source-id sub-depth sub-value))
(define (loop depth value)
(cond [(promise? value)
(loop depth (force value))]
[(zero? depth)
(if (syntax? value) value (bad depth value))]
[else (loop-list depth value)]))
(define (loop-list depth value)
(cond [(promise? value)
(loop-list depth (force value))]
[(pair? value)
(let ([new-car (loop (sub1 depth) (car value))]
[new-cdr (loop-list depth (cdr value))])
;; Don't copy unless necessary
(if (and (eq? new-car (car value))
(eq? new-cdr (cdr value)))
value
(cons new-car new-cdr)))]
[(null? value)
null]
[else
(bad depth value)]))
(loop depth value0))
(define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value)
(raise-syntax-error #f
(format (string-append "bad attribute value for syntax template"
"\n attribute value: ~e"
"\n expected for attribute: ~a"
"\n sub-value: ~e"
"\n expected for sub-value: ~a")
value0
(describe-depth depth0)
sub-value
(describe-depth sub-depth))
source-id))
(define (describe-depth depth)
(cond [(zero? depth) "syntax"]
[else (format "list of depth ~s of syntax" depth)]))
;; syntax-list^depth? : nat any -> boolean
;; Returns true iff value is (listof^depth syntax).
(define (syntax-list^depth? depth value)
(if (zero? depth)
(syntax? value)
(and (list? value)
(for/and ([part (in-list value)])
(syntax-list^depth? (sub1 depth) part)))))
;; 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) -> FailureSet -> (escapes)
(define ((syntax-patterns-fail ctx) fs)
(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)))])))))

97
parse/private/runtime-reflect.rkt-6-11 Normal file
View File

@ -0,0 +1,97 @@
#lang racket/base
(require stxparse-info/parse/private/residual ;; keep abs. path
(only-in syntax/parse/private/residual-ct ;; keep abs. path
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 fh cp rl success . rest)
(keyword-apply parser kws kwargs x cx pr es fh cp rl
(if splicing?
(lambda (fh x cx pr . result)
(apply success fh x cx pr (take-indexes result indexes)))
(lambda (fh . result)
(apply success fh (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)))

784
parse/private/runtime-report.rkt-6-11 Normal file
View File

@ -0,0 +1,784 @@
#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)
;; ============================================================
;; 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)])))
;; ps->stx+index : Progress -> (cons Syntax Nat)
;; 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)
(match ps
[(cons (? syntax? stx) _) stx]
[(cons 'car parent)
(let* ([d (interp parent)]
[d (if (syntax? d) (syntax-e d) d)])
(cond [(pair? d) (car d)]
[(vector? d) (vector->list d)]
[(box? d) (unbox d)]
[(prefab-struct-key d) (struct->list d)]
[else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
[(cons (? exact-positive-integer? n) parent)
(for/fold ([stx (interp parent)]) ([i (in-range n)])
(stx-cdr stx))]
[(cons (? ord?) parent)
(interp parent)]
[(cons 'post parent)
(interp parent)]))
(let ([ps (ps-truncate-opaque ps)])
(match ps
[(cons (? syntax? stx) _)
(cons stx 0)]
[(cons 'car parent)
(cons (interp ps) 0)]
[(cons (? exact-positive-integer? n) parent)
(cons (interp parent) n)]
[(cons (? ord?) parent)
(ps->stx+index parent)]
[(cons 'post parent)
(ps->stx+index parent)])))
;; ============================================================
;; 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) (car stx+index) (cdr 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 Syntax Nat -> 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 (x cx) (stx-list-drop/cx stx stx index))
(define frame-stx (datum->syntax cx x cx))
(define within-stx (if (syntax? x) #f cx))
(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 ([stx (stx+index->stx 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)))]))
(define (stx+index->stx stx+index)
(let*-values ([(stx) (car stx+index)]
[(index) (cdr stx+index)]
[(x cx) (stx-list-drop/cx stx stx index)])
(datum->syntax cx x cx)))
;; ============================================================
;; 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])))

224
parse/private/runtime.rkt-6-11 Normal file
View File

@ -0,0 +1,224 @@
#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
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-rule (wrap-user-code e)
(with ([fail-handler #f]
[cut-prompt #t])
e))
(define-syntax-rule (fail fs)
(fail-handler 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 ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)]
[(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)])
#'(let* ([fh (lambda (fs1)
(with ([fail-handler
(lambda (fs2)
(next-fh (cons fs1 fs2)))])
re))]
...)
(with ([fail-handler last-fh])
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) (make-attribute-mapping (quote-syntax vtmp)
'name 'depth 'syntax?)] ...)
([(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
(make-attribute-mapping (quote-syntax vtmp)
'name 'depth 'syntax?))
...
(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 fh cp rl success)
(app-argu parser x cx pr es 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 ...))]))

75
parse/private/sc.rkt-6-11 Normal file
View File

@ -0,0 +1,75 @@
#lang racket/base
(require (for-syntax racket/base
racket/lazy-require)
syntax/parse/private/keywords)
;; keep and keep as abs. path -- lazy-loaded macros produce references to this
;; must be required via *absolute module path* from any disappearing module
;; (so for consistency etc, require absolutely from all modules)
(require stxparse-info/parse/private/residual
racket/syntax
racket/stxparam
syntax/stx)
(begin-for-syntax
(lazy-require
;; load macro transformers lazily via identifier
;; This module path must also be absolute (not sure why,
;; but it definitely breaks on relative module path).
[stxparse-info/parse/private/parse-aux
(id:define-syntax-class
id:define-splicing-syntax-class
id:define-integrable-syntax-class
id:syntax-parse
id:syntax-parser
id:define/syntax-parse
id:syntax-parser/template
id:parser/rhs
id:define-eh-alternative-set)]))
;; 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_ 'stxparse-info/parse/private/parse-aux)
(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)
(define-syntaxes (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)
(let ([tx (lambda (get-id)
(lambda (stx)
(syntax-case stx ()
[(_ . args)
(datum->syntax stx (cons (get-id) #'args) stx)])))])
(values
(tx id:define-syntax-class)
(tx id:define-splicing-syntax-class)
(tx id:define-integrable-syntax-class)
(tx id:syntax-parse)
(tx id:syntax-parser)
(tx id:define/syntax-parse)
(tx id:syntax-parser/template)
(tx id:parser/rhs)
(tx id:define-eh-alternative-set))))

350
scribblings/stxparse-info.scrbl-6-11 Normal file
View File

@ -0,0 +1,350 @@
#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
this-syntax
~!
~and
~between
~bind
~commit
~datum
~delimit-cut
~describe
~do
~fail
~literal
~not
~once
~optional
~or
~parse
~peek
~peek-not
~post
~rest
~seq
~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
??
?@)