syntax/parse/experimental/template: improve prop handling & syntax checks
Separate parameters for props to serialize and those to transfer. Make syntax?/list? checks on attributes explicit. Also add continuation barrier around metafunction application.
This commit is contained in:
Ryan Culpepper
parent
ddcafbc6d1
commit
8a02ff54ac
|
|
@ -1,8 +1,7 @@
|
|||
#lang racket/base
|
||||
(require syntax/parse/private/minimatch
|
||||
racket/private/stx) ;; syntax/stx
|
||||
(provide translate
|
||||
error/not-stx)
|
||||
(provide translate)
|
||||
|
||||
#|
|
||||
;; Doesn't seem to make much difference.
|
||||
|
|
@ -18,13 +17,13 @@
|
|||
#|
|
||||
A Guide (G) is one of:
|
||||
- '_
|
||||
- positive-exact-integer ;; represents depth=0 pvar ref or metafun ref
|
||||
- negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis)
|
||||
- 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 integer)) nat (listof nat) G)
|
||||
- (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)
|
||||
|
|
@ -37,6 +36,10 @@ A HeadGuide (HG) is one of:
|
|||
- (vector 'app-opt H (vector-of integer))
|
||||
- (vector 'orelse-h H (vector-of integer) H)
|
||||
- (vector 'splice G)
|
||||
|
||||
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)
|
||||
|
|
@ -67,11 +70,19 @@ A HeadGuide (HG) is one of:
|
|||
(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)])
|
||||
|
|
@ -89,6 +100,7 @@ A HeadGuide (HG) is one of:
|
|||
[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
|
||||
|
|
@ -109,32 +121,55 @@ A HeadGuide (HG) is one of:
|
|||
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))
|
||||
;; template was just (pvar ... . T)
|
||||
(let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)])
|
||||
(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)
|
||||
;; - avoid trivial map, just append
|
||||
(let ([var-index (vector-ref henv 0)])
|
||||
(lambda (env lenv)
|
||||
(let ([lenv* (get (vector-ref henv 0) 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?))
|
||||
(let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)])
|
||||
;; 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 dotsloop ([lenv* (get (vector-ref henv 0) env lenv)])
|
||||
(if (null? lenv*)
|
||||
(ftail env lenv)
|
||||
(cons (fhead env (car lenv*))
|
||||
(dotsloop (cdr lenv*))))))))]
|
||||
(let ([lenv* (check-list stx (get var-index env lenv))])
|
||||
(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 env vectors to reduce allocation. For continuation-safety
|
||||
we must install a continuation barrier around metafunction applications.
|
||||
|#
|
||||
(define (nestloop lenv* nesting uptos)
|
||||
(cond [(zero? nesting)
|
||||
(fhead env lenv*)]
|
||||
[else
|
||||
(check-lenv stx lenv*)
|
||||
(let ([iters (length (vector-ref lenv* 0))])
|
||||
(let ([iters (check-lenv/get-iterations stx lenv*)])
|
||||
(let ([lenv** (make-vector lenv*-len)]
|
||||
[upto** (car uptos)]
|
||||
[uptos** (cdr uptos)])
|
||||
|
|
@ -142,8 +177,8 @@ A HeadGuide (HG) is one of:
|
|||
(if (zero? iters)
|
||||
null
|
||||
(begin (vector-car/cdr! lenv** lenv* upto**)
|
||||
(cons (nestloop lenv** (sub1 nesting) uptos**)
|
||||
(dotsloop (sub1 iters))))))))]))
|
||||
(let ([row (nestloop lenv** (sub1 nesting) uptos**)])
|
||||
(cons row (dotsloop (sub1 iters)))))))))]))
|
||||
(let ([head-results
|
||||
;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
|
||||
;; otherwise, is (listof^nesting stx)
|
||||
|
|
@ -154,13 +189,16 @@ A HeadGuide (HG) is one of:
|
|||
(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 drivers1 g2)
|
||||
(let ([f1 (loop (stx-cadr stx) g1)]
|
||||
[f2 (loop (stx-caddr stx) g2)])
|
||||
|
|
@ -170,6 +208,7 @@ A HeadGuide (HG) is one of:
|
|||
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
|
||||
(f1 env lenv)
|
||||
(f2 env lenv))))]
|
||||
|
||||
[(vector 'metafun index g1)
|
||||
(let ([f1 (loop (stx-cdr stx) g1)])
|
||||
(check-var index env-length lenv-mode)
|
||||
|
|
@ -179,30 +218,36 @@ A HeadGuide (HG) is one of:
|
|||
[old-mark (current-template-metafunction-introducer)]
|
||||
[mf (get index env lenv)])
|
||||
(parameterize ((current-template-metafunction-introducer mark))
|
||||
(let ([r (mf (mark (old-mark v)))])
|
||||
(let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))])
|
||||
(unless (syntax? r)
|
||||
(raise-syntax-error 'template "result of 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)])
|
||||
;; FIXME: avoid copying if no value
|
||||
;; (if that situation becomes possible in future)
|
||||
(syntax-property v key (syntax-property stx key)))))]
|
||||
(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)
|
||||
|
|
@ -213,7 +258,9 @@ A HeadGuide (HG) is one of:
|
|||
(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 drivers1)
|
||||
(let ([f1 (loop-h (stx-cadr stx) hg1)])
|
||||
(for ([var (in-vector drivers1)])
|
||||
|
|
@ -222,6 +269,7 @@ A HeadGuide (HG) is one of:
|
|||
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
|
||||
(f1 env lenv)
|
||||
null)))]
|
||||
|
||||
[(vector 'orelse-h hg1 drivers1 hg2)
|
||||
(let ([f1 (loop-h (stx-cadr stx) hg1)]
|
||||
[f2 (loop-h (stx-caddr stx) hg2)])
|
||||
|
|
@ -231,6 +279,7 @@ A HeadGuide (HG) is one of:
|
|||
(if (for/and ([index (in-vector drivers1)]) (get index env lenv))
|
||||
(f1 env lenv)
|
||||
(f2 env lenv))))]
|
||||
|
||||
[(vector 'splice g1)
|
||||
(let ([f1 (loop (stx-cdr stx) g1)])
|
||||
(lambda (env lenv)
|
||||
|
|
@ -241,7 +290,8 @@ A HeadGuide (HG) is one of:
|
|||
"splicing template did not produce a syntax list"
|
||||
stx))
|
||||
v*)))]
|
||||
[else
|
||||
|
||||
[_
|
||||
(let ([f (loop stx hg)])
|
||||
(lambda (env lenv)
|
||||
(list (f env lenv))))]))
|
||||
|
|
@ -265,16 +315,18 @@ A HeadGuide (HG) is one of:
|
|||
(else lenv-mode)))
|
||||
(error/bad-index))]))
|
||||
|
||||
(define (check-lenv stx lenv)
|
||||
(for ([v (in-vector lenv)])
|
||||
(unless v
|
||||
(error 'template "pattern variable used in ellipsis pattern is not defined")))
|
||||
(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)))))
|
||||
stx)))
|
||||
len0))
|
||||
|
||||
;; ----
|
||||
|
||||
|
|
@ -313,8 +365,16 @@ A HeadGuide (HG) is one of:
|
|||
v
|
||||
(error/not-stx ctx v)))
|
||||
|
||||
(define (check-list ctx v)
|
||||
(if (list? v)
|
||||
v
|
||||
(error/not-list ctx v)))
|
||||
|
||||
(define (error/not-stx ctx v)
|
||||
(raise-syntax-error 'template "pattern variable is not syntax-valued" ctx))
|
||||
(raise-syntax-error 'template "pattern variable value is not syntax" ctx))
|
||||
|
||||
(define (error/not-list ctx v)
|
||||
(raise-syntax-error 'template "pattern variable value is not syntax list" ctx))
|
||||
|
||||
(define (error/bad-index index)
|
||||
(error 'template "internal error: bad index: ~e" index))
|
||||
|
|
|
|||
|
|
@ -35,43 +35,26 @@ A HeadTemplate (H) is one of:
|
|||
- (?@ . T)
|
||||
|#
|
||||
|
||||
(define-syntax (template stx)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(template t)
|
||||
#'(template t #:properties (paren-shape))]
|
||||
[(template t #:properties (prop ...))
|
||||
(andmap identifier? (syntax->list #'(prop ...)))
|
||||
(let-values ([(guide deps props-guide)
|
||||
(parameterize ((retain-props (syntax->datum #'(prop ...))))
|
||||
(parse-template #'t))])
|
||||
(let ([vars
|
||||
(for/list ([dep (in-vector deps)])
|
||||
(cond [(pvar? dep)
|
||||
(let* ([sm (pvar-sm dep)]
|
||||
[valvar (syntax-mapping-valvar sm)]
|
||||
[attr (syntax-local-value valvar (lambda () #f))])
|
||||
(cond [(attribute-mapping? attr)
|
||||
(attribute-mapping-var attr)]
|
||||
[else valvar]))]
|
||||
[(template-metafunction? dep)
|
||||
(template-metafunction-var dep)]
|
||||
[else
|
||||
(error 'template
|
||||
"internal error: bad environment entry: ~e"
|
||||
dep)]))])
|
||||
(begin-for-syntax
|
||||
(define (do-template ctx tstx)
|
||||
(parameterize ((current-syntax-context ctx))
|
||||
(let-values ([(guide deps props-guide) (parse-template tstx)])
|
||||
(let ([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)
|
||||
(with-syntax ([var (car vars)])
|
||||
#'(if (syntax? var)
|
||||
var
|
||||
(error/not-stx (quote-syntax t) var)))]
|
||||
[(equal? guide '_) ;; constant
|
||||
(cond [(equal? props-guide '_) ;; no props
|
||||
#`(quote-syntax t)]
|
||||
[else
|
||||
(with-syntax ([props-guide props-guide])
|
||||
#`(substitute (quote-syntax t) 'props-guide '_ '#()))])]
|
||||
(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]
|
||||
|
|
@ -82,7 +65,17 @@ A HeadTemplate (H) is one of:
|
|||
#'(substitute (quote-syntax t)
|
||||
'props-guide
|
||||
'guide
|
||||
vars-vector))]))))])))
|
||||
vars-vector))]))))))))
|
||||
|
||||
(define-syntax (template stx)
|
||||
(syntax-case stx ()
|
||||
[(template t)
|
||||
(do-template stx #'t)]
|
||||
[(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))]))
|
||||
|
||||
;; substitute-table : hash[stx => translated-template]
|
||||
;; Cache for closure-compiled templates. Key is just syntax of
|
||||
|
|
@ -118,7 +111,7 @@ A HeadTemplate (H) is one of:
|
|||
See private/substitute for definition of Guide (G) and HeadGuide (HG).
|
||||
|
||||
A env-entry is one of
|
||||
- (pvar syntax-mapping depth-delta)
|
||||
- (pvar syntax-mapping attribute-mapping/#f depth-delta)
|
||||
- template-metafunction
|
||||
|
||||
The depth-delta associated with a depth>0 pattern variable is the difference
|
||||
|
|
@ -148,7 +141,7 @@ instead of integers and integer vectors.
|
|||
|#
|
||||
|
||||
(begin-for-syntax
|
||||
(struct pvar (sm dd) #:prefab))
|
||||
(struct pvar (sm attr dd) #:prefab))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
|
|
@ -170,6 +163,22 @@ instead of integers and integer vectors.
|
|||
|
||||
(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)))
|
||||
|
||||
;; parse-template : stx -> (values guide (vectorof env-entry) guide)
|
||||
(define (parse-template t)
|
||||
(let-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)])
|
||||
|
|
@ -196,8 +205,12 @@ instead of integers and integer vectors.
|
|||
(hash-ref main-env x))))
|
||||
(match g
|
||||
['_ '_]
|
||||
[(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))]
|
||||
[(? pvar? pvar) (get-index pvar)]
|
||||
[(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])
|
||||
|
|
@ -253,25 +266,31 @@ instead of integers and integer vectors.
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define retain-props (make-parameter '(paren-shape)))
|
||||
|
||||
(define (wrap-props stx env-set pre-guide props-guide)
|
||||
(let ([prop-entries
|
||||
(let ([saved-prop-values
|
||||
(if (syntax? stx)
|
||||
(for/fold ([entries null]) ([prop (in-list (retain-props))])
|
||||
(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)])
|
||||
(if (pair? prop-entries)
|
||||
(values env-set
|
||||
(cond [(eq? pre-guide '_)
|
||||
;; No need to copy props; already on constant.
|
||||
'_]
|
||||
[else (vector 'copy-props pre-guide (map car prop-entries))])
|
||||
(vector 'set-props props-guide prop-entries))
|
||||
(values env-set pre-guide props-guide))))
|
||||
(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)
|
||||
|
|
@ -294,7 +313,7 @@ instead of integers and integer vectors.
|
|||
(define (list-guide . gs)
|
||||
(foldr cons-guide '_ gs))
|
||||
|
||||
;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide)
|
||||
;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide props-guide)
|
||||
(define (parse-t t depth esc?)
|
||||
(syntax-case t (?? ?@)
|
||||
[id
|
||||
|
|
@ -405,7 +424,7 @@ instead of integers and integer vectors.
|
|||
[const
|
||||
(wrap-props t (set) '_ '_)]))
|
||||
|
||||
;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide)
|
||||
;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide props-guide)
|
||||
(define (parse-h h depth esc?)
|
||||
(syntax-case h (?? ?@)
|
||||
[(?? t)
|
||||
|
|
@ -439,13 +458,15 @@ instead of integers and integer vectors.
|
|||
(define (lookup id depth)
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(let ([pvar-depth (syntax-mapping-depth 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 #f)]
|
||||
(pvar v attr #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(pvar v (- depth pvar-depth))]
|
||||
(pvar v attr (- depth pvar-depth))]
|
||||
[else
|
||||
(wrong-syntax id
|
||||
(string-append "pattern variable used at wrong ellipsis depth "
|
||||
|
|
@ -454,10 +475,13 @@ instead of integers and integer vectors.
|
|||
[(template-metafunction? v)
|
||||
v]
|
||||
[else
|
||||
;; id is a literal; check that for all x s.t. id = x.y, x is not a pattern variable
|
||||
;; 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))])
|
||||
(when (syntax-pattern-variable? (syntax-local-value pfx (lambda () #f)))
|
||||
(wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))
|
||||
(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)
|
||||
|
|
@ -474,9 +498,19 @@ instead of integers and integer vectors.
|
|||
|
||||
(define ((pvar/dd<=? expected-dd) x)
|
||||
(match x
|
||||
[(pvar sm dd) (and dd (<= dd expected-dd))]
|
||||
[(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))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user