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

find syntax properties to transfer at compile time

Browse Source
This commit is contained in:
Ryan Culpepper 2012-07-31 19:14:14 -04:00
parent 6eb8da1f40
commit 9e566a90ac
2 changed files with 48 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/syntax/parse/experimental/private/substitute.rkt
View File

@ -29,6 +29,7 @@ A Guide (G) is one of:
- (vector 'escaped G)
- (vector 'orelse G (vector-of integer) G)
- (vector 'metafun integer G)
- (vector 'props G (listof (cons any any)))
A HeadGuide (HG) is one of:
- G
@ -193,7 +194,12 @@ A HeadGuide (HG) is one of:
[(vector 'box g1)
(let ([f1 (loop (unbox (syntax-e stx)) g1)])
(lambda (env lenv)
(restx stx (box (f1 env lenv)))))]))
(restx stx (box (f1 env lenv)))))]
[(vector '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)))))]))
(define (translate-hg stx0 stx hg env-length lenv-mode)
(define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
@ -283,11 +289,7 @@ A HeadGuide (HG) is one of:
(define (restx basis val)
(if (syntax? basis)
(let ([stx (datum->syntax basis val basis)]
[paren-shape (syntax-property basis 'paren-shape)])
(if paren-shape
(syntax-property stx 'paren-shape paren-shape)
stx))
(datum->syntax basis val basis)
val))
;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)

62
collects/syntax/parse/experimental/template.rkt
View File

@ -211,6 +211,8 @@ instead of integers and integer vectors.
(vector 'struct (loop g1 loop-env))]
[(vector 'box g1)
(vector 'box (loop (unbox g) loop-env))]
[(vector 'props g1 props-alist)
(vector 'props (loop g1 loop-env) props-alist)]
[(vector 'app-opt g1 drivers1)
(vector 'app-opt
(loop g1 loop-env)
@ -223,6 +225,19 @@ instead of integers and integer vectors.
;; ----------------------------------------
(define retain-props '(paren-shape))
(define (wrap-props stx env-set pre-guide)
(let ([prop-entries (for/fold ([entries null]) ([prop (in-list retain-props)])
(let ([v (syntax-property stx prop)])
(if (and v) ;; FIXME: add read-write-able check!
(cons (cons prop v) entries)
entries)))])
(values env-set
(if (pair? prop-entries)
(vector 'props pre-guide prop-entries)
pre-guide))))
;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide)
(define (parse-t t depth esc?)
(syntax-case t (?? ?@)
@ -239,7 +254,8 @@ instead of integers and integer vectors.
(values (set pvar) pvar)]
[(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")]
[else (values (set) '_)]))])]
[else
(wrap-props #'id (set) '_)]))])]
[(mf . template)
(and (not esc?)
(identifier? #'mf)
@ -273,40 +289,42 @@ instead of integers and integer vectors.
[(tdrivers tguide) (parse-t tail depth esc?)])
(unless (positive? (set-count hdrivers))
(wrong-syntax #'head "no pattern variables in term before ellipsis"))
(values (set-union hdrivers tdrivers)
;; pre-guide hdrivers is (listof (setof pvar))
;; set of pvars new to each level
(let* ([hdrivers/level
(for/list ([i (in-range nesting)])
(set-filter hdrivers (pvar/dd<=? (+ depth i))))]
[new-hdrivers/level
(let loop ([raw hdrivers/level] [last (set)])
(cond [(null? raw) null]
[else
(cons (set-subtract (car raw) last)
(loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide)))))]
(wrap-props t
(set-union hdrivers tdrivers)
;; pre-guide hdrivers is (listof (setof pvar))
;; set of pvars new to each level
(let* ([hdrivers/level
(for/list ([i (in-range nesting)])
(set-filter hdrivers (pvar/dd<=? (+ depth i))))]
[new-hdrivers/level
(let loop ([raw hdrivers/level] [last (set)])
(cond [(null? raw) null]
[else
(cons (set-subtract (car raw) last)
(loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide)))))]
[(head . tail)
(let-values ([(hdrivers hsplice? hguide) (parse-h #'head depth esc?)]
[(tdrivers tguide) (parse-t #'tail depth esc?)])
(values (set-union hdrivers tdrivers)
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
[hsplice? (vector 'app hguide tguide)]
[else (cons hguide tguide)])))]
(wrap-props t
(set-union hdrivers tdrivers)
(cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
[hsplice? (vector 'app hguide tguide)]
[else (cons hguide tguide)])))]
[vec
(vector? (syntax-e #'vec))
(let-values ([(drivers guide) (parse-t (vector->list (syntax-e #'vec)) depth esc?)])
(values drivers (if (eq? guide '_) '_ (vector 'vector guide))))]
(wrap-props t drivers (if (eq? guide '_) '_ (vector 'vector guide))))]
[pstruct
(prefab-struct-key (syntax-e #'pstruct))
(let-values ([(drivers guide)
(parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
(values drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
(wrap-props t drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
[#&template
(let-values ([(drivers guide) (parse-t #'template depth esc?)])
(values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
(wrap-props t drivers (if (eq? guide '_) '_ (vector 'box guide))))]
[const
(values (set) '_)]))
(wrap-props t (set) '_)]))
;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide)
(define (parse-h h depth esc?)