From 9e566a90ac50349b5dce028855699eb7d85258e0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 31 Jul 2012 19:14:14 -0400 Subject: [PATCH] find syntax properties to transfer at compile time --- .../parse/experimental/private/substitute.rkt | 14 +++-- .../syntax/parse/experimental/template.rkt | 62 ++++++++++++------- 2 files changed, 48 insertions(+), 28 deletions(-) diff --git a/collects/syntax/parse/experimental/private/substitute.rkt b/collects/syntax/parse/experimental/private/substitute.rkt index b05447c6b3..9060f4783c 100644 --- a/collects/syntax/parse/experimental/private/substitute.rkt +++ b/collects/syntax/parse/experimental/private/substitute.rkt @@ -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) diff --git a/collects/syntax/parse/experimental/template.rkt b/collects/syntax/parse/experimental/template.rkt index d91ffce3e5..400c5f031f 100644 --- a/collects/syntax/parse/experimental/template.rkt +++ b/collects/syntax/parse/experimental/template.rkt @@ -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?)