commit 1795b7af5f3c57ae829f1e2eaa9cd83bdb090edf
parent f97039fb1f0e9a0d8e2d63abc0b1f41679c0d0e3
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 7 Aug 2017 19:17:47 -0400
syntax/parse template: remove syntax-property handling
Since template was written, Racket has added a notion of preserved
syntax properties.
Diffstat:
4 files changed, 74 insertions(+), 287 deletions(-)
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
@@ -30,8 +30,6 @@ A Guide (G) is one of:
- (vector 'escaped G)
- (vector 'orelse G G)
- (vector 'metafun integer G)
- - (vector 'copy-props G (listof symbol))
- - (vector 'set-props G (listof (cons symbol any)))
- (vector 'unsyntax VarRef)
- (vector 'relocate G)
@@ -281,21 +279,6 @@ An VarRef is one of
(lambda (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)
(let ([f1 (loop stx var)])
(lambda (env lenv)
@@ -424,7 +407,7 @@ An VarRef is one of
(define (restx basis val)
(if (syntax? basis)
- (datum->syntax basis val basis)
+ (datum->syntax basis val basis basis)
val))
;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -45,11 +45,13 @@ A HeadTemplate (H) is one of:
|#
(begin-for-syntax
+ (define-logger template)
+
(define (do-template ctx tstx quasi? loc-id)
(with-disappeared-uses
(parameterize ((current-syntax-context ctx)
(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)
(for/list ([dep (in-vector deps)])
(cond [(pvar? dep) (pvar-var dep)]
@@ -62,13 +64,12 @@ A HeadTemplate (H) is one of:
(with-syntax ([t tstx])
(syntax-arm
(cond [(equal? guide '1)
- ;; was (template pvar), implies props-guide = '_
+ ;; was (template pvar)
(car vars)]
- [(and (equal? guide '_) (equal? props-guide '_))
+ [(equal? guide '_)
#'(quote-syntax t)]
[else
(with-syntax ([guide guide]
- [props-guide props-guide]
[vars-vector
(if (pair? vars)
#`(vector . #,vars)
@@ -77,7 +78,6 @@ A HeadTemplate (H) is one of:
(if quasi? (reverse (unbox (quasi))) null)])
#'(let ([un-var (handle-unsyntax un-form)] ...)
(substitute (quote-syntax t)
- 'props-guide
'guide
vars-vector)))]))))))))
@@ -85,10 +85,9 @@ A HeadTemplate (H) is one of:
(syntax-case stx ()
[(template t)
(do-template stx #'t #f #f)]
- [(template t #:properties (prop ...))
- (andmap identifier? (syntax->list #'(prop ...)))
- (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
- (props-to-transfer (syntax->datum #'(prop ...))))
+ [(template t #:properties _)
+ (begin
+ (log-template-error "template #:properties argument no longer supported: ~e" stx)
(do-template stx #'t #f #f))]))
(define-syntax (quasitemplate stx)
@@ -140,21 +139,11 @@ A HeadTemplate (H) is one of:
;; template, since eq? templates must have equal? guides.
(define substitute-table (make-weak-hasheq))
-;; props-syntax-table : hash[stx => stx]
-(define props-syntax-table (make-weak-hasheq))
-
-(define (substitute stx props-guide g main-env)
- (let* ([stx (if (eq? props-guide '_)
- 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))])
+(define (substitute stx g main-env)
+ (let ([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)))
;; ----
@@ -225,30 +214,14 @@ instead of integers and integer vectors.
(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))))
;; each list wrapper represents nested quasi wrapping
;; QuasiPairs = (listof (cons/c identifier syntax))
(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)
- (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)
(if loc-id
(let* ([loc-sm (make-auto-pvar 0 loc-id)]
@@ -259,8 +232,7 @@ instead of integers and integer vectors.
(let* ([main-env (dset->env drivers (hash))]
[guide (guide-resolve-env pre-guide main-env)])
(values guide
- (index-hash->vector main-env)
- props-guide))))
+ (index-hash->vector main-env)))))
;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
(define (dset->env drivers init-env)
@@ -316,10 +288,6 @@ instead of integers and integer vectors.
(vector 'struct (loop g1 loop-env))]
[(vector 'box g1)
(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 (loop g1 loop-env))]
[(vector 'splice g1)
@@ -364,8 +332,6 @@ instead of integers and integer vectors.
(relocate g)]
[(vector 'box g1)
(relocate g)]
- [(vector 'copy-props g1 keys)
- (vector 'copy-props (loop g1) keys)]
[(vector 'unsyntax var)
g]
;; ----
@@ -391,56 +357,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)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2)))
(define (list-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?)
(syntax-case t (?? ?@ unsyntax quasitemplate)
[id
@@ -456,20 +379,18 @@ instead of integers and integer vectors.
[else
(let ([pvar (lookup #'id depth)])
(cond [(pvar? pvar)
- (values (dset pvar) pvar '_)]
+ (values (dset pvar) pvar)]
[(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")]
[else
- (wrap-props #'id (dset) '_ '_)]))])]
+ (values (dset) '_)]))])]
[(mf . template)
(and (not esc?)
(identifier? #'mf)
(template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
- [(drivers guide props-guide) (parse-t #'template depth esc?)])
- (values (dset-add drivers mf)
- (vector 'metafun mf guide)
- (cons-guide '_ props-guide)))]
+ [(drivers guide) (parse-t #'template depth esc?)])
+ (values (dset-add drivers mf) (vector 'metafun mf guide)))]
[(unsyntax t1)
(quasi)
(let ([qval (quasi)])
@@ -478,36 +399,27 @@ instead of integers and integer vectors.
(set-box! qval (cons (cons #'tmp t) (unbox qval)))
(let* ([fake-sm (make-auto-pvar 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
- (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))]
+ (values (dset fake-pvar) (vector 'unsyntax fake-pvar))))]
[else
(parameterize ((quasi (car qval)))
- (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
- (wrap-props t
- drivers
- (list-guide '_ guide)
- (list-guide '_ props-guide))))]))]
+ (let-values ([(drivers guide) (parse-t #'t1 depth esc?)])
+ (values drivers (list-guide '_ guide))))]))]
[(quasitemplate t1)
;; quasitemplate escapes inner unsyntaxes
(quasi)
(parameterize ((quasi (list (quasi))))
- (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
- (wrap-props t
- drivers
- (list-guide '_ guide)
- (list-guide '_ props-guide))))]
+ (let-values ([(drivers guide) (parse-t #'t1 depth esc?)])
+ (values drivers (list-guide '_ guide))))]
[(DOTS template)
(and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
- (let-values ([(drivers guide props-guide) (parse-t #'template depth #t)])
- (values drivers (vector 'escaped guide)
- (list-guide '_ props-guide)))]
+ (let-values ([(drivers guide) (parse-t #'template depth #t)])
+ (values drivers (vector 'escaped guide)))]
[(?? t1 t2)
(not esc?)
- (let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)]
- [(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)])
- (values (dset-union drivers1 drivers2)
- (vector 'orelse guide1 guide2)
- (list-guide '_ props-guide1 props-guide2)))]
+ (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)]
+ [(drivers2 guide2) (parse-t #'t2 depth esc?)])
+ (values (dset-union drivers1 drivers2) (vector 'orelse guide1 guide2)))]
[(head DOTS . tail)
(and (not esc?)
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
@@ -518,9 +430,9 @@ instead of integers and integer vectors.
(and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
(loop (add1 nesting) #'tail)]
[else (values nesting tail)]))])
- (let-values ([(hdrivers _hsplice? hguide hprops-guide)
+ (let-values ([(hdrivers _hsplice? hguide)
(parse-h #'head (+ depth nesting) esc?)]
- [(tdrivers tguide tprops-guide)
+ [(tdrivers tguide)
(parse-t tail depth esc?)])
(when (dset-empty? hdrivers)
(wrong-syntax #'head "no pattern variables before ellipsis in template"))
@@ -530,78 +442,65 @@ instead of integers and integer vectors.
;; select the nestingth (last) ellipsis as the bad one
(stx-car (stx-drop nesting t))])
(wrong-syntax bad-dots "too many ellipses in template")))
- (wrap-props t
- (dset-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)])
- (dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
- [new-hdrivers/level
- (let loop ([raw hdrivers/level] [last (dset)])
- (cond [(null? raw) null]
- [else
- (cons (dset-subtract (car raw) last)
- (loop (cdr raw) (car raw)))]))])
- (vector 'dots hguide new-hdrivers/level nesting #f tguide))
- (cons-guide hprops-guide (cons-guide '_ tprops-guide)))))]
+ (values (dset-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)])
+ (dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
+ [new-hdrivers/level
+ (let loop ([raw hdrivers/level] [last (dset)])
+ (cond [(null? raw) null]
+ [else
+ (cons (dset-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 hprops-guide)
+ (let-values ([(hdrivers hsplice? hguide)
(parse-h #'head depth esc?)]
- [(tdrivers tguide tprops-guide)
+ [(tdrivers tguide)
(parse-t #'tail depth esc?)])
- (wrap-props t
- (dset-union hdrivers tdrivers)
- (cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
- [hsplice? (vector 'app hguide tguide)]
- [else (cons hguide tguide)])
- (cons-guide hprops-guide tprops-guide)))]
+ (values (dset-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 props-guide)
+ (let-values ([(drivers guide)
(parse-t (vector->list (syntax-e #'vec)) depth esc?)])
- (wrap-props t drivers
- (if (eq? guide '_) '_ (vector 'vector guide))
- (if (eq? props-guide '_) '_ (vector 'vector props-guide))))]
+ (values drivers (if (eq? guide '_) '_ (vector 'vector guide))))]
[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?)])
- (wrap-props t drivers
- (if (eq? guide '_) '_ (vector 'struct guide))
- (if (eq? props-guide '_) '_ (vector 'struct props-guide))))]
+ (values drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
[#&template
- (let-values ([(drivers guide props-guide)
+ (let-values ([(drivers guide)
(parse-t #'template depth esc?)])
- (wrap-props t drivers
- (if (eq? guide '_) '_ (vector 'box guide))
- (if (eq? props-guide '_) '_ (vector 'box props-guide))))]
+ (values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
[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?)
(syntax-case h (?? ?@ unsyntax-splicing)
[(?? t)
(not esc?)
- (let-values ([(drivers splice? guide props-guide)
+ (let-values ([(drivers splice? guide)
(parse-h #'t depth esc?)])
- (values drivers #t
- (vector 'app-opt guide)
- (list-guide '_ props-guide)))]
+ (values drivers #t (vector 'app-opt guide)))]
[(?? t1 t2)
(not esc?)
- (let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)]
- [(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)])
+ (let-values ([(drivers1 splice?1 guide1) (parse-h #'t1 depth esc?)]
+ [(drivers2 splice?2 guide2) (parse-h #'t2 depth esc?)])
(values (dset-union drivers1 drivers2)
(or splice?1 splice?2)
(vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
- guide1 guide2)
- (list-guide '_ props-guide1 props-guide2)))]
+ guide1 guide2)))]
[(?@ . t)
(not esc?)
- (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
- (values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))]
+ (let-values ([(drivers guide) (parse-t #'t depth esc?)])
+ (values drivers #t (vector 'splice guide)))]
[(unsyntax-splicing t1)
(quasi)
(let ([qval (quasi)])
@@ -610,19 +509,15 @@ instead of integers and integer vectors.
(set-box! qval (cons (cons #'tmp h) (unbox qval)))
(let* ([fake-sm (make-auto-pvar 0 #'tmp)]
[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
(parameterize ((quasi (car qval)))
- (let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]
- [(drivers guide props-guide)
- (wrap-props h
- drivers
- (list-guide '_ guide)
- (list-guide '_ props-guide))])
- (values drivers #f guide props-guide)))]))]
+ (let*-values ([(drivers guide) (parse-t #'t1 depth esc?)]
+ [(drivers guide) (values drivers (list-guide '_ guide))])
+ (values drivers #f guide)))]))]
[t
- (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
- (values drivers #f guide props-guide))]))
+ (let-values ([(drivers guide) (parse-t #'t depth esc?)])
+ (values drivers #f guide))]))
(define (lookup id depth)
(let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v)
diff --git a/pkgs/racket-test/tests/stxparse/test-template-save-props.rkt b/pkgs/racket-test/tests/stxparse/test-template-save-props.rkt
@@ -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)
-\ No newline at end of file
diff --git a/pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt b/pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt
@@ -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
-\ No newline at end of file
