From 224f9fa3a76371ea1d02ee4d9c4c2c4973af913e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Apr 2009 20:31:07 +0000 Subject: [PATCH] fix bug in tracking paren shapes; fix Scribble binding search code; add syntax/template library svn: r14661 --- collects/rnrs/syntax-case-6.ss | 237 +++--------------- collects/scheme/private/sc.ss | 50 ++-- collects/scheme/private/stxcase-scheme.ss | 3 +- collects/scheme/private/stxcase.ss | 5 +- collects/scheme/private/stxloc.ss | 2 +- collects/scribble/search.ss | 14 +- .../scribblings/reference/stx-patterns.scrbl | 13 + collects/stxclass/private/runtime.ss | 2 +- collects/syntax/private/template-runtime.ss | 83 ++++++ collects/syntax/scribblings/template.scrbl | 99 ++++++++ .../scribblings/transformer-helpers.scrbl | 1 + collects/syntax/template.ss | 189 ++++++++++++++ 12 files changed, 470 insertions(+), 228 deletions(-) create mode 100644 collects/syntax/private/template-runtime.ss create mode 100644 collects/syntax/scribblings/template.scrbl create mode 100644 collects/syntax/template.ss diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss index f445aaabf6..6404d5bb5b 100644 --- a/collects/rnrs/syntax-case-6.ss +++ b/collects/rnrs/syntax-case-6.ss @@ -2,10 +2,10 @@ (require (for-syntax scheme/base) r6rs/private/qq-gen - scheme/stxparam scheme/mpair r6rs/private/exns - (for-syntax r6rs/private/check-pattern)) + (for-syntax syntax/template + r6rs/private/check-pattern)) (provide make-variable-transformer (rename-out [r6rs:syntax-case syntax-case] @@ -138,35 +138,6 @@ ;; Also, R6RS doesn't have (... ) quoting in patterns --- only ;; in templates. <<<< FIXME -(define-syntax-parameter pattern-vars null) - -(provide pattern-vars) - -(define-for-syntax (add-pattern-vars ids) - (append (syntax->list ids) - (syntax-parameter-value (quote-syntax pattern-vars)))) - -;; ---------------------------------------- - -(define-for-syntax (extract-pattern-ids stx lits) - (syntax-case stx () - [(a . b) (append (extract-pattern-ids #'a lits) - (extract-pattern-ids #'b lits))] - [#(a ...) (apply append - (map (lambda (a) - (extract-pattern-ids a lits)) - (syntax->list #'(a ...))))] - [a - (identifier? #'a) - (if (or (ormap (lambda (lit) - (free-identifier=? lit #'a)) - lits) - (free-identifier=? #'a #'(... ...)) - (free-identifier=? #'a #'_)) - null - (list #'a))] - [_ null])) - (define-syntax (r6rs:syntax-case stx) (syntax-case stx () [(_ expr (lit ...) clause ...) @@ -194,186 +165,58 @@ . #,(map (lambda (clause) (syntax-case clause () [(pat val) - (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)]) + (begin ((check-pat-ellipses stx) #'pat) - #`(pat (syntax-parameterize ([pattern-vars - (add-pattern-vars #'pat-ids)]) - val)))] + #`(pat val))] [(pat fender val) - (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)]) + (begin ((check-pat-ellipses stx) #'pat) - #`(pat (syntax-parameterize ([pattern-vars - (add-pattern-vars #'pat-ids)]) - fender) - (syntax-parameterize ([pattern-vars - (add-pattern-vars #'pat-ids)]) - val)))] + #`(pat fender val))] [else clause])) (syntax->list #'(clause ...))))))] [(_ . rest) (syntax/loc stx (syntax-case . rest))])) ;; ---------------------------------------- -(define-for-syntax (make-unwrap-map tmpl pattern-vars) - (let loop ([tmpl tmpl] - [in-ellipses? #f] - [counting? #f]) - (syntax-case tmpl () - [(ellipses expr) - (and (not in-ellipses?) - (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - (loop #'expr #t #f)] - [(expr ellipses . rest) - (and (not in-ellipses?) - (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - (box (cons (loop #'expr #f #f) - (let rloop ([rest #'rest]) - (syntax-case rest () - [(ellipses . rest) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - ;; keep going: - (rloop #'rest)] - [else (loop rest #f #t)]))))] - [(a . b) (let ([a (loop #'a in-ellipses? #f)] - [b (loop #'b in-ellipses? counting?)]) - (if (or a b counting?) - (cons a b) - #f))] - [#(a ...) (let ([as (loop (syntax->list #'(a ...)) - in-ellipses? - #f)]) - (and as (vector as)))] - [a - (identifier? #'a) - (ormap (lambda (pat-var) - (free-identifier=? #'a pat-var)) - pattern-vars)] - [_ #f]))) +(define (unwrap-reconstructed data stx datum) + datum) -(define-for-syntax (group-ellipses tmpl umap) - (define (stx-cdr s) (if (syntax? s) (cdr (syntax-e s)) (cdr s))) - (let loop ([tmpl tmpl][umap umap]) - (if (not umap) - tmpl - (syntax-case tmpl () - [(ellipses expr) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - tmpl] - [(expr ellipses . rest) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - (let rloop ([rest (stx-cdr (stx-cdr tmpl))] - [accum (list #'ellipses (loop #'expr - (car (unbox umap))))]) - (syntax-case rest () - [(ellipses . _) - (and (identifier? #'ellipses) - (free-identifier=? #'ellipses #'(... ...))) - ;; keep going: - (rloop (stx-cdr rest) (cons #'ellipses accum))] - [_ (cons (datum->syntax #f (reverse accum)) - (loop rest (cdr (unbox umap))))]))] - [(a . b) (let ([n (cons (loop #'a (car umap)) - (loop (cdr (if (syntax? tmpl) - (syntax-e tmpl) - tmpl)) - (cdr umap)))]) - (if (syntax? tmpl) - (datum->syntax tmpl n tmpl tmpl tmpl) - n))] - [#(a ...) (datum->syntax - tmpl - (list->vector (loop (syntax->list #'(a ...)) - (vector-ref umap 0))) - tmpl - tmpl - tmpl)] - [_ tmpl])))) +(define (unwrap-pvar data stx) + ;; unwrap based on srcloc: + (let loop ([v stx]) + (cond + [(syntax? v) + (if (eq? (syntax-source v) unwrapped-tag) + (loop (syntax-e v)) + v)] + [(pair? v) (mcons (loop (car v)) + (loop (cdr v)))] + [(vector? v) (list->vector + (map loop (vector->list v)))] + [else v]))) -(define (unwrap stx mapping) - (cond - [(not mapping) - ;; In case stx is a pair, explicitly convert - (datum->syntax #f (convert-mpairs stx))] - [(eq? mapping #t) - ;; was a pattern var; unwrap based on srcloc: - (let loop ([v stx]) - (cond - [(syntax? v) - (if (eq? (syntax-source v) unwrapped-tag) - (loop (syntax-e v)) - v)] - [(pair? v) (mcons (loop (car v)) - (loop (cdr v)))] - [(vector? v) (list->vector - (map loop (vector->list v)))] - [else v]))] - [(pair? mapping) - (let ([p (if (syntax? stx) - (syntax-e stx) - stx)]) - (mcons (unwrap (car p) (car mapping)) - (unwrap (cdr p) (cdr mapping))))] - [(vector? mapping) - (list->vector (let loop ([v (unwrap (vector->list (syntax-e stx)) - (vector-ref mapping 0))]) - (cond - [(null? v) null] - [(mpair? v) (cons (mcar v) (loop (mcdr v)))] - [(syntax? v) (syntax->list v)])))] - [(null? mapping) null] - [(box? mapping) - ;; ellipses - (let* ([mapping (unbox mapping)] - [rest-mapping (cdr mapping)] - [p (if (syntax? stx) (syntax-e stx) stx)] - [repeat-stx (car p)] - [rest-stx (cdr p)]) - (let ([repeats (list->mlist - (map (lambda (rep) - (unwrap rep (car mapping))) - (syntax->list repeat-stx)))] - [rest-mapping - ;; collapse #fs to single #f: - (if (let loop ([rest-mapping rest-mapping]) - (if (pair? rest-mapping) - (if (not (car rest-mapping)) - (loop (cdr rest-mapping)) - #f) - (not rest-mapping))) - #f - rest-mapping)]) - - (if (and (not rest-mapping) - (or (null? rest-stx) - (and (syntax? rest-stx) - (null? (syntax-e rest-stx))))) - repeats - (mappend repeats - (unwrap rest-stx rest-mapping)))))] - [else (error 'unwrap "strange unwrap mapping: ~e" mapping)])) +(define (leaf-to-syntax datum) + (datum->syntax #f datum)) + +(define (ellipses-end stx) + ;; R6RS says that (x ...) must be a list, so we need a special rule + (if (and (syntax? stx) (null? (syntax-e stx))) + null + stx)) + +(define-for-syntax (no-data x) #f) (define-syntax (r6rs:syntax stx) (syntax-case stx () - [(_ tmpl) - (let ([umap (make-unwrap-map #'tmpl - (syntax-parameter-value #'pattern-vars))]) - (quasisyntax/loc stx - (unwrap (if #f - ;; Process tmpl first, so that syntax errors are reported - ;; usinf the original source. - #,(syntax/loc stx (syntax tmpl)) - ;; Convert tmpl to group ...-created repetitions together, - ;; so that `unwrap' can tell which result came from which - ;; template: - #,(with-syntax ([tmpl (group-ellipses #'tmpl umap)]) - (syntax/loc stx (syntax tmpl)))) - '#,umap)))] - [(_ . rest) (syntax/loc stx (syntax . rest))])) + [(_ template) + (transform-template #'template + #:constant-as-leaf? #t + #:save (lambda (x) #f) + #:restore-stx #'unwrap-reconstructed + #:leaf-datum-stx #'leaf-to-syntax + #:pvar-restore-stx #'unwrap-pvar + #:cons-stx #'mcons + #:ellipses-end-stx #'ellipses-end)])) ;; ---------------------------------------- diff --git a/collects/scheme/private/sc.ss b/collects/scheme/private/sc.ss index 10f2a8b788..04ba3b1dff 100644 --- a/collects/scheme/private/sc.ss +++ b/collects/scheme/private/sc.ss @@ -507,7 +507,7 @@ (set! cnt (add1 cnt)) (string->symbol (format "~a~a" prefix cnt))))) ;; The pattern expander: - (-define (expander p proto-r local-top use-ellipses? use-tail-pos hash!) + (-define (expander p proto-r local-top use-ellipses? use-tail-pos hash! need-list?) (cond [(and use-ellipses? (ellipsis? p)) (let*-values ([(p-head) (stx-car p)] @@ -559,8 +559,9 @@ (pick-specificity top last-el))))] - [rest (expander rest-p proto-r local-top #t use-tail-pos hash!)] - [ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash!)]) + [rest (expander rest-p proto-r local-top #t use-tail-pos hash! need-list?)] + [ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash! + (or need-list? (positive? el-count)))]) (if proto-r `(lambda (r) ,(let ([pre (let ([deeps @@ -597,10 +598,11 @@ (sub1 el-count))))]) (wrap `(map - (lambda vals (,ehead - ,(if (null? proto-rr-shallow) - 'vals - '(append shallows vals)))) + (lambda vals + (,ehead + ,(if (null? proto-rr-shallow) + 'vals + '(append shallows vals)))) ,@valses) el-count))]))]) (if (null? proto-rr-shallow) @@ -611,9 +613,17 @@ proto-rr-shallow))]) ,deeps)))] [post (apply-to-r rest)]) - (if (eq? post 'null) - pre - `(append ,pre ,post)))) + (let ([v (if (eq? post 'null) + pre + `(append ,pre ,post))]) + (if (and (not need-list?) (syntax? p)) + ;; Keep srcloc, properties, etc.: + (let ([small-dest (datum->syntax p + 'dest + p + p)]) + `(datum->syntax/shape (quote-syntax ,small-dest) ,v)) + v)))) ;; variables were hashed (void))))] [(stx-pair? p) @@ -623,21 +633,21 @@ (if (and (stx-pair? (stx-cdr p)) (stx-null? (stx-cdr (stx-cdr p)))) (let ([dp (stx-car (stx-cdr p))]) - (expander dp proto-r dp #f use-tail-pos hash!)) + (expander dp proto-r dp #f use-tail-pos hash! need-list?)) (raise-syntax-error 'syntax "misplaced ellipses in template" top hd)) - (let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash!)] - [etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash!)]) + (let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash! #f)] + [etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash! need-list?)]) (if proto-r `(lambda (r) ,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym)) ;; variables were hashed (void)))))] [(stx-vector? p #f) - (let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash!)]) + (let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) (if proto-r `(lambda (r) (list->vector (stx->list ,(apply-to-r e)))) @@ -646,7 +656,7 @@ [(and (syntax? p) (struct? (syntax-e p)) (prefab-struct-key (syntax-e p))) - (let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash!)]) + (let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash! #t)]) (if proto-r `(lambda (r) (apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) (stx->list ,(apply-to-r e)))) @@ -697,7 +707,8 @@ l))]) (if pr (set-mcdr! pr (cons r (mcdr pr))) - (hash-set! ht (syntax-e r) (cons (mcons r (list r)) l))))))))]) + (hash-set! ht (syntax-e r) (cons (mcons r (list r)) l))))))) + #f)]) (if proto-r `(lambda (r) ,(let ([main (let ([build (apply-to-r l)]) @@ -808,9 +819,10 @@ `(pattern-substitute (quote-syntax ())) p sub-gensym)] + [(and (pair? t) (eq? (car t) 'quote-syntax) - (stx-smaller-than? (car t) 10)) + (stx-smaller-than? (cdr t) 10)) ;; Shift into `pattern-substitute' mode with an intitial constant. ;; (Only do this for small constants, so we don't traverse ;; big constants when looking for substitutions.) @@ -1028,7 +1040,7 @@ (stx-car stx))))))) (-define (make-syntax-mapping depth valvar) (make-set!-transformer (-make-syntax-mapping depth valvar))) - (-define (syntax-mapping? v) + (-define (syntax-pattern-variable? v) (and (set!-transformer? v) (-syntax-mapping? (set!-transformer-procedure v)))) (-define (syntax-mapping-depth v) @@ -1038,6 +1050,6 @@ (#%provide (protect make-match&env get-match-vars make-interp-match make-pexpand - make-syntax-mapping syntax-mapping? + make-syntax-mapping syntax-pattern-variable? syntax-mapping-depth syntax-mapping-valvar stx-memq-pos no-ellipses?))) diff --git a/collects/scheme/private/stxcase-scheme.ss b/collects/scheme/private/stxcase-scheme.ss index a091315538..53eb04f0f1 100644 --- a/collects/scheme/private/stxcase-scheme.ss +++ b/collects/scheme/private/stxcase-scheme.ss @@ -60,4 +60,5 @@ (#%provide syntax (all-from "with-stx.ss") (all-from "stxloc.ss") check-duplicate-identifier - syntax-rules syntax-id-rules)) + syntax-rules syntax-id-rules + (for-syntax syntax-pattern-variable?))) diff --git a/collects/scheme/private/stxcase.ss b/collects/scheme/private/stxcase.ss index f6261c0e16..39008d7bd7 100644 --- a/collects/scheme/private/stxcase.ss +++ b/collects/scheme/private/stxcase.ss @@ -491,7 +491,7 @@ (map (lambda (var) (and (let ([v (syntax-local-value var (lambda () #f))]) - (and (syntax-mapping? v) + (and (syntax-pattern-variable? v) v)))) unique-vars)]) (if (and (or (null? var-bindings) @@ -556,4 +556,5 @@ (cons (quote-syntax list*) r)])))))))))) x))) - (#%provide (all-from "ellipses.ss") syntax-case** syntax)) + (#%provide (all-from "ellipses.ss") syntax-case** syntax + (for-syntax syntax-pattern-variable?))) diff --git a/collects/scheme/private/stxloc.ss b/collects/scheme/private/stxloc.ss index 35ccaae5a7..a4b51be4ce 100644 --- a/collects/scheme/private/stxloc.ss +++ b/collects/scheme/private/stxloc.ss @@ -38,7 +38,7 @@ (syntax-case** #f #t stx () free-identifier=? [(_ loc pattern) (if (if (symbol? (syntax-e #'pattern)) - (syntax-mapping? (syntax-local-value #'pattern (lambda () #f))) + (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) #f) (syntax (syntax pattern)) (syntax (relocate loc (syntax pattern))))]))) diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss index 1186ed6305..86321b198a 100644 --- a/collects/scribble/search.ss +++ b/collects/scribble/search.ss @@ -56,7 +56,7 @@ (cadddr (cdr stx/binding)))))])]) (and (pair? b) - (let ([seen (make-hasheq)] + (let ([seen (make-hash)] [search-key #f]) (let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))] [rqueue null] @@ -99,7 +99,7 @@ (loop queue rqueue need-result?) ;; Check parents, if we can get the source: (if (and (path? (resolved-module-path-name rmp)) - (not (hash-ref seen rmp #f))) + (not (hash-ref seen (cons export-phase rmp) #f))) (let ([exports (hash-ref module-info-cache @@ -130,7 +130,7 @@ (cdr stxess))]))]) (hash-set! module-info-cache rmp t) t))))]) - (hash-set! seen rmp #t) + (hash-set! seen (cons export-phase rmp) #t) (let ([a (assq id (let ([a (assoc export-phase exports)]) (if a (cdr a) @@ -149,7 +149,7 @@ 0 0 0))) - (cadr a)) + (reverse (cadr a))) rqueue) need-result?) (begin @@ -158,9 +158,9 @@ ;; for now. #; (error 'find-scheme-tag - "dead end when looking for binding source: ~e" - id) - #f)))) + "dead end when looking for binding source: ~e" + id) + (loop queue rqueue need-result?))))) ;; Can't get the module source, so continue with queue: (loop queue rqueue need-result?)))]) (or here-result diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl index 92d2458771..0adbac5306 100644 --- a/collects/scribblings/reference/stx-patterns.scrbl +++ b/collects/scribblings/reference/stx-patterns.scrbl @@ -411,3 +411,16 @@ The @scheme[_] transformer binding prohibits @scheme[_] from being used as an expression. This binding useful only in syntax patterns, where it indicates a pattern that matches any syntax object. See @scheme[syntax-case].} + + +@defproc[(syntax-pattern-variable? [v any/c]) boolean?]{ + +Return @scheme[#t] if @scheme[v] is a value that, as a +transformer-binding value, makes the bound variable as pattern +variable in @scheme[syntax] and other forms. To check whether an +identifier is a pattern variable, use @scheme[syntax-local-value] to +get the identifier's transformer value, and then test the value with +@scheme[syntax-pattern-variable?]. + +The @scheme[syntax-pattern-variable?] procedure is provided +@scheme[for-syntax] by @schememodname[scheme/base].} diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index ba9ecebdee..be748fd4f2 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -299,7 +299,7 @@ [(attribute name) (identifier? #'name) (let ([mapping (syntax-local-value #'name (lambda () #f))]) - (unless (syntax-mapping? mapping) + (unless (syntax-pattern-variable? mapping) (wrong-syntax #'name "not bound as a pattern variable")) (let ([var (syntax-mapping-valvar mapping)]) (let ([attr (syntax-local-value var (lambda () #f))]) diff --git a/collects/syntax/private/template-runtime.ss b/collects/syntax/private/template-runtime.ss new file mode 100644 index 0000000000..809aa5e125 --- /dev/null +++ b/collects/syntax/private/template-runtime.ss @@ -0,0 +1,83 @@ +#lang scheme/base +(require "../stx.ss") + +(provide template-map-apply) + +(define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes) +(define-struct prefab (key fields) #:prefab #:omit-define-syntaxes) + +(define (stx-list->vector l) + (list->vector + (if (list? l) + l + (let loop ([l l]) + (cond + [(null? l) null] + [(pair? l) (cons (car l) (loop (cdr l)))] + [(syntax? l) (loop (syntax-e l))]))))) + +(define (template-map-apply tmap d->s leaf->s leaf-datum pvar->s pcons ellipses-end data stx) + (let loop ([tmap tmap][data data][stx stx][local-pcons pcons]) + (cond + [(not tmap) (if (box? data) + (leaf->s (unbox data) stx) + (leaf-datum stx))] + [(eq? tmap #t) (pvar->s data stx)] + [(pair? tmap) + (let ([a (loop (car tmap) + (if (pair? data) (car data) (vector-ref data 1)) + (stx-car stx) + pcons)] + [b (loop (cdr tmap) + (if (pair? data) (cdr data) (vector-ref data 2)) + (stx-cdr stx) + local-pcons)]) + (if (vector? data) + (d->s + (vector-ref data 0) + stx + (pcons a b)) + (local-pcons a b)))] + [(vector? tmap) + (d->s (car data) + stx + (stx-list->vector + (loop (vector-ref tmap 0) + (cdr data) + (vector->list (syntax-e stx)) + cons)))] + [(box? tmap) + (d->s (car data) + stx + (box + (loop (unbox tmap) + (cdr data) + (unbox (syntax-e stx)) + pcons)))] + [(ellipses? tmap) + (let ([prefix (map (lambda (e) + (loop (ellipses-elem tmap) + (if (pair? data) (car data) (vector-ref data 1)) + e + local-pcons)) + (syntax->list (stx-car stx)))] + [rest (loop (ellipses-rest tmap) + (if (pair? data) (cdr data) (vector-ref data 2)) + (stx-cdr stx) + local-pcons)]) + (let ([appended (let loop ([prefix prefix]) + (if (null? prefix) + (ellipses-end rest) + (local-pcons (car prefix) (loop (cdr prefix)))))]) + (if (vector? data) + (d->s (vector-ref data 0) + stx + appended) + appended)))] + [(prefab? tmap) + (d->s (car data) + stx + (loop (prefab-fields tmap) + (cdr data) + (cdr (vector->list (struct->vector (syntax-e stx))))))] + [else (error "template-map-apply fallthrough")]))) diff --git a/collects/syntax/scribblings/template.scrbl b/collects/syntax/scribblings/template.scrbl new file mode 100644 index 0000000000..832354b8b0 --- /dev/null +++ b/collects/syntax/scribblings/template.scrbl @@ -0,0 +1,99 @@ +#lang scribble/doc +@(require "common.ss" + (for-label syntax/template)) + +@title[#:tag "template"]{Controlling Syntax Templates} + +@defmodule[syntax/template] + +@defproc[(transform-template [template-stx syntax?] + [#:save save-proc (syntax? . -> . any/c)] + [#:restore-stx restore-proc-stx syntax?] + [#:leaf-save leaf-save-proc (syntax? . -> . any/c) save-proc] + [#:leaf-restore-stx leaf-restore-proc-stx syntax? #'(lambda (data stx) stx)] + [#:leaf-datum-stx leaf-datum-proc-stx syntax? #'(lambda (v) v)] + [#:pvar-save pvar-save-proc (identifier? . -> . any/c) (lambda (x) #f)] + [#:pvar-restore-stx pvar-restore-stx syntax? #'(lambda (d stx) stx)] + [#:cons-stx cons-proc-stx syntax? cons] + [#:ellipses-end-stx ellipses-end-stx syntax? #'values] + [#:constant-as-leaf? constant-as-leaf? boolean? #f]) + syntax?]{ + +Produces an representation of an expression similar to +@SCHEME[#`((UNSYNTAX @scheme[syntax]) #,template-stx)], but functions like +@scheme[save-proc] can collect information that might otherwise be +lost by @scheme[syntax] (such as properties when the syntax object is +marshaled within bytecode), and run-time functions like the one +specified by @scheme[restore-proc-stx] can use the saved information or +otherwise process the syntax object that is generated by the template. + +The @scheme[save-proc] is applied to each syntax object in the +representation of the original template (i.e., in +@scheme[template-stx]). If @scheme[constant-as-leaf?] is @scheme[#t], +then @scheme[save-proc] is applied only to syntax objects that contain +at least one pattern variable in a sub-form. The result of +@scheme[save-proc] is provided back as the first argument to +@scheme[restore-proc-stx], which indicates a function with a contract +@scheme[(any/c syntax any/c . -> . any/c)]; the second argument to +@scheme[restore-proc-stx] is the syntax object that @scheme[syntax] +generates, and the last argument is a datum that have been processed +recursively (by functions such as @scheme[restore-proc-stx]) and that +normally would be converted back to a syntax object using the second +argument's context, source, and properties. Note that +@scheme[save-proc] works at expansion time (with respect to the +template form), while @scheme[restore-proc-stx] indicates a function +that is called at run time (for the template form), and the data that +flows from @scheme[save-proc] to @scheme[restore-proc-stx] crosses +phases via @scheme[quote]. + +The @scheme[leaf-save-proc] and @scheme[leaf-restore-proc-stx] procedures +are analogous to @scheme[save-proc] and +@scheme[restore-proc-stx], but they are applied to leaves, so +there is no third argument for recursively processed sub-forms. The +function indicated by @scheme[leaf-restore-proc-stx] should have the +contract @scheme[(any/c syntax? . -> . any/c)]. + +The @scheme[leaf-datum-proc-stx] procedure is applied to leaves that +are not syntax objects, which can happen because pairs and the empty +list are not always individually wrapped as syntax objects. The +function should have the contract @scheme[(any/c . -> . any/c)]. When +@scheme[constant-as-leaf?] is @scheme[#f], the only possible argument +to the procedure is @scheme[null]. + +The @scheme[pvar-save] and @scheme[pvar-restore-stx] procedures are +analogous to @scheme[save-proc] and @scheme[restore-proc-stx], +but they are applied to pattern variables. The +@scheme[pvar-restore-stx] procedure should have the contract +@scheme[(any/c syntax? . -> . any/c)], where the second argument +corresponds to the substitution of the pattern variable. + +The @scheme[cons-proc-stx] procedure is used to build intermediate +pairs, including pairs passed to @scheme[restore-proc-stx] and pairs +that do not correspond to syntax objects. + +The @scheme[ellipses-end-stx] procedure is an extra filter on the +syntax object that follows a sequence of @scheme[...] ellipses in the +template. The procedure should have the contract @scheme[(any/c . -> +. any/c)]. + +The following example illustrates a use of @scheme[transform-template] +to implement a @scheme[syntax/shape] form that preserves the +@scheme['paren-shape] property from the original template, even if the +template code is marshaled within bytecode. + +@schemeblock[ +(define-for-syntax (get-shape-prop stx) + (syntax-property stx 'paren-shape)) + +(define (add-shape-prop v stx datum) + (syntax-property (datum->syntax stx datum stx stx stx) + 'paren-shape + v)) + +(define-syntax (syntax/shape stx) + (syntax-case stx () + [(_ tmpl) + (transform-template #'tmpl + #:save get-shape-prop + #:restore-stx #'add-shape-prop)])) +]} diff --git a/collects/syntax/scribblings/transformer-helpers.scrbl b/collects/syntax/scribblings/transformer-helpers.scrbl index 951c202743..0b8957186c 100644 --- a/collects/syntax/scribblings/transformer-helpers.scrbl +++ b/collects/syntax/scribblings/transformer-helpers.scrbl @@ -9,3 +9,4 @@ @include-section["flatten-begin.scrbl"] @include-section["struct.scrbl"] @include-section["path-spec.scrbl"] +@include-section["template.scrbl"] diff --git a/collects/syntax/template.ss b/collects/syntax/template.ss new file mode 100644 index 0000000000..bb35a5ccfd --- /dev/null +++ b/collects/syntax/template.ss @@ -0,0 +1,189 @@ +#lang scheme/base +(require "stx.ss" + (for-template scheme/base + "private/template-runtime.ss")) + +(provide transform-template) + +;; A template map descibres the structure of a template +;; in terms of where pattern variables are replaced. +;; +;; Walk a map and a template in parallel, and you see +;; these map cases: +;; +;; - #f => corresponding template portion is constant +;; - #t => corresponding template portion is a pattern variable +;; - (cons map1 map2) => template part is a pair +;; which substitutions in one side +;; or the other +;; - (vector map) => template portion is a vector, +;; contents like the list in map +;; - (box map) => template portion is a box with substition +;; - #s(ellipses count map) => template portion is an ellipses-generated list +;; - #s(prefab v map) => templat portion is a prefab + +(define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes) +(define-struct prefab (key fields) #:prefab #:omit-define-syntaxes) + +(define (datum->syntax* stx d) + (datum->syntax stx d stx stx stx)) + +(define (make-template-map tmpl const-leaf?) + (let loop ([tmpl tmpl] + [in-ellipses? #f]) + (syntax-case tmpl () + [(ellipses expr) + (and (not in-ellipses?) + (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + (loop #'expr #t)] + [(expr ellipses . rest) + (and (not in-ellipses?) + (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + (let-values ([(elem) (loop #'expr #f)] + [(rest count) + (let rloop ([rest #'rest][count 1]) + (syntax-case rest () + [(ellipses . rest) + (and (identifier? #'ellipses) + (free-identifier=? #'ellipses #'(... ...))) + ;; keep going: + (rloop #'rest (add1 count))] + [else (values (loop rest #f) count)]))]) + (make-ellipses elem count rest))] + [(a . b) (let ([a (loop #'a in-ellipses?)] + [b (loop #'b in-ellipses?)]) + (and (or a b (not const-leaf?)) + (cons a b)))] + [#(a ...) (let ([as (loop (syntax->list #'(a ...)) + in-ellipses?)]) + (and (or as (not const-leaf?)) + (vector as)))] + [#&(a) (let ([as (loop #'a in-ellipses?)]) + (and (or as (not const-leaf?)) + (box as)))] + [a + (identifier? #'a) + (syntax-pattern-variable? (syntax-local-value #'a (lambda () #f)))] + [_ + (let ([k (prefab-struct-key (syntax-e tmpl))]) + (and k + (let ([as (loop (cdr (vector->list (struct->vector (syntax-e tmpl))) in-ellipses?))]) + (and (or as (not const-leaf?)) + (make-prefab k as)) + #f)))]))) + +(define (template-map-collect tmap template s->d leaf->d pvar->d) + (let loop ([tmap tmap][template template]) + (cond + [(not tmap) (if (syntax? template) + (box (leaf->d template)) + #f)] + [(eq? tmap #t) (pvar->d template)] + [(pair? tmap) + (if (syntax? template) + (vector (s->d template) + (loop (car tmap) (stx-car template)) + (loop (cdr tmap) (stx-cdr template))) + (cons (loop (car tmap) (stx-car template)) + (loop (cdr tmap) (stx-cdr template))))] + [(vector? tmap) + (cons (s->d template) + (loop (vector-ref tmap 0) + (vector->list (syntax-e template))))] + [(box? tmap) + (cons (s->d template) + (loop (unbox tmap) + (syntax-e template)))] + [(ellipses? tmap) + (let ([rest (let loop ([rest (stx-cdr template)] + [count (ellipses-count tmap)]) + (if (zero? count) + rest + (loop (stx-cdr rest) (sub1 count))))]) + (if (syntax? template) + (vector (s->d template) + (loop (ellipses-elem tmap) (stx-car template)) + (loop (ellipses-rest tmap) rest)) + (cons (loop (ellipses-elem tmap) (stx-car template)) + (loop (ellipses-rest tmap) rest))))] + [(prefab? tmap) + (cons (s->d template) + (loop (prefab-fields tmap) + (cdr (vector->list (struct->vector (syntax-e template))))))] + [else (error "template-map-collect fall-through")]))) + +(define (group-ellipses tmap template) + (let loop ([tmap tmap][template template]) + (cond + [(boolean? tmap) template] + [(pair? tmap) + (let ([p (cons (loop (car tmap) (stx-car template)) + (loop (cdr tmap) (stx-cdr template)))]) + (if (syntax? template) + (datum->syntax* template p) + p))] + [(vector? tmap) + (datum->syntax* template + (list->vector + (loop (vector-ref tmap 0) + (vector->list (syntax-e template)))))] + [(box? tmap) + (datum->syntax* template + (box + (loop (unbox tmap) + (syntax-e template))))] + [(ellipses? tmap) + (let ([rest + (loop (ellipses-rest tmap) + (let loop ([rest (stx-cdr template)] + [count (ellipses-count tmap)]) + (if (zero? count) + rest + (loop (stx-cdr rest) (sub1 count)))))] + [elem (loop (ellipses-elem tmap) (stx-car template))]) + (let ([new `((,elem ,@(for/list ([i (in-range (ellipses-count tmap))]) + #'(... ...))) + . ,rest)]) + (if (syntax? template) + (datum->syntax* template new) + new)))] + [(prefab? tmap) + (datum->syntax* + template + (apply + make-prefab-struct + (prefab-key tmap) + (loop (prefab-fields tmap) + (cdr (vector->list (struct->vector (syntax-e template)))))))] + [else (error "group-ellipses fall-through")]))) + +(define (transform-template template-stx + #:save s->d + #:restore-stx d->s + #:leaf-save [leaf->d s->d] + #:leaf-restore-stx [leaf->s #'(lambda (data stx) stx)] + #:leaf-datum-stx [leaf-datum #'values] + #:pvar-save [pvar->d (lambda (x) #f)] + #:pvar-restore-stx [pvar->s #'(lambda (d s) s)] + #:cons-stx [pcons cons] + #:ellipses-end-stx [ellipses-end #'values] + #:constant-as-leaf? [const-leaf? #f]) + (let* ([tmap (make-template-map template-stx const-leaf?)] + [grouped-template + ;; Convert tmpl to group ...-created repetitions together, + ;; so that `unwrap' can tell which result came from which + ;; template: + (group-ellipses tmap template-stx)] + [data (template-map-collect tmap template-stx + s->d leaf->d pvar->d)]) + #`(if #f + ;; Process tmpl first, so that syntax errors are reported + ;; usinf the original source. + (syntax #,template-stx) + ;; Apply give d->s to result: + (template-map-apply '#,tmap + #,d->s #,leaf->s #,leaf-datum #,pvar->s #,pcons #,ellipses-end + '#,data + (syntax #,grouped-template)))))