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

syntax/parse template: remove syntax-property handling

Browse Source 
Since template was written, Racket has added a notion of preserved
syntax properties.
This commit is contained in:
Ryan Culpepper 2017-08-07 19:17:47 -04:00
parent ff1ec66c7f
commit eb65a859cd
4 changed files with 74 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
pkgs/racket-test/tests/stxparse/test-template-save-props.rkt
View File

@ -1,65 +0,0 @@
#lang racket
(require syntax/parse
syntax/parse/experimental/template)
(begin-for-syntax
(struct prefab-st (a b c) #:prefab)
(struct st (a b c))
(define (syntax-properties s . p*)
(if (null? p*)
s
(apply syntax-properties
(syntax-property s (car p*) (cadr p*))
(cddr p*)))))
(define-syntax (define-with-prop stx)
(syntax-case stx ()
[(_ name)
#`(define (name)
(syntax-parse #'1
[v
(template #,(syntax-properties #'(v)
'null '()
'string "str"
'bytes #"by"
'number 123.4
'boolean #t
'char #\c
'keyword '#:kw
'regexp #rx".*"
'pregexp #px".*"
'byte-regexp #rx#".*"
'byte-pregexp #px#".*"
'box #&bx
'symbol 'sym
'pair '(a . b)
'vector #(1 2 3)
'hash #hash([a . 1] [b . 2])
'hasheq #hasheq([a . 1] [b . 2])
'hasheqv #hasheqv([a . 1] [b . 2])
'prefab-st (prefab-st 'x 'y 'z)
'st (st 'x 'y 'z))
#:properties (null
string
bytes
number
boolean
char
keyword
regexp
pregexp
byte-regexp
byte-pregexp
box
symbol
pair
vector
hash
hasheq
hasheqv
prefab-st
st))]))]))
(define-with-prop get-syntax-with-saved-props)
(provide get-syntax-with-saved-props)

24
pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt
View File

