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

fix nested ?? in template form

Browse Source 
closes PR 14170

Instead of checking free pvars of first template and using that to choose
which template to use, just try first and on failure try second.

Note: ?? still only covers absent pvars; non-#f non-stx value still
causes error; ellipsis rep mismatch still causes error; etc.
This commit is contained in:
Ryan Culpepper 2013-12-05 13:42:05 -05:00
parent 7017e3fb9d
commit 5593febba5
3 changed files with 101 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
pkgs/racket-pkgs/racket-test/tests/stxparse/test-template.rkt
View File

@ -311,10 +311,37 @@
(check-pred syntax? factors)
(check-equal? (syntax->datum factors)
'(() () () (2) () (2 3) ())))
(check-exn #rx"attribute is bound to non-syntax value"
(check-exn #rx"attribute contains non-syntax value"
(lambda () (template (n.half ...))))
(let ([halves (template ((?? n.half) ...))])
(check-pred syntax? halves)
(check-equal? (syntax->datum halves)
'(1 2 3)))
(void)])))
;; ----------------------------------------
;; Testing raise/handlers-based ?? (used to be based on drivers check)
(tc (syntax-parse #'()
[((~optional abs))
(template (?? (?? abs inner) outer))])
'inner)
;; test from ianj, 11/18/2013
(tc (syntax-parse #'(a)
[(a:expr (~optional b:expr))
(template (?? '(a (?? b 0)) 0))])
''(a 0))
(define/syntax-parse ((~and (~or i:id n:nat)) ...) '(a b 1 2 3 4))
;; note: i,n both 6 elts long
(tc (template ((?? i X) ...))
'(a b X X X X))
(tc (template ((?? i n) ...))
'(a b 1 2 3 4))
(tc (template ((?? i) ...)) '(a b))
(tc (template ((?? n) ...)) '(1 2 3 4))
(tc (template (?? (i ...) no)) 'no)
(tc (template (?? (n ...) no)) 'no)

93
racket/collects/syntax/parse/experimental/private/substitute.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require syntax/parse/private/minimatch
(only-in syntax/parse/private/residual check/force-syntax-list^depth)
racket/private/promise
racket/private/stx) ;; syntax/stx
(provide translate)
@ -27,7 +27,7 @@ A Guide (G) is one of:
- (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G)
- (vector 'app HG G)
- (vector 'escaped G)
- (vector 'orelse G (vector-of integer) G)
- (vector 'orelse G G)
- (vector 'metafun integer G)
- (vector 'copy-props G (listof symbol))
- (vector 'set-props G (listof (cons symbol any)))
@ -36,8 +36,8 @@ A Guide (G) is one of:
A HeadGuide (HG) is one of:
- G
- (vector 'app-opt H (vector-of integer))
- (vector 'orelse-h H (vector-of integer) H)
- (vector 'app-opt H)
- (vector 'orelse-h H H)
- (vector 'splice G)
- (vector 'unsyntax-splicing VarRef)
@ -48,14 +48,20 @@ An VarRef is one of
(define (head-guide? x)
(match x
[(vector 'app-opt g vars) #t]
[(vector 'app-opt g) #t]
[(vector 'splice g) #t]
[(vector 'orelse-h g1 vars g2) #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
(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.
@ -65,7 +71,10 @@ An VarRef is one of
(lambda (env lenv)
(unless (>= (vector-length env) env-length)
(error 'template "internal error: environment too short"))
(f env lenv))))
(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
@ -204,15 +213,14 @@ An VarRef is one of
[(vector 'escaped g1)
(loop (stx-cadr stx) g1)]
[(vector 'orelse g1 drivers1 g2)
[(vector 'orelse g1 g2)
(let ([f1 (loop (stx-cadr stx) g1)]
[f2 (loop (stx-caddr stx) g2)])
(for ([var (in-vector drivers1)])
(check-var var env-length lenv-mode))
(lambda (env lenv)
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
(f1 env lenv)
(f2 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)])
@ -281,24 +289,20 @@ An VarRef is one of
(match hg
[(vector 'app-opt hg1 drivers1)
[(vector 'app-opt hg1)
(let ([f1 (loop-h (stx-cadr stx) hg1)])
(for ([var (in-vector drivers1)])
(check-var var env-length lenv-mode))
(lambda (env lenv)
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
(f1 env lenv)
null)))]
(with-handlers ([absent-pvar? (lambda (_e) null)])
(f1 env lenv))))]
[(vector 'orelse-h hg1 drivers1 hg2)
[(vector 'orelse-h hg1 hg2)
(let ([f1 (loop-h (stx-cadr stx) hg1)]
[f2 (loop-h (stx-caddr stx) hg2)])
(for ([var (in-vector drivers1)])
(check-var var env-length lenv-mode))
(lambda (env lenv)
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
(f1 env lenv)
(f2 env lenv))))]
(with-handlers ([absent-pvar?
(lambda (_e)
(f2 env lenv))])
(f1 env lenv))))]
[(vector 'splice g1)
(let ([f1 (loop (stx-cdr stx) g1)])
@ -392,14 +396,39 @@ An VarRef is one of
(nested-append (cdr lst) nesting onto))]))
(define (check-stx ctx v)
(if (syntax? v)
v
(check/force-syntax-list^depth 0 v ctx)))
(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 ctx v)
(if (list? v)
v
(check/force-syntax-list^depth 1 v ctx)))
(define (check-list ctx v0)
(if (list? v0)
v0
(let loop ([v v0])
(cond [(null? v)
null]
[(pair? v)
(let ([new-cdr (loop (cdr v))])
;; Don't copy unless necessary
(if (eq? new-cdr (cdr v))
v
(cons (car v) 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))

35
racket/collects/syntax/parse/experimental/template.rkt
View File

@ -278,18 +278,10 @@ instead of integers and integer vectors.
(vector 'app (loop head loop-env) (loop tail loop-env))]
[(vector 'escaped g1)
(vector 'escaped (loop g1 loop-env))]
[(vector 'orelse g1 drivers1 g2)
(vector 'orelse
(loop g1 loop-env)
(for/vector ([ee (in-set drivers1)])
(get-index ee))
(loop g2 loop-env))]
[(vector 'orelse-h g1 drivers1 g2)
(vector 'orelse-h
(loop g1 loop-env)
(for/vector ([ee (in-set drivers1)])
(get-index ee))
(loop g2 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)
@ -304,11 +296,8 @@ instead of integers and integer vectors.
(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 drivers1)
(vector 'app-opt
(loop g1 loop-env)
(for/vector ([ee (in-set drivers1)])
(get-index ee)))]
[(vector 'app-opt g1)
(vector 'app-opt (loop g1 loop-env))]
[(vector 'splice g1)
(vector 'splice (loop g1 loop-env))]
[(vector 'unsyntax var)
@ -361,13 +350,13 @@ instead of integers and integer vectors.
[(vector 'unsyntax-splicing _) g]
[_ (error/no-relocate)])]
;; ----
[(vector 'orelse g1 drivers1 g2)
[(vector 'orelse g1 g2)
(error/no-relocate)]
[(vector 'orelse-h g1 drivers1 g2)
[(vector 'orelse-h g1 g2)
(error/no-relocate)]
[(vector 'metafun mf g1)
(error/no-relocate)]
[(vector 'app-opt g1 drivers1)
[(vector 'app-opt g1)
(error/no-relocate)]
[(vector 'splice g1)
(error/no-relocate)]
@ -491,7 +480,7 @@ instead of integers and integer vectors.
(let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)]
[(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)])
(values (set-union drivers1 drivers2)
(vector 'orelse guide1 (set-filter drivers1 pvar?) guide2)
(vector 'orelse guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(head DOTS . tail)
(and (not esc?)
@ -572,7 +561,7 @@ instead of integers and integer vectors.
(let-values ([(drivers splice? guide props-guide)
(parse-h #'t depth esc?)])
(values drivers #t
(vector 'app-opt guide (set-filter drivers pvar?))
(vector 'app-opt guide)
(list-guide '_ props-guide)))]
[(?? t1 t2)
(not esc?)
@ -581,7 +570,7 @@ instead of integers and integer vectors.
(values (set-union drivers1 drivers2)
(or splice?1 splice?2)
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
guide1 (set-filter drivers1 pvar?) guide2)
guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(?@ . t)
(not esc?)