template: parse ellipses using stack of map environments
This is like the psyntax approach but frames are mutable and track extra information.
This commit is contained in:
Ryan Culpepper
parent
7b4e757fe5
commit
2915657c27
|
|
@ -73,50 +73,12 @@
|
|||
;; - (list 'h-t G)
|
||||
;; - other expression (must be pair!)
|
||||
|
||||
;; A PVar is (pvar Id Id Id/#f Nat/#f)
|
||||
;;
|
||||
;; The first identifier (var) is from the syntax-mapping or attribute-binding.
|
||||
;; The second (lvar) is a local variable name used to hold its value (or parts
|
||||
;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a
|
||||
;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see
|
||||
;; below) if it needs to be checked.
|
||||
;;
|
||||
;; The depth-delta associated with a depth>0 pattern variable is the difference
|
||||
;; between the pattern variable's depth and the depth at which it is used. (For
|
||||
;; depth 0 pvars, it's #f.) For example, in
|
||||
;;
|
||||
;; (with-syntax ([x #'0]
|
||||
;; [(y ...) #'(1 2)]
|
||||
;; [((z ...) ...) #'((a b) (c d))])
|
||||
;; (template (((x y z) ...) ...)))
|
||||
;;
|
||||
;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta
|
||||
;; for z is 0. The depth-delta (or depth "delay") is also the depth of the
|
||||
;; ellipsis form where the variable begins to be iterated over. That is, the
|
||||
;; template above should be interpreted roughly as
|
||||
;;
|
||||
;; (let ([Lx (pvar-value-of x)]
|
||||
;; [Ly (pvar-value-of y)]
|
||||
;; [Lz (pvar-value-of z)])
|
||||
;; (for/list ([Lz (in-list Lz)]) ;; depth 0
|
||||
;; (for/list ([Ly (in-list Ly)] ;; depth 1
|
||||
;; [Lz (in-list Lz)])
|
||||
;; (___ Lx Ly Lz ___))))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define here-stx (quote-syntax here))
|
||||
|
||||
(define template-logger (make-logger 'template (current-logger)))
|
||||
|
||||
;; (struct pvar (var lvar check dd) #:prefab)
|
||||
(define-values (struct:pv pvar pvar? pvar-ref pvar-set!)
|
||||
(make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3)))
|
||||
(define (pvar-var pv) (pvar-ref pv 0))
|
||||
(define (pvar-lvar pv) (pvar-ref pv 1))
|
||||
(define (pvar-check pv) (pvar-ref pv 2))
|
||||
(define (pvar-dd pv) (pvar-ref pv 3))
|
||||
|
||||
;; An Attribute is an identifier statically bound to a syntax-mapping
|
||||
;; (see sc.rkt) whose valvar is an identifier statically bound to an
|
||||
;; attribute-mapping.
|
||||
|
|
@ -170,14 +132,51 @@
|
|||
[(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))]
|
||||
[else (list 't-list* g1 g2)]))
|
||||
|
||||
;; A Depth is (Listof MapFrame)
|
||||
|
||||
;; A DotsFrame is (vector (Listof (cons Id Syntax)) (Hash Id => Id) Id Bool)
|
||||
;; Each ellipsis in a template has a corresponding DotsFrame of the form
|
||||
;; (vector env ht ellipsis-id any-vars?), where
|
||||
;; -- env is (list (cons iter-id src-list-expr) ...), where src-list-expr
|
||||
;; is a src-list-id either by itself or wrapped in a check
|
||||
;; -- ht maps a src-list-id to the corresponding iter-id
|
||||
;; -- ellipsis-id is the identifier for the ellipsis (for error reporting)
|
||||
;; -- any-vars? is a flag that indicates whether any pattern variables occur
|
||||
;; in this frame's subtemplate (for error reporting)
|
||||
;; When a pattern variable of depth D is found, it is added to the D current
|
||||
;; innermost (ie, topmost) dotsframes (see `lookup`).
|
||||
(define (new-dotsframe ellipsis-stx)
|
||||
(vector null (make-hasheq) ellipsis-stx #f))
|
||||
(define (dotsframe-env frame) (vector-ref frame 0))
|
||||
(define (dotsframe-ref frame src-id)
|
||||
(hash-ref (vector-ref frame 1) src-id #f))
|
||||
(define (dotsframe-add! frame iter-id src-id src-expr)
|
||||
(vector-set! frame 0 (cons (cons iter-id src-expr) (vector-ref frame 0)))
|
||||
(hash-set! (vector-ref frame 1) src-id iter-id))
|
||||
(define (dotsframe-index-iter frame) (vector-ref frame 2))
|
||||
(define (dotsframe-index-iter! frame)
|
||||
(cond [(vector-ref frame 2) => (lambda (x) x)]
|
||||
[else (let ([index-var (gentemp)])
|
||||
(vector-set! frame 2 index-var)
|
||||
index-var)]))
|
||||
(define (dotsframe-ellipsis-id frame) (vector-ref frame 2))
|
||||
(define (dotsframe-has-mapvars? frame) (pair? (vector-ref frame 0)))
|
||||
(define (dotsframe-has-any-vars? frame) (vector-ref frame 3))
|
||||
|
||||
(define (frames-seen-pvar! frames)
|
||||
(when (pair? frames)
|
||||
(unless (vector-ref (car frames) 3)
|
||||
(vector-set! (car frames) 3 #t)
|
||||
(frames-seen-pvar! (cdr frames)))))
|
||||
|
||||
(define (ellipsis? x)
|
||||
(and (identifier? x) (free-identifier=? x (quote-syntax ...))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Parsing templates
|
||||
|
||||
;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id))
|
||||
;; parse-template : Syntax Syntax Boolean -> (values Guide (Listof Id))
|
||||
(define (parse-template ctx t stx?)
|
||||
;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
|
||||
(define env (make-hasheq))
|
||||
|
||||
;; wrong-syntax : Syntax Format-String Any ... -> (error)
|
||||
(define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x))
|
||||
|
||||
|
|
@ -186,7 +185,7 @@
|
|||
;; disappeared! : Id -> Void
|
||||
(define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses)))
|
||||
|
||||
;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide)
|
||||
;; parse-t : Stx Nat Boolean -> Guide
|
||||
(define (parse-t t depth esc?)
|
||||
(cond [(stx-pair? t)
|
||||
(if (identifier? (stx-car t))
|
||||
|
|
@ -202,80 +201,64 @@
|
|||
[(parse-form t (quote-syntax ...) 1)
|
||||
=> (lambda (t)
|
||||
(disappeared! (car t))
|
||||
(define-values (drivers guide) (parse-t (cadr t) depth #t))
|
||||
(define guide (parse-t (cadr t) depth #t))
|
||||
;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _)
|
||||
(values drivers `(t-escaped ,guide)))]
|
||||
`(t-escaped ,guide))]
|
||||
[(parse-form t (quote-syntax ~?) 2)
|
||||
=> (lambda (t)
|
||||
(disappeared! (car t))
|
||||
(define t1 (cadr t))
|
||||
(define t2 (caddr t))
|
||||
(define-values (drivers1 guide1) (parse-t t1 depth esc?))
|
||||
(define-values (drivers2 guide2) (parse-t t2 depth esc?))
|
||||
(values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))]
|
||||
(define guide1 (parse-t t1 depth esc?))
|
||||
(define guide2 (parse-t t2 depth esc?))
|
||||
`(t-orelse ,guide1 ,guide2))]
|
||||
[(lookup-metafun (stx-car t))
|
||||
=> (lambda (mf)
|
||||
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
|
||||
(disappeared! (stx-car t))
|
||||
(define-values (drivers guide) (parse-t (stx-cdr t) depth esc?))
|
||||
(values drivers
|
||||
(define guide (parse-t (stx-cdr t) depth esc?))
|
||||
`(t-metafun ,(metafunction-var mf) ,guide
|
||||
(quote-syntax
|
||||
,(let ([tstx (and (syntax? t) t)])
|
||||
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx))))))]
|
||||
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))]
|
||||
[else (parse-t-pair/dots t depth esc?)]))
|
||||
|
||||
;; parse-t-pair/dots : Stx Nat Boolean -> ...
|
||||
;; t is a stx pair; check for dots
|
||||
(define (parse-t-pair/dots t depth esc?)
|
||||
(define head (stx-car t))
|
||||
(define-values (tail nesting)
|
||||
(let loop ([tail (stx-cdr t)] [nesting 0])
|
||||
(if (and (not esc?) (stx-pair? tail)
|
||||
(let ([x (stx-car tail)])
|
||||
(and (identifier? x) (free-identifier=? x (quote-syntax ...)))))
|
||||
(begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting)))
|
||||
(values tail nesting))))
|
||||
(if (zero? nesting)
|
||||
(parse-t-pair/normal t depth esc?)
|
||||
(let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)]
|
||||
[(tdrivers tguide) (parse-t tail depth esc?)])
|
||||
(when (dset-empty? hdrivers)
|
||||
(wrong-syntax head "no pattern variables before ellipsis in template"))
|
||||
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
|
||||
(let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
|
||||
(stx-car (stx-drop nesting t))])
|
||||
;; FIXME: improve error message?
|
||||
(wrong-syntax bad-dots "too many ellipses in template")))
|
||||
;; hdrivers is (listof (dsetof pvar))
|
||||
(define hdriverss ;; per level
|
||||
(let loop ([i 0])
|
||||
(if (< i nesting)
|
||||
(cons (dset-filter hdrivers (pvar/dd<=? (+ depth i)))
|
||||
(loop (add1 i)))
|
||||
null)))
|
||||
(define-values (tail frames) ;; first-in-stx = innermost is first in list
|
||||
(let loop ([tail (stx-cdr t)] [frames null])
|
||||
(cond [(and (not esc?) (stx-pair? tail) (ellipsis? (stx-car tail)))
|
||||
(disappeared! (stx-car tail))
|
||||
(loop (stx-cdr tail) (cons (new-dotsframe (stx-car tail)) frames))]
|
||||
[else (values tail (reverse frames))])))
|
||||
(define at-stx (datum->syntax #f '... head))
|
||||
(define hg
|
||||
(let loop ([hdriverss hdriverss])
|
||||
(cond [(null? (cdr hdriverss))
|
||||
(define hguide
|
||||
(let loop ([frames frames] [hguide (parse-h head (append frames depth) esc?)])
|
||||
(cond [(pair? frames)
|
||||
(define frame (car frames))
|
||||
(unless (dotsframe-has-mapvars? frame)
|
||||
(unless (dotsframe-has-any-vars? frame)
|
||||
(wrong-syntax head "no pattern variables before ellipsis in template"))
|
||||
(wrong-syntax (dotsframe-ellipsis-id frame) "too many ellipses in template"))
|
||||
(loop (cdr frames)
|
||||
(let ([cons? (ht-guide? hguide)]
|
||||
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
|
||||
`(t-dots ,cons? ,hguide ,(car hdriverss)
|
||||
(quote ,head) (quote-syntax ,at-stx)))]
|
||||
[else (let ([inner (loop (cdr hdriverss))])
|
||||
`(t-dots #f ,inner ,(car hdriverss)
|
||||
(quote ,head) (quote-syntax ,at-stx)))])))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(if (equal? tguide '(t-list))
|
||||
(resyntax t hg)
|
||||
(resyntax t `(t-append ,hg ,tguide)))))))
|
||||
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]
|
||||
[env (dotsframe-env frame)])
|
||||
;; FIXME: optimize (x ...) case where x is trusted!
|
||||
`(t-dots ,cons? ,hguide ,(map car env) ,(map cdr env)
|
||||
(quote ,head) (quote-syntax ,at-stx))))]
|
||||
[else hguide])))
|
||||
(define tguide (parse-t tail depth esc?))
|
||||
(cond [(equal? tguide `(t-list)) (resyntax t hguide)]
|
||||
[else (resyntax t `(t-append ,hguide ,tguide))]))
|
||||
|
||||
;; parse-t-pair/normal : Stx Nat Boolean -> ...
|
||||
;; t is a normal stx pair
|
||||
(define (parse-t-pair/normal t depth esc?)
|
||||
(define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?))
|
||||
(define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?))
|
||||
(values (dset-union hdrivers tdrivers)
|
||||
(define hguide (parse-h (stx-car t) depth esc?))
|
||||
(define tguide (parse-t (stx-cdr t) depth esc?))
|
||||
(resyntax t
|
||||
(if (ht-guide? hguide)
|
||||
(let ([hguide (ht-guide-t hguide)])
|
||||
|
|
@ -284,7 +267,7 @@
|
|||
(cons-guide hguide tguide)))
|
||||
(if (equal? tguide '(t-list))
|
||||
hguide
|
||||
`(t-append ,hguide ,tguide))))))
|
||||
`(t-append ,hguide ,tguide)))))
|
||||
|
||||
;; parse-t-nonpair : Syntax Nat Boolean -> ...
|
||||
;; PRE: t is not a stxpair
|
||||
|
|
@ -298,92 +281,89 @@
|
|||
(wrong-syntax t "illegal use")]
|
||||
[(lookup-metafun t)
|
||||
(wrong-syntax t "illegal use of syntax metafunction")]
|
||||
[(lookup t depth)
|
||||
=> (lambda (pvar)
|
||||
(disappeared! t)
|
||||
(values (dset pvar)
|
||||
(cond [(pvar-check pvar)
|
||||
=> (lambda (check)
|
||||
`(#%expression
|
||||
(,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))]
|
||||
[else `(t-var ,(pvar-lvar pvar))])))]
|
||||
[else (values (dset) (const-guide t))])]
|
||||
[(lookup t depth) => (lambda (ref) ref)]
|
||||
[else (const-guide t)])]
|
||||
[(vector? td)
|
||||
(define-values (drivers guide) (parse-t (vector->list td) depth esc?))
|
||||
(values drivers
|
||||
(define guide (parse-t (vector->list td) depth esc?))
|
||||
(cond [(const-guide? guide) (const-guide t)]
|
||||
[else (resyntax t `(t-vector ,guide))]))]
|
||||
[else (resyntax t `(t-vector ,guide))])]
|
||||
[(prefab-struct-key td)
|
||||
=> (lambda (key)
|
||||
(define-values (drivers guide)
|
||||
(define guide
|
||||
(let ([elems (cdr (vector->list (struct->vector td)))])
|
||||
(parse-t elems depth esc?)))
|
||||
(values drivers
|
||||
(cond [(const-guide? guide) (const-guide t)]
|
||||
[else (resyntax t `(t-struct (quote ,key) ,guide))])))]
|
||||
[else (resyntax t `(t-struct (quote ,key) ,guide))]))]
|
||||
[(box? td)
|
||||
(define-values (drivers guide) (parse-t (unbox td) depth esc?))
|
||||
(values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))]
|
||||
[else (values (dset) (const-guide t))]))
|
||||
(define guide (parse-t (unbox td) depth esc?))
|
||||
(if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide)))]
|
||||
[else (const-guide t)]))
|
||||
|
||||
;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide)
|
||||
;; parse-h : Syntax Depth Boolean -> HeadGuide
|
||||
(define (parse-h h depth esc?)
|
||||
(cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
|
||||
=> (lambda (h)
|
||||
(disappeared! (car h))
|
||||
(define-values (drivers guide) (parse-h (cadr h) depth esc?))
|
||||
(values drivers `(h-orelse ,guide null)))]
|
||||
(define guide (parse-h (cadr h) depth esc?))
|
||||
`(h-orelse ,guide null))]
|
||||
[(and (not esc?) (parse-form h (quote-syntax ~?) 2))
|
||||
=> (lambda (h)
|
||||
(disappeared! (car h))
|
||||
(define-values (drivers1 guide1) (parse-h (cadr h) depth esc?))
|
||||
(define-values (drivers2 guide2) (parse-h (caddr h) depth esc?))
|
||||
(values (dset-union drivers1 drivers2)
|
||||
(define guide1 (parse-h (cadr h) depth esc?))
|
||||
(define guide2 (parse-h (caddr h) depth esc?))
|
||||
(if (and (ht-guide? guide1) (ht-guide? guide2))
|
||||
`(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
|
||||
`(h-orelse ,guide1 ,guide2))))]
|
||||
`(h-orelse ,guide1 ,guide2)))]
|
||||
[(and (stx-pair? h)
|
||||
(let ([h-head (stx-car h)])
|
||||
(and (identifier? h-head)
|
||||
(or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?))
|
||||
(free-identifier=? h-head (quote-syntax ~@!))))))
|
||||
(disappeared! (stx-car h))
|
||||
(define-values (drivers guide) (parse-t (stx-cdr h) depth esc?))
|
||||
(values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))]
|
||||
(define guide (parse-t (stx-cdr h) depth esc?))
|
||||
`(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h)))]
|
||||
[else
|
||||
(define-values (drivers guide) (parse-t h depth esc?))
|
||||
(values drivers `(h-t ,guide))]))
|
||||
(define guide (parse-t h depth esc?))
|
||||
`(h-t ,guide)]))
|
||||
|
||||
;; lookup : Identifier Nat -> PVar/#f
|
||||
(define (lookup id depth)
|
||||
;; lookup : Identifier Depth -> Syntax/#f
|
||||
;; If pattern variable with depth>0, insert into depth innermost ellipsis envs.
|
||||
(define (lookup id depth0)
|
||||
(define (make-pvar var check pvar-depth)
|
||||
(cond [(zero? pvar-depth)
|
||||
(pvar var var check #f)]
|
||||
[(>= depth pvar-depth)
|
||||
(pvar var (gentemp) check (- depth pvar-depth))]
|
||||
[(zero? depth)
|
||||
(wrong-syntax id "missing ellipsis with pattern variable in template")]
|
||||
(define (make-ref var)
|
||||
(cond [check `(t-check-var (,check ,var 0 #t (quote-syntax ,id)))]
|
||||
[else `(t-var ,var)]))
|
||||
(define (make-src-ref var id)
|
||||
(cond [check `(#%expression (,check ,var 1 #f (quote-syntax ,id)))]
|
||||
[else `(#%expression ,var)]))
|
||||
(frames-seen-pvar! depth0)
|
||||
(make-ref
|
||||
(let dloop ([depth depth0] [pvar-depth pvar-depth]) ;; ... -> Identifier
|
||||
;; Returns variable reference whose value has not been checked yet.
|
||||
(cond [(zero? pvar-depth) var]
|
||||
[(null? depth)
|
||||
(if (null? depth0)
|
||||
(wrong-syntax id "missing ellipsis with pattern variable in template")
|
||||
(wrong-syntax id "too few ellipses for pattern variable in template"))]
|
||||
[else
|
||||
(wrong-syntax id "too few ellipses for pattern variable in template")]))
|
||||
(define (hash-ref! h k proc)
|
||||
(let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*))))
|
||||
(define src (dloop (cdr depth) (sub1 pvar-depth)))
|
||||
(or (dotsframe-ref (car depth) src)
|
||||
(let ([iter (gentemp)])
|
||||
(dotsframe-add! (car depth) iter src (make-src-ref src id))
|
||||
iter))]))))
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(cond [(and stx? (syntax-pattern-variable? v))
|
||||
(define pvar-depth (syntax-mapping-depth v))
|
||||
(define attr
|
||||
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
|
||||
(and (attribute-mapping? attr) attr)))
|
||||
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
|
||||
(define check (and attr (attribute-mapping-check attr)))
|
||||
(make-pvar var check pvar-depth)))]
|
||||
[(s-exp-pattern-variable? v)
|
||||
(hash-ref! env (cons v depth)
|
||||
(lambda ()
|
||||
(make-pvar var check pvar-depth)]
|
||||
[(and (not stx?) (s-exp-pattern-variable? v))
|
||||
(define pvar-depth (s-exp-mapping-depth v))
|
||||
(define var (s-exp-mapping-valvar v))
|
||||
(make-pvar var #f pvar-depth)))]
|
||||
(make-pvar var #f pvar-depth)]
|
||||
[else
|
||||
;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute
|
||||
(for-each
|
||||
|
|
@ -459,8 +439,8 @@
|
|||
[(syntax? x) `(t-const (quote-syntax ,x))]
|
||||
[else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))]))
|
||||
|
||||
(let-values ([(drivers guide) (parse-t t 0 #f)])
|
||||
(values (dset->list drivers) guide disappeared-uses)))
|
||||
(let ([guide (parse-t t null #f)])
|
||||
(values guide disappeared-uses)))
|
||||
|
||||
;; parse-form : Stx Id Nat -> (list[arity+1] Syntax)
|
||||
(define (parse-form stx form-id arity)
|
||||
|
|
@ -489,9 +469,6 @@
|
|||
(map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc))))
|
||||
dot-locations)))
|
||||
|
||||
(define (pvar/dd<=? expected-dd)
|
||||
(lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))))
|
||||
|
||||
(define gentemp-counter 0)
|
||||
(define (gentemp)
|
||||
(set! gentemp-counter (add1 gentemp-counter))
|
||||
|
|
@ -501,29 +478,6 @@
|
|||
(define (stx-drop n x)
|
||||
(if (zero? n) x (stx-drop (sub1 n) (stx-cdr x))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Deterministic Sets
|
||||
;; FIXME: detect big unions, use hash table
|
||||
|
||||
(define (dset . xs) xs)
|
||||
(define (dset-empty? ds) (null? ds))
|
||||
(define (dset-filter ds pred) (filter pred ds))
|
||||
(define (dset->list ds) ds)
|
||||
(define (dset-union ds1 ds2)
|
||||
(if (pair? ds1)
|
||||
(let ([elem (car ds1)])
|
||||
(if (member elem ds2)
|
||||
(dset-union (cdr ds1) ds2)
|
||||
(dset-union (cdr ds1) (cons (car ds1) ds2))))
|
||||
ds2))
|
||||
|
||||
(define (filter keep? xs)
|
||||
(if (pair? xs)
|
||||
(if (keep? (car xs))
|
||||
(cons (car xs) (filter keep? (cdr xs)))
|
||||
(filter keep? (cdr xs)))
|
||||
null))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Relocating (eg, syntax/loc)
|
||||
|
||||
|
|
@ -559,17 +513,13 @@
|
|||
|
||||
;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
|
||||
(define (do-template ctx tstx loc-id stx?)
|
||||
(define-values (pvars pre-guide disappeared-uses)
|
||||
(define-values (pre-guide disappeared-uses)
|
||||
(parse-template ctx tstx stx?))
|
||||
(define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
|
||||
(define ell-pvars (filter pvar-dd pvars))
|
||||
(define pre-code
|
||||
(if (const-guide? guide)
|
||||
(if stx? `(quote-syntax ,tstx) `(quote ,tstx))
|
||||
(let ([lvars (map pvar-lvar ell-pvars)]
|
||||
[valvars (map pvar-var ell-pvars)])
|
||||
`(let (,@(map list lvars valvars))
|
||||
,(datum->syntax here-stx guide)))))
|
||||
guide))
|
||||
(define code (syntax-arm (datum->syntax here-stx pre-code ctx)))
|
||||
(syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses)))
|
||||
)
|
||||
|
|
@ -609,33 +559,22 @@
|
|||
;; ============================================================
|
||||
;; Run-time support
|
||||
|
||||
;; (t-dots cons? hguide hdrivers) : Expr[(Listof Syntax)]
|
||||
;; (t-dots cons? hguide iter-vars src-vars head-datum at-stx) : Expr[(Listof Syntax)]
|
||||
(define-syntax (t-dots stx)
|
||||
(define s (syntax->list stx))
|
||||
(define cons? (syntax-e (list-ref s 1)))
|
||||
(define head (list-ref s 2))
|
||||
(define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar)
|
||||
(define in-stx (list-ref s 4))
|
||||
(define at-stx (list-ref s 5))
|
||||
(cond
|
||||
;; Case 1: (x ...) where x is trusted
|
||||
[(and cons? (let ([head-s (syntax->list head)])
|
||||
(and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var))))
|
||||
head]
|
||||
;; General case
|
||||
[else
|
||||
;; var-value-expr : Id Id/#'#f -> Expr[List]
|
||||
(define (var-value-expr lvar check)
|
||||
(if (syntax-e check) `(,check ,lvar 1 #f #f) lvar))
|
||||
(define lvars (map pvar-lvar drivers))
|
||||
(define checks (map pvar-check drivers))
|
||||
(define iter-vars (syntax->list (list-ref s 3)))
|
||||
(define src-exprs (syntax->list (list-ref s 4)))
|
||||
(define in-stx (list-ref s 5))
|
||||
(define at-stx (list-ref s 6))
|
||||
(define code
|
||||
`(let ,(map list lvars (map var-value-expr lvars checks))
|
||||
,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void))
|
||||
`(let ,(map list iter-vars src-exprs)
|
||||
,(if (> (length iter-vars) 1) `(check-same-length ,in-stx ,at-stx . ,iter-vars) '(void))
|
||||
,(if cons?
|
||||
`(map (lambda ,lvars ,head) . ,lvars)
|
||||
`(apply append (map (lambda ,lvars ,head) . ,lvars)))))
|
||||
(datum->syntax here-stx code stx)]))
|
||||
`(map (lambda ,iter-vars ,head) . ,iter-vars)
|
||||
`(apply append (map (lambda ,iter-vars ,head) . ,iter-vars)))))
|
||||
(datum->syntax here-stx code stx))
|
||||
|
||||
(define-syntaxes (t-orelse h-orelse)
|
||||
(let ()
|
||||
|
|
@ -647,6 +586,7 @@
|
|||
|
||||
(#%require (rename '#%kernel t-const #%expression)
|
||||
(rename '#%kernel t-var #%expression)
|
||||
(rename '#%kernel t-check-var #%expression)
|
||||
;; (rename '#%kernel t-append append)
|
||||
(rename '#%kernel t-list list)
|
||||
(rename '#%kernel t-list* list*)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user