@ -1,24 +0,0 @@
#lang racket
(require "test-template-save-props.rkt"
rackunit)
(define s (get-syntax-with-saved-props))
(check-equal? (syntax-property s 'null) '())
(check-equal? (syntax-property s 'string) "str")
(check-equal? (syntax-property s 'bytes) #"by")
(check-equal? (syntax-property s 'number) 123.4)
(check-equal? (syntax-property s 'boolean) #t)
(check-equal? (syntax-property s 'char) #\c)
(check-equal? (syntax-property s 'keyword) '#:kw)
(check-equal? (syntax-property s 'regexp) #rx".*")
(check-equal? (syntax-property s 'pregexp) #px".*")
(check-equal? (syntax-property s 'byte-regexp) #rx#".*")
(check-equal? (syntax-property s 'byte-pregexp) #px#".*")
(check-equal? (syntax-property s 'box) #&bx)
(check-equal? (syntax-property s 'symbol) 'sym)
(check-equal? (syntax-property s 'pair) '(a . b))
(check-equal? (syntax-property s 'vector) #(1 2 3))
(check-equal? (syntax-property s 'hash) #hash([a . 1] [b . 2]))
(check-equal? (syntax-property s 'hasheq) #hasheq([a . 1] [b . 2]))
(check-equal? (syntax-property s 'hasheqv) #hasheqv([a . 1] [b . 2]))
(check-equal? (syntax-property s 'prefab-st) #s(prefab-st x y z))
(check-equal? (syntax-property s 'st) #f) ; st is not serializable, should be #f

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

@ -29,8 +29,6 @@ A Guide (G) is one of:
- (vector 'escaped G) - (vector 'escaped G)
- (vector 'orelse G G) - (vector 'orelse G G)
- (vector 'metafun integer G) - (vector 'metafun integer G)
- (vector 'copy-props G (listof symbol))
- (vector 'set-props G (listof (cons symbol any)))
- (vector 'unsyntax VarRef) - (vector 'unsyntax VarRef)
- (vector 'relocate G) - (vector 'relocate G)
@ -269,21 +267,6 @@ An VarRef is one of
(lambda (env lenv) (lambda (env lenv)
(restx stx (box (f1 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) [(vector 'unsyntax var)
(let ([f1 (loop stx var)]) (let ([f1 (loop stx var)])
(lambda (env lenv) (lambda (env lenv)
@ -401,7 +384,7 @@ An VarRef is one of
(define (restx basis val) (define (restx basis val)
(if (syntax? basis) (if (syntax? basis)
(datum->syntax basis val basis) (datum->syntax basis val basis basis)
val)) val))
;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A) ;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)

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

@ -41,11 +41,13 @@ A HeadTemplate (H) is one of:
|# |#
(begin-for-syntax (begin-for-syntax
(define-logger template)
(define (do-template ctx tstx quasi? loc-id) (define (do-template ctx tstx quasi? loc-id)
(with-disappeared-uses (with-disappeared-uses
(parameterize ((current-syntax-context ctx) (parameterize ((current-syntax-context ctx)
(quasi (and quasi? (box null)))) (quasi (and quasi? (box null))))
(let*-values ([(guide deps props-guide) (parse-template tstx loc-id)] (let*-values ([(guide deps) (parse-template tstx loc-id)]
[(vars) [(vars)
(for/list ([dep (in-vector deps)]) (for/list ([dep (in-vector deps)])
(cond [(pvar? dep) (pvar-var dep)] (cond [(pvar? dep) (pvar-var dep)]
@ -58,13 +60,12 @@ A HeadTemplate (H) is one of:
(with-syntax ([t tstx]) (with-syntax ([t tstx])
(syntax-arm (syntax-arm
(cond [(equal? guide '1) (cond [(equal? guide '1)
;; was (template pvar), implies props-guide = '_ ;; was (template pvar)
(car vars)] (car vars)]
[(and (equal? guide '_) (equal? props-guide '_)) [(equal? guide '_)
#'(quote-syntax t)] #'(quote-syntax t)]
[else [else
(with-syntax ([guide guide] (with-syntax ([guide guide]
[props-guide props-guide]
[vars-vector [vars-vector
(if (pair? vars) (if (pair? vars)
#`(vector . #,vars) #`(vector . #,vars)
@ -73,7 +74,6 @@ A HeadTemplate (H) is one of:
(if quasi? (reverse (unbox (quasi))) null)]) (if quasi? (reverse (unbox (quasi))) null)])
#'(let ([un-var (handle-unsyntax un-form)] ...) #'(let ([un-var (handle-unsyntax un-form)] ...)
(substitute (quote-syntax t) (substitute (quote-syntax t)
'props-guide
'guide 'guide
vars-vector)))])))))))) vars-vector)))]))))))))
@ -81,10 +81,9 @@ A HeadTemplate (H) is one of:
(syntax-case stx () (syntax-case stx ()
[(template t) [(template t)
(do-template stx #'t #f #f)] (do-template stx #'t #f #f)]
[(template t #:properties (prop ...)) [(template t #:properties _)
(andmap identifier? (syntax->list #'(prop ...))) (begin
(parameterize ((props-to-serialize (syntax->datum #'(prop ...))) (log-template-error "template #:properties argument no longer supported: ~e" stx)
(props-to-transfer (syntax->datum #'(prop ...))))
(do-template stx #'t #f #f))])) (do-template stx #'t #f #f))]))
(define-syntax (quasitemplate stx) (define-syntax (quasitemplate stx)
@ -121,21 +120,11 @@ A HeadTemplate (H) is one of:
;; template, since eq? templates must have equal? guides. ;; template, since eq? templates must have equal? guides.
(define substitute-table (make-weak-hasheq)) (define substitute-table (make-weak-hasheq))
;; props-syntax-table : hash[stx => stx] (define (substitute stx g main-env)
(define props-syntax-table (make-weak-hasheq)) (let ([f (or (hash-ref substitute-table stx #f)
(let ([f (translate stx g (vector-length main-env))])
(define (substitute stx props-guide g main-env) (hash-set! substitute-table stx f)
(let* ([stx (if (eq? props-guide '_) f))])
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))) (f main-env #f)))
;; ---- ;; ----
@ -202,30 +191,14 @@ instead of integers and integer vectors.
(begin-for-syntax (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)))) ;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs))))
;; each list wrapper represents nested quasi wrapping ;; each list wrapper represents nested quasi wrapping
;; QuasiPairs = (listof (cons/c identifier syntax)) ;; QuasiPairs = (listof (cons/c identifier syntax))
(define quasi (make-parameter #f)) (define quasi (make-parameter #f))
;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide) ;; parse-template : stx id/#f -> (values guide (vectorof env-entry))
(define (parse-template t loc-id) (define (parse-template t loc-id)
(let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)] (let*-values ([(drivers pre-guide) (parse-t t 0 #f)]
[(drivers pre-guide) [(drivers pre-guide)
(if loc-id (if loc-id
(let* ([loc-sm (make-syntax-mapping 0 loc-id)] (let* ([loc-sm (make-syntax-mapping 0 loc-id)]
@ -236,8 +209,7 @@ instead of integers and integer vectors.
(let* ([main-env (dset->env drivers (hash))] (let* ([main-env (dset->env drivers (hash))]
[guide (guide-resolve-env pre-guide main-env)]) [guide (guide-resolve-env pre-guide main-env)])
(values guide (values guide
(index-hash->vector main-env) (index-hash->vector main-env)))))
props-guide))))
;; dset->env : (dsetof env-entry) -> hash[env-entry => nat] ;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
(define (dset->env drivers init-env) (define (dset->env drivers init-env)
@ -293,10 +265,6 @@ instead of integers and integer vectors.
(vector 'struct (loop g1 loop-env))] (vector 'struct (loop g1 loop-env))]
[(vector 'box g1) [(vector 'box g1)
(vector 'box (loop (unbox g) loop-env))] (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 g1)
(vector 'app-opt (loop g1 loop-env))] (vector 'app-opt (loop g1 loop-env))]
[(vector 'splice g1) [(vector 'splice g1)
@ -341,8 +309,6 @@ instead of integers and integer vectors.
(relocate g)] (relocate g)]
[(vector 'box g1) [(vector 'box g1)
(relocate g)] (relocate g)]
[(vector 'copy-props g1 keys)
(vector 'copy-props (loop g1) keys)]
[(vector 'unsyntax var) [(vector 'unsyntax var)
g] g]
;; ---- ;; ----
@ -368,56 +334,13 @@ instead of integers and integer vectors.
;; ---------------------------------------- ;; ----------------------------------------
(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? (cdr (vector->list (struct->vector v)))))))
(define (cons-guide g1 g2) (define (cons-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2)))
(define (list-guide . gs) (define (list-guide . gs)
(foldr cons-guide '_ gs)) (foldr cons-guide '_ gs))
;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide) ;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide)
(define (parse-t t depth esc?) (define (parse-t t depth esc?)
(syntax-case t (?? ?@ unsyntax quasitemplate) (syntax-case t (?? ?@ unsyntax quasitemplate)
[id [id
@ -433,20 +356,18 @@ instead of integers and integer vectors.
[else [else
(let ([pvar (lookup #'id depth)]) (let ([pvar (lookup #'id depth)])
(cond [(pvar? pvar) (cond [(pvar? pvar)
(values (dset pvar) pvar '_)] (values (dset pvar) pvar)]
[(template-metafunction? pvar) [(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")] (wrong-syntax t "illegal use of syntax metafunction")]
[else [else
(wrap-props #'id (dset) '_ '_)]))])] (values (dset) '_)]))])]
[(mf . template) [(mf . template)
(and (not esc?) (and (not esc?)
(identifier? #'mf) (identifier? #'mf)
(template-metafunction? (lookup #'mf #f))) (template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)] (let-values ([(mf) (lookup #'mf #f)]
[(drivers guide props-guide) (parse-t #'template depth esc?)]) [(drivers guide) (parse-t #'template depth esc?)])
(values (dset-add drivers mf) (values (dset-add drivers mf) (vector 'metafun mf guide)))]
(vector 'metafun mf guide)
(cons-guide '_ props-guide)))]
[(unsyntax t1) [(unsyntax t1)
(quasi) (quasi)
(let ([qval (quasi)]) (let ([qval (quasi)])
@ -455,36 +376,27 @@ instead of integers and integer vectors.
(set-box! qval (cons (cons #'tmp t) (unbox qval))) (set-box! qval (cons (cons #'tmp t) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)] (let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)]) [fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))] (values (dset fake-pvar) (vector 'unsyntax fake-pvar))))]
[else [else
(parameterize ((quasi (car qval))) (parameterize ((quasi (car qval)))
(let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) (let-values ([(drivers guide) (parse-t #'t1 depth esc?)])
(wrap-props t (values drivers (list-guide '_ guide))))]))]
drivers
(list-guide '_ guide)
(list-guide '_ props-guide))))]))]
[(quasitemplate t1) [(quasitemplate t1)
;; quasitemplate escapes inner unsyntaxes ;; quasitemplate escapes inner unsyntaxes
(quasi) (quasi)
(parameterize ((quasi (list (quasi)))) (parameterize ((quasi (list (quasi))))
(let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) (let-values ([(drivers guide) (parse-t #'t1 depth esc?)])
(wrap-props t (values drivers (list-guide '_ guide))))]
drivers
(list-guide '_ guide)
(list-guide '_ props-guide))))]
[(DOTS template) [(DOTS template)
(and (not esc?) (and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(let-values ([(drivers guide props-guide) (parse-t #'template depth #t)]) (let-values ([(drivers guide) (parse-t #'template depth #t)])
(values drivers (vector 'escaped guide) (values drivers (vector 'escaped guide)))]
(list-guide '_ props-guide)))]
[(?? t1 t2) [(?? t1 t2)
(not esc?) (not esc?)
(let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)] (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)]
[(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)]) [(drivers2 guide2) (parse-t #'t2 depth esc?)])
(values (dset-union drivers1 drivers2) (values (dset-union drivers1 drivers2) (vector 'orelse guide1 guide2)))]
(vector 'orelse guide1 guide2)
(list-guide '_ props-guide1 props-guide2)))]
[(head DOTS . tail) [(head DOTS . tail)
(and (not esc?) (and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
@ -495,9 +407,9 @@ instead of integers and integer vectors.
(and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(loop (add1 nesting) #'tail)] (loop (add1 nesting) #'tail)]
[else (values nesting tail)]))]) [else (values nesting tail)]))])
(let-values ([(hdrivers _hsplice? hguide hprops-guide) (let-values ([(hdrivers _hsplice? hguide)
(parse-h #'head (+ depth nesting) esc?)] (parse-h #'head (+ depth nesting) esc?)]
[(tdrivers tguide tprops-guide) [(tdrivers tguide)
(parse-t tail depth esc?)]) (parse-t tail depth esc?)])
(when (dset-empty? hdrivers) (when (dset-empty? hdrivers)
(wrong-syntax #'head "no pattern variables before ellipsis in template")) (wrong-syntax #'head "no pattern variables before ellipsis in template"))
@ -507,78 +419,65 @@ instead of integers and integer vectors.
;; select the nestingth (last) ellipsis as the bad one ;; select the nestingth (last) ellipsis as the bad one
(stx-car (stx-drop nesting t))]) (stx-car (stx-drop nesting t))])
(wrong-syntax bad-dots "too many ellipses in template"))) (wrong-syntax bad-dots "too many ellipses in template")))
(wrap-props t (values (dset-union hdrivers tdrivers)
(dset-union hdrivers tdrivers) ;; pre-guide hdrivers is (listof (setof pvar))
;; pre-guide hdrivers is (listof (setof pvar)) ;; set of pvars new to each level
;; set of pvars new to each level (let* ([hdrivers/level
(let* ([hdrivers/level (for/list ([i (in-range nesting)])
(for/list ([i (in-range nesting)]) (dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
(dset-filter hdrivers (pvar/dd<=? (+ depth i))))] [new-hdrivers/level
[new-hdrivers/level (let loop ([raw hdrivers/level] [last (dset)])
(let loop ([raw hdrivers/level] [last (dset)]) (cond [(null? raw) null]
(cond [(null? raw) null] [else
[else (cons (dset-subtract (car raw) last)
(cons (dset-subtract (car raw) last) (loop (cdr raw) (car raw)))]))])
(loop (cdr raw) (car raw)))]))]) (vector 'dots hguide new-hdrivers/level nesting #f tguide)))))]
(vector 'dots hguide new-hdrivers/level nesting #f tguide))
(cons-guide hprops-guide (cons-guide '_ tprops-guide)))))]
[(head . tail) [(head . tail)
(let-values ([(hdrivers hsplice? hguide hprops-guide) (let-values ([(hdrivers hsplice? hguide)
(parse-h #'head depth esc?)] (parse-h #'head depth esc?)]
[(tdrivers tguide tprops-guide) [(tdrivers tguide)
(parse-t #'tail depth esc?)]) (parse-t #'tail depth esc?)])
(wrap-props t (values (dset-union hdrivers tdrivers)
(dset-union hdrivers tdrivers) (cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_] [hsplice? (vector 'app hguide tguide)]
[hsplice? (vector 'app hguide tguide)] [else (cons hguide tguide)])))]
[else (cons hguide tguide)])
(cons-guide hprops-guide tprops-guide)))]
[vec [vec
(vector? (syntax-e #'vec)) (vector? (syntax-e #'vec))
(let-values ([(drivers guide props-guide) (let-values ([(drivers guide)
(parse-t (vector->list (syntax-e #'vec)) depth esc?)]) (parse-t (vector->list (syntax-e #'vec)) depth esc?)])
(wrap-props t drivers (values drivers (if (eq? guide '_) '_ (vector 'vector guide))))]
(if (eq? guide '_) '_ (vector 'vector guide))
(if (eq? props-guide '_) '_ (vector 'vector props-guide))))]
[pstruct [pstruct
(prefab-struct-key (syntax-e #'pstruct)) (prefab-struct-key (syntax-e #'pstruct))
(let-values ([(drivers guide props-guide) (let-values ([(drivers guide)
(parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)]) (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
(wrap-props t drivers (values drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
(if (eq? guide '_) '_ (vector 'struct guide))
(if (eq? props-guide '_) '_ (vector 'struct props-guide))))]
[#&template [#&template
(let-values ([(drivers guide props-guide) (let-values ([(drivers guide)
(parse-t #'template depth esc?)]) (parse-t #'template depth esc?)])
(wrap-props t drivers (values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
(if (eq? guide '_) '_ (vector 'box guide))
(if (eq? props-guide '_) '_ (vector 'box props-guide))))]
[const [const
(wrap-props t (dset) '_ '_)])) (values (dset) '_)]))
;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide) ;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide)
(define (parse-h h depth esc?) (define (parse-h h depth esc?)
(syntax-case h (?? ?@ unsyntax-splicing) (syntax-case h (?? ?@ unsyntax-splicing)
[(?? t) [(?? t)
(not esc?) (not esc?)
(let-values ([(drivers splice? guide props-guide) (let-values ([(drivers splice? guide)
(parse-h #'t depth esc?)]) (parse-h #'t depth esc?)])
(values drivers #t (values drivers #t (vector 'app-opt guide)))]
(vector 'app-opt guide)
(list-guide '_ props-guide)))]
[(?? t1 t2) [(?? t1 t2)
(not esc?) (not esc?)
(let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)] (let-values ([(drivers1 splice?1 guide1) (parse-h #'t1 depth esc?)]
[(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)]) [(drivers2 splice?2 guide2) (parse-h #'t2 depth esc?)])
(values (dset-union drivers1 drivers2) (values (dset-union drivers1 drivers2)
(or splice?1 splice?2) (or splice?1 splice?2)
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse) (vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
guide1 guide2) guide1 guide2)))]
(list-guide '_ props-guide1 props-guide2)))]
[(?@ . t) [(?@ . t)
(not esc?) (not esc?)
(let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) (let-values ([(drivers guide) (parse-t #'t depth esc?)])
(values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))] (values drivers #t (vector 'splice guide)))]
[(unsyntax-splicing t1) [(unsyntax-splicing t1)
(quasi) (quasi)
(let ([qval (quasi)]) (let ([qval (quasi)])
@ -587,19 +486,15 @@ instead of integers and integer vectors.
(set-box! qval (cons (cons #'tmp h) (unbox qval))) (set-box! qval (cons (cons #'tmp h) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)] (let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)]) [fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))] (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar))))]
[else [else
(parameterize ((quasi (car qval))) (parameterize ((quasi (car qval)))
(let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)] (let*-values ([(drivers guide) (parse-t #'t1 depth esc?)]
[(drivers guide props-guide) [(drivers guide) (values drivers (list-guide '_ guide))])
(wrap-props h (values drivers #f guide)))]))]
drivers
(list-guide '_ guide)
(list-guide '_ props-guide))])
(values drivers #f guide props-guide)))]))]
[t [t
(let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) (let-values ([(drivers guide) (parse-t #'t depth esc?)])
(values drivers #f guide props-guide))])) (values drivers #f guide))]))
(define (lookup id depth) (define (lookup id depth)
(let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v)