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

template: parse ellipses using stack of map environments

Browse Source 
This is like the psyntax approach but frames are mutable
and track extra information.
This commit is contained in:
Ryan Culpepper 2019-06-14 01:16:33 +02:00
parent 7b4e757fe5
commit 2915657c27
1 changed files with 164 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

388
racket/collects/racket/private/template.rkt
View File

@ -73,50 +73,12 @@
;; - (list 'h-t G) ;; - (list 'h-t G)
;; - other expression (must be pair!) ;; - 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 (begin-for-syntax
(define here-stx (quote-syntax here)) (define here-stx (quote-syntax here))
(define template-logger (make-logger 'template (current-logger))) (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 ;; An Attribute is an identifier statically bound to a syntax-mapping
;; (see sc.rkt) whose valvar is an identifier statically bound to an ;; (see sc.rkt) whose valvar is an identifier statically bound to an
;; attribute-mapping. ;; attribute-mapping.
@ -170,14 +132,51 @@
[(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))] [(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))]
[else (list 't-list* g1 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 ;; 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?) (define (parse-template ctx t stx?)
;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
(define env (make-hasheq))
;; wrong-syntax : Syntax Format-String Any ... -> (error) ;; wrong-syntax : Syntax Format-String Any ... -> (error)
(define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x)) (define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x))
@ -186,7 +185,7 @@
;; disappeared! : Id -> Void ;; disappeared! : Id -> Void
(define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses))) (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?) (define (parse-t t depth esc?)
(cond [(stx-pair? t) (cond [(stx-pair? t)
(if (identifier? (stx-car t)) (if (identifier? (stx-car t))
@ -202,89 +201,73 @@
[(parse-form t (quote-syntax ...) 1) [(parse-form t (quote-syntax ...) 1)
=> (lambda (t) => (lambda (t)
(disappeared! (car 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 _) ;; 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) [(parse-form t (quote-syntax ~?) 2)
=> (lambda (t) => (lambda (t)
(disappeared! (car t)) (disappeared! (car t))
(define t1 (cadr t)) (define t1 (cadr t))
(define t2 (caddr t)) (define t2 (caddr t))
(define-values (drivers1 guide1) (parse-t t1 depth esc?)) (define guide1 (parse-t t1 depth esc?))
(define-values (drivers2 guide2) (parse-t t2 depth esc?)) (define guide2 (parse-t t2 depth esc?))
(values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] `(t-orelse ,guide1 ,guide2))]
[(lookup-metafun (stx-car t)) [(lookup-metafun (stx-car t))
=> (lambda (mf) => (lambda (mf)
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported")) (unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
(disappeared! (stx-car t)) (disappeared! (stx-car t))
(define-values (drivers guide) (parse-t (stx-cdr t) depth esc?)) (define guide (parse-t (stx-cdr t) depth esc?))
(values drivers `(t-metafun ,(metafunction-var mf) ,guide
`(t-metafun ,(metafunction-var mf) ,guide (quote-syntax
(quote-syntax ,(let ([tstx (and (syntax? t) t)])
,(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?)])) [else (parse-t-pair/dots t depth esc?)]))
;; parse-t-pair/dots : Stx Nat Boolean -> ... ;; parse-t-pair/dots : Stx Nat Boolean -> ...
;; t is a stx pair; check for dots ;; t is a stx pair; check for dots
(define (parse-t-pair/dots t depth esc?) (define (parse-t-pair/dots t depth esc?)
(define head (stx-car t)) (define head (stx-car t))
(define-values (tail nesting) (define-values (tail frames) ;; first-in-stx = innermost is first in list
(let loop ([tail (stx-cdr t)] [nesting 0]) (let loop ([tail (stx-cdr t)] [frames null])
(if (and (not esc?) (stx-pair? tail) (cond [(and (not esc?) (stx-pair? tail) (ellipsis? (stx-car tail)))
(let ([x (stx-car tail)]) (disappeared! (stx-car tail))
(and (identifier? x) (free-identifier=? x (quote-syntax ...))))) (loop (stx-cdr tail) (cons (new-dotsframe (stx-car tail)) frames))]
(begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting))) [else (values tail (reverse frames))])))
(values tail nesting)))) (define at-stx (datum->syntax #f '... head))
(if (zero? nesting) (define hguide
(parse-t-pair/normal t depth esc?) (let loop ([frames frames] [hguide (parse-h head (append frames depth) esc?)])
(let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)] (cond [(pair? frames)
[(tdrivers tguide) (parse-t tail depth esc?)]) (define frame (car frames))
(when (dset-empty? hdrivers) (unless (dotsframe-has-mapvars? frame)
(wrong-syntax head "no pattern variables before ellipsis in template")) (unless (dotsframe-has-any-vars? frame)
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) (wrong-syntax head "no pattern variables before ellipsis in template"))
(let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one (wrong-syntax (dotsframe-ellipsis-id frame) "too many ellipses in template"))
(stx-car (stx-drop nesting t))]) (loop (cdr frames)
;; 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 at-stx (datum->syntax #f '... head))
(define hg
(let loop ([hdriverss hdriverss])
(cond [(null? (cdr hdriverss))
(let ([cons? (ht-guide? hguide)] (let ([cons? (ht-guide? hguide)]
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]
`(t-dots ,cons? ,hguide ,(car hdriverss) [env (dotsframe-env frame)])
(quote ,head) (quote-syntax ,at-stx)))] ;; FIXME: optimize (x ...) case where x is trusted!
[else (let ([inner (loop (cdr hdriverss))]) `(t-dots ,cons? ,hguide ,(map car env) ,(map cdr env)
`(t-dots #f ,inner ,(car hdriverss) (quote ,head) (quote-syntax ,at-stx))))]
(quote ,head) (quote-syntax ,at-stx)))]))) [else hguide])))
(values (dset-union hdrivers tdrivers) (define tguide (parse-t tail depth esc?))
(if (equal? tguide '(t-list)) (cond [(equal? tguide `(t-list)) (resyntax t hguide)]
(resyntax t hg) [else (resyntax t `(t-append ,hguide ,tguide))]))
(resyntax t `(t-append ,hg ,tguide)))))))
;; parse-t-pair/normal : Stx Nat Boolean -> ... ;; parse-t-pair/normal : Stx Nat Boolean -> ...
;; t is a normal stx pair ;; t is a normal stx pair
(define (parse-t-pair/normal t depth esc?) (define (parse-t-pair/normal t depth esc?)
(define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?)) (define hguide (parse-h (stx-car t) depth esc?))
(define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?)) (define tguide (parse-t (stx-cdr t) depth esc?))
(values (dset-union hdrivers tdrivers) (resyntax t
(resyntax t (if (ht-guide? hguide)
(if (ht-guide? hguide) (let ([hguide (ht-guide-t hguide)])
(let ([hguide (ht-guide-t hguide)]) (if (and (const-guide? hguide) (const-guide? tguide))
(if (and (const-guide? hguide) (const-guide? tguide)) (const-guide t)
(const-guide t) (cons-guide hguide tguide)))
(cons-guide hguide tguide))) (if (equal? tguide '(t-list))
(if (equal? tguide '(t-list)) hguide
hguide `(t-append ,hguide ,tguide)))))
`(t-append ,hguide ,tguide))))))
;; parse-t-nonpair : Syntax Nat Boolean -> ... ;; parse-t-nonpair : Syntax Nat Boolean -> ...
;; PRE: t is not a stxpair ;; PRE: t is not a stxpair
@ -298,92 +281,89 @@
(wrong-syntax t "illegal use")] (wrong-syntax t "illegal use")]
[(lookup-metafun t) [(lookup-metafun t)
(wrong-syntax t "illegal use of syntax metafunction")] (wrong-syntax t "illegal use of syntax metafunction")]
[(lookup t depth) [(lookup t depth) => (lambda (ref) ref)]
=> (lambda (pvar) [else (const-guide t)])]
(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))])]
[(vector? td) [(vector? td)
(define-values (drivers guide) (parse-t (vector->list td) depth esc?)) (define guide (parse-t (vector->list td) depth esc?))
(values drivers (cond [(const-guide? guide) (const-guide t)]
(cond [(const-guide? guide) (const-guide t)] [else (resyntax t `(t-vector ,guide))])]
[else (resyntax t `(t-vector ,guide))]))]
[(prefab-struct-key td) [(prefab-struct-key td)
=> (lambda (key) => (lambda (key)
(define-values (drivers guide) (define guide
(let ([elems (cdr (vector->list (struct->vector td)))]) (let ([elems (cdr (vector->list (struct->vector td)))])
(parse-t elems depth esc?))) (parse-t elems depth esc?)))
(values drivers (cond [(const-guide? guide) (const-guide t)]
(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) [(box? td)
(define-values (drivers guide) (parse-t (unbox td) depth esc?)) (define guide (parse-t (unbox td) depth esc?))
(values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))] (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide)))]
[else (values (dset) (const-guide t))])) [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?) (define (parse-h h depth esc?)
(cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1)) (cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
=> (lambda (h) => (lambda (h)
(disappeared! (car h)) (disappeared! (car h))
(define-values (drivers guide) (parse-h (cadr h) depth esc?)) (define guide (parse-h (cadr h) depth esc?))
(values drivers `(h-orelse ,guide null)))] `(h-orelse ,guide null))]
[(and (not esc?) (parse-form h (quote-syntax ~?) 2)) [(and (not esc?) (parse-form h (quote-syntax ~?) 2))
=> (lambda (h) => (lambda (h)
(disappeared! (car h)) (disappeared! (car h))
(define-values (drivers1 guide1) (parse-h (cadr h) depth esc?)) (define guide1 (parse-h (cadr h) depth esc?))
(define-values (drivers2 guide2) (parse-h (caddr h) depth esc?)) (define guide2 (parse-h (caddr h) depth esc?))
(values (dset-union drivers1 drivers2) (if (and (ht-guide? guide1) (ht-guide? guide2))
(if (and (ht-guide? guide1) (ht-guide? guide2)) `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t 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) [(and (stx-pair? h)
(let ([h-head (stx-car h)]) (let ([h-head (stx-car h)])
(and (identifier? h-head) (and (identifier? h-head)
(or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?)) (or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?))
(free-identifier=? h-head (quote-syntax ~@!)))))) (free-identifier=? h-head (quote-syntax ~@!))))))
(disappeared! (stx-car h)) (disappeared! (stx-car h))
(define-values (drivers guide) (parse-t (stx-cdr h) depth esc?)) (define guide (parse-t (stx-cdr h) depth esc?))
(values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))] `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h)))]
[else [else
(define-values (drivers guide) (parse-t h depth esc?)) (define guide (parse-t h depth esc?))
(values drivers `(h-t ,guide))])) `(h-t ,guide)]))
;; lookup : Identifier Nat -> PVar/#f ;; lookup : Identifier Depth -> Syntax/#f
(define (lookup id depth) ;; If pattern variable with depth>0, insert into depth innermost ellipsis envs.
(define (lookup id depth0)
(define (make-pvar var check pvar-depth) (define (make-pvar var check pvar-depth)
(cond [(zero? pvar-depth) (define (make-ref var)
(pvar var var check #f)] (cond [check `(t-check-var (,check ,var 0 #t (quote-syntax ,id)))]
[(>= depth pvar-depth) [else `(t-var ,var)]))
(pvar var (gentemp) check (- depth pvar-depth))] (define (make-src-ref var id)
[(zero? depth) (cond [check `(#%expression (,check ,var 1 #f (quote-syntax ,id)))]
(wrong-syntax id "missing ellipsis with pattern variable in template")] [else `(#%expression ,var)]))
[else (frames-seen-pvar! depth0)
(wrong-syntax id "too few ellipses for pattern variable in template")])) (make-ref
(define (hash-ref! h k proc) (let dloop ([depth depth0] [pvar-depth pvar-depth]) ;; ... -> Identifier
(let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*)))) ;; 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
(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))]) (let ([v (syntax-local-value id (lambda () #f))])
(cond [(syntax-pattern-variable? v) (cond [(and stx? (syntax-pattern-variable? v))
(hash-ref! env (cons v depth) (define pvar-depth (syntax-mapping-depth v))
(lambda () (define attr
(define pvar-depth (syntax-mapping-depth v)) (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
(define attr (and (attribute-mapping? attr) attr)))
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
(and (attribute-mapping? attr) attr))) (define check (and attr (attribute-mapping-check attr)))
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) (make-pvar var check pvar-depth)]
(define check (and attr (attribute-mapping-check attr))) [(and (not stx?) (s-exp-pattern-variable? v))
(make-pvar var check pvar-depth)))] (define pvar-depth (s-exp-mapping-depth v))
[(s-exp-pattern-variable? v) (define var (s-exp-mapping-valvar v))
(hash-ref! env (cons v depth) (make-pvar var #f pvar-depth)]
(lambda ()
(define pvar-depth (s-exp-mapping-depth v))
(define var (s-exp-mapping-valvar v))
(make-pvar var #f pvar-depth)))]
[else [else
;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute ;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute
(for-each (for-each
@ -459,8 +439,8 @@
[(syntax? x) `(t-const (quote-syntax ,x))] [(syntax? x) `(t-const (quote-syntax ,x))]
[else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))])) [else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))]))
(let-values ([(drivers guide) (parse-t t 0 #f)]) (let ([guide (parse-t t null #f)])
(values (dset->list drivers) guide disappeared-uses))) (values guide disappeared-uses)))
;; parse-form : Stx Id Nat -> (list[arity+1] Syntax) ;; parse-form : Stx Id Nat -> (list[arity+1] Syntax)
(define (parse-form stx form-id arity) (define (parse-form stx form-id arity)
@ -489,9 +469,6 @@
(map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc)))) (map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc))))
dot-locations))) 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-counter 0)
(define (gentemp) (define (gentemp)
(set! gentemp-counter (add1 gentemp-counter)) (set! gentemp-counter (add1 gentemp-counter))
@ -501,29 +478,6 @@
(define (stx-drop n x) (define (stx-drop n x)
(if (zero? n) x (stx-drop (sub1 n) (stx-cdr 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) ;; Relocating (eg, syntax/loc)
@ -559,17 +513,13 @@
;; do-template : Syntax Syntax Id/#f Boolean -> Syntax ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
(define (do-template ctx tstx loc-id stx?) (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?)) (parse-template ctx tstx stx?))
(define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide)) (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
(define ell-pvars (filter pvar-dd pvars))
(define pre-code (define pre-code
(if (const-guide? guide) (if (const-guide? guide)
(if stx? `(quote-syntax ,tstx) `(quote ,tstx)) (if stx? `(quote-syntax ,tstx) `(quote ,tstx))
(let ([lvars (map pvar-lvar ell-pvars)] guide))
[valvars (map pvar-var ell-pvars)])
`(let (,@(map list lvars valvars))
,(datum->syntax here-stx guide)))))
(define code (syntax-arm (datum->syntax here-stx pre-code ctx))) (define code (syntax-arm (datum->syntax here-stx pre-code ctx)))
(syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses))) (syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses)))
) )
@ -609,33 +559,22 @@
;; ============================================================ ;; ============================================================
;; Run-time support ;; 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-syntax (t-dots stx)
(define s (syntax->list stx)) (define s (syntax->list stx))
(define cons? (syntax-e (list-ref s 1))) (define cons? (syntax-e (list-ref s 1)))
(define head (list-ref s 2)) (define head (list-ref s 2))
(define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar) (define iter-vars (syntax->list (list-ref s 3)))
(define in-stx (list-ref s 4)) (define src-exprs (syntax->list (list-ref s 4)))
(define at-stx (list-ref s 5)) (define in-stx (list-ref s 5))
(cond (define at-stx (list-ref s 6))
;; Case 1: (x ...) where x is trusted (define code
[(and cons? (let ([head-s (syntax->list head)]) `(let ,(map list iter-vars src-exprs)
(and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var)))) ,(if (> (length iter-vars) 1) `(check-same-length ,in-stx ,at-stx . ,iter-vars) '(void))
head] ,(if cons?
;; General case `(map (lambda ,iter-vars ,head) . ,iter-vars)
[else `(apply append (map (lambda ,iter-vars ,head) . ,iter-vars)))))
;; var-value-expr : Id Id/#'#f -> Expr[List] (datum->syntax here-stx code stx))
(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 code
`(let ,(map list lvars (map var-value-expr lvars checks))
,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void))
,(if cons?
`(map (lambda ,lvars ,head) . ,lvars)
`(apply append (map (lambda ,lvars ,head) . ,lvars)))))
(datum->syntax here-stx code stx)]))
(define-syntaxes (t-orelse h-orelse) (define-syntaxes (t-orelse h-orelse)
(let () (let ()
@ -647,6 +586,7 @@
(#%require (rename '#%kernel t-const #%expression) (#%require (rename '#%kernel t-const #%expression)
(rename '#%kernel t-var #%expression) (rename '#%kernel t-var #%expression)
(rename '#%kernel t-check-var #%expression)
;; (rename '#%kernel t-append append) ;; (rename '#%kernel t-append append)
(rename '#%kernel t-list list) (rename '#%kernel t-list list)
(rename '#%kernel t-list* list*) (rename '#%kernel t-list* list*)