diff --git a/pkgs/racket-test/tests/stxparse/test-template.rkt b/pkgs/racket-test/tests/stxparse/test-template.rkt index b6400e1a2f..ae83732121 100644 --- a/pkgs/racket-test/tests/stxparse/test-template.rkt +++ b/pkgs/racket-test/tests/stxparse/test-template.rkt @@ -246,8 +246,6 @@ (with-syntax ([(z ...) '()]) (tloc quasitemplate/loc (z ... . 2) #f)) ;; zero iters + syntax tail => no relocation (tloc quasitemplate/loc (#,'a) #t) -(tloc quasitemplate/loc #,'a #f) -(tloc quasitemplate/loc (#,@(list 1 2 3)) #t) ;; Lazy attribute tests from test.rkt diff --git a/racket/collects/racket/private/ellipses.rkt b/racket/collects/racket/private/ellipses.rkt index e8931fb735..3f8a750f7c 100644 --- a/racket/collects/racket/private/ellipses.rkt +++ b/racket/collects/racket/private/ellipses.rkt @@ -1,12 +1,17 @@ (module ellipses '#%kernel (#%require (for-syntax '#%kernel)) - (#%provide ... _) + (#%provide ... _ ?? ?@) (define-syntaxes (...) (lambda (stx) (raise-syntax-error #f "ellipses not allowed as an expression" stx))) + (define-syntaxes (??) + (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))) + (define-syntaxes (?@) + (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))) + (define-syntaxes (_) (lambda (stx) (raise-syntax-error #f "wildcard not allowed as an expression" stx)))) diff --git a/racket/collects/racket/private/qqstx.rkt b/racket/collects/racket/private/qqstx.rkt index df2229e075..9d9f10a32e 100644 --- a/racket/collects/racket/private/qqstx.rkt +++ b/racket/collects/racket/private/qqstx.rkt @@ -2,7 +2,7 @@ ;; #%qqstx : quasisyntax (module qqstx '#%kernel - (#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" + (#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" "template.rkt" (for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt")) (#%provide quasisyntax @@ -105,13 +105,11 @@ [ctx (datum->syntax #'x 'ctx #'x)]) (convert-k (datum->syntax stx - (list* (syntax temp) - (quote-syntax ...) - rest-v) + (cons #'(?@! . temp) rest-v) stx stx) (with-syntax ([check check-splicing-list-id]) - (cons #'[(temp (... ...)) (check x (quote-syntax ctx))] + (cons #'[temp (check x (quote-syntax ctx))] bindings)))))]) (loop (syntax rest) depth (lambda () diff --git a/racket/collects/racket/private/sc.rkt b/racket/collects/racket/private/sc.rkt index 7cd4d77a05..606ac5b5a9 100644 --- a/racket/collects/racket/private/sc.rkt +++ b/racket/collects/racket/private/sc.rkt @@ -494,451 +494,6 @@ `(cons/#f ,(cadr e1) ,e2) `(append/#f ,e1 ,e2))) - ;; ---------------------------------------------------------------------- - ;; Output generator - - ;; Takes a syntax pattern, an environment prototype, and - ;; a keyword symbol list, and produces an expander - ;; that takes an environment and produces syntax. - ;; - ;; If the environment prototype is #f, it produces a list of - ;; variables used in the pattern, instead. This is useful for - ;; determining what kind of environment (and prototype) to construct - ;; for the pattern. - ;; - ;; An environment for an expander is a list*; see the note above, - ;; under "Input Matcher", for details. - ;; - (-define (make-pexpand p proto-r k dest s-exp?) - (-define top p) - ;; Helper function: avoid generating completely new symbols - ;; for substitution. Instead, try to generate normal symbols - ;; with a standard prefix, so that the symbols can be shared. - (-define sub-gensym (let ([cnt 0] - [prefix (let pfx-loop ([pfx "_pat"]) - (if (let loop ([p p]) - (cond - [(symbol? p) - (let ([s (symbol->string p)]) - (and ((string-length s) . > . (string-length pfx)) - (string=? pfx (substring s 0 (string-length pfx)))))] - [(syntax? p) (loop (syntax-e p))] - [(pair? p) (or (loop (car p)) (loop (cdr p)))] - [(vector? p) (loop (vector->list p))] - [(box? p) (loop (unbox p))] - [(struct? p) (loop (struct->vector p))] - [else #f])) - (pfx-loop (string-append "_" pfx)) - pfx))]) - (lambda () - (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! need-list?) - (cond - [(and use-ellipses? (ellipsis? p)) - (let*-values ([(p-head) (stx-car p)] - [(el-count rest-p last-el) - (let loop ([p (stx-cdr (stx-cdr p))][el-count 0][last-el (stx-car (stx-cdr p))]) - (if (and (stx-pair? p) - (...? (stx-car p))) - (loop (stx-cdr p) (add1 el-count) (stx-car p)) - (values el-count p last-el)))] - [(p-head) (let loop ([el-count el-count]) - (if (zero? el-count) - p-head - (datum->syntax - #f - (list (loop (sub1 el-count)) (quote-syntax ...)))))] - [(nestings) (and proto-r (get-ellipsis-nestings p-head k))]) - (when (null? nestings) - (apply - raise-syntax-error - 'syntax - "no pattern variables before ellipsis in template" - (pick-specificity - top - last-el))) - (let* ([proto-rr+deep?s (and proto-r - (map (lambda (nesting) - (ellipsis-sub-env nesting proto-r top local-top)) - nestings))] - [proto-rr-deep (and proto-r - ;; the ones that we had to unwrap: - (let loop ([l proto-rr+deep?s]) - (cond - [(null? l) null] - [(cdar l) (loop (cdr l))] - [else (cons (caar l) (loop (cdr l)))])))] - [proto-rr-shallow (and proto-r - ;; the ones that we leave alone for these ellipsis: - (let loop ([l proto-rr+deep?s]) - (cond - [(null? l) null] - [(cdar l) (cons (caar l) (loop (cdr l)))] - [else (loop (cdr l))])))] - [__ (unless (null? proto-rr-shallow) - (when (null? proto-rr-deep) - (apply - raise-syntax-error - 'syntax - "too many ellipses in template" - (pick-specificity - top - last-el))))] - [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 - (let ([valses - ;; Generate one binding per nested use. This will duplicate - ;; bindings if a pattern variable is used multiple times; that's - ;; good if the uses are in different nesting levels (which could be - ;; ok if there are extra ellipses around them), but it might also - ;; create redundant entries. - (map (lambda (var) - (apply-list-ref 'r (stx-memq*-pos (list var) proto-r) use-tail-pos)) - proto-rr-deep)]) - (cond - [(and (= 1 (length valses)) - (= 0 el-count) - (null? proto-rr-shallow) - (equal? ehead '(lambda (r) (car r)))) - ;; Common case: one item in list, no map needed: - (car valses)] - [(and (= 2 (length valses)) - (= 0 el-count) - (null? proto-rr-shallow) - (equal? ehead '(lambda (r) (list (car r) (cadr r))))) - ;; Another common case: a maintained pair - `(map - (lambda (a b) (list a b)) - ,@valses)] - [else - ;; General case: - (letrec ([wrap (lambda (expr el-count) - (if (zero? el-count) - expr - (wrap `(apply append ,expr) - (sub1 el-count))))]) - (wrap - `(map - (lambda vals - (,ehead - ,(if (null? proto-rr-shallow) - 'vals - '(append shallows vals)))) - ,@valses) - el-count))]))]) - (if (null? proto-rr-shallow) - deeps - `(let ([shallows - (list ,@(map (lambda (var) - (apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos)) - proto-rr-shallow))]) - ,deeps)))] - [post (apply-to-r rest)]) - (let ([v (if (eq? post 'null) - pre - `(append ,pre ,post))]) - (if (and (not need-list?) (syntax? p) (not s-exp?)) - ;; 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) - (let ([hd (stx-car p)]) - (if (and use-ellipses? - (...? hd)) - (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! need-list?)) - (raise-syntax-error - 'syntax - "misplaced ellipsis in template" - top - hd)) - (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 s-exp?)) - ;; 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! #t)]) - (if proto-r - `(lambda (r) - (list->vector (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) - ;; variables were hashed - (void)))] - [(stx-box? p) - (let ([e (expander (unbox (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) - (if proto-r - `(lambda (r) - (box (,(if s-exp? 'values 'syntax-e) ,(apply-to-r e)))) - ;; variables were hashed - (void)))] - [(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! #t)]) - (if proto-r - `(lambda (r) - (apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) - (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) - ;; variables were hashed - (void)))] - [(identifier? p) - (if (stx-memq p k) - (if proto-r - `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)) - (void)) - (if proto-r - (let ((x (stx-memq p proto-r))) - (if x - `(lambda (r) ,(apply-list-ref 'r (stx-memq-pos p proto-r) use-tail-pos)) - (begin - (when (and use-ellipses? - (...? p)) - (raise-syntax-error - 'syntax - "misplaced ellipsis in template" - top - p)) - (check-not-pattern p proto-r) - `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))))) - (unless (and (...? p) - use-ellipses?) - (hash! p))))] - [(null? p) - ;; Not syntax, so avoid useless syntax info - (if proto-r - `(lambda (r) null) - (void))] - [else (if proto-r - `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)) - (void))])) - (let* ([ht (if proto-r - #f - (make-hasheq))] - [in-order null] ; same content as ht, but in deterministic order - [l (expander p proto-r p #t - (and proto-r (sub1 (length proto-r))) - (if proto-r - #f - (lambda (r) - (let ([l (hash-ref ht (syntax-e r) null)]) - (let ([pr (and (pair? l) - (ormap (lambda (i) - (and (bound-identifier=? (mcar i) r) i)) - l))]) - (if pr - (set-mcdr! pr (cons r (mcdr pr))) - (let ([pr (mcons r (list r))]) - (set! in-order (cons pr in-order)) - (hash-set! ht (syntax-e r) (cons pr l)))))))) - #f)]) - (if proto-r - `(lambda (r) - ,(let ([main (let ([build (apply-to-r l)]) - (if (or s-exp? - (and (pair? build) - (eq? (car build) 'pattern-substitute))) - build - (let ([small-dest ;; In case dest has significant structure... - (and dest (datum->syntax - dest - 'dest - dest - dest))]) - `(datum->syntax/shape (quote-syntax ,small-dest) - ,build))))]) - (if (multiple-ellipsis-vars? p proto-r) - `(catch-ellipsis-error - (lambda () ,main) - (quote ,p) - ;; This is a trick to minimize the syntax structure we keep: - (quote-syntax ,(datum->syntax #f '... p))) - main))) - (let ([l in-order]) - (values - ;; Get list of unique vars: - (map mcar l) - ;; All ids, including duplicates: - (map mcdr l)))))) - - ;; apply-to-r creates an S-expression that applies - ;; rest to `r', but it also optimizes ((lambda (r) E) r) - ;; as simply E. - (-define (apply-to-r rest) - (if (and (pair? rest) - (eq? (car rest) 'lambda) - (equal? (cadr rest) '(r))) - (caddr rest) - `(,rest r))) - - ;; creates an S-expression that conses h and t, - ;; with optimizations. If h and t are quoted - ;; versions of the car and cdr of p, then return - ;; a quoted as the "optimization" --- one that - ;; is necessary to preserve the syntax wraps - ;; associated with p. - (-define (apply-cons stx h t p sub-gensym s-exp?) - (cond - [(and (pair? h) - (if s-exp? - (eq? (car h) 'quote) - (eq? (car h) 'quote-syntax)) - (eq? (cadr h) (stx-car p)) - (or (eq? t 'null) - (and - (pair? t) - (eq? (car t) (car h)) - (eq? (cadr t) (stx-cdr p))))) - `(,(if s-exp? 'quote 'quote-syntax) ,p)] - [(and (pair? t) - (eq? (car t) 'pattern-substitute)) - ;; fold h into the existing pattern-substitute: - (cond - [(and (pair? h) - (or (eq? (car h) 'quote-syntax) - (eq? (car h) 'quote)) - (eq? (cadr h) (stx-car p))) - ;; Just extend constant part: - `(pattern-substitute - (,(if s-exp? 'quote 'quote-syntax) - ,(let ([v (cons (cadr h) (cadadr t))]) - ;; We exploit the fact that we're - ;; building an S-expression to - ;; preserve the source's distinction - ;; between (x y) and (x . (y)). - (if (syntax? stx) - (datum->syntax stx - v - stx - stx - stx) - v))) - . ,(cddr t))] - [(and (pair? h) - (eq? (car t) #| = 'pattern-substitute |# (car h))) - ;; Combine two pattern substitutions: - `(pattern-substitute - (,(if s-exp? 'quote 'quote-syntax) - ,(let ([v (cons (cadadr h) (cadadr t))]) - (if (syntax? stx) - (datum->syntax stx - v - stx - stx - stx) - v))) - ,@(cddr h) ;; <-- WARNING: potential quadratic expansion - . ,(cddr t))] - [else - ;; General case: add a substitution: - (let* ([id (sub-gensym)] - [expr (cons id (cadadr t))] - [expr (if (syntax? stx) - (datum->syntax stx - expr - stx - stx - stx) - expr)]) - `(pattern-substitute - (,(if s-exp? 'quote 'quote-syntax) ,expr) - ,id ,h - . ,(cddr t)))])] - [(not s-exp?) - (cond - [(eq? t 'null) - (apply-cons stx h - `(pattern-substitute (quote-syntax ())) - p - sub-gensym - s-exp?)] - - [(and (pair? t) - (eq? (car t) 'quote-syntax) - (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.) - (apply-cons stx h - `(pattern-substitute ,t) - p - sub-gensym - s-exp?)] - [else - ;; Shift into `pattern-substitute' with an initial substitution: - (apply-cons stx h - (let ([id (sub-gensym)]) - `(pattern-substitute (quote-syntax ,id) - ,id ,t)) - p - sub-gensym - s-exp?)])] - [else - ;; In S-expression mode, `cons' on, but collapse to `list' - ;; or `list*' if possible: - (cond - [(eq? t 'null) - (list 'list h)] - [(and (pair? t) - (eq? (car t) 'list)) - (list* 'list h (cdr t))] - [(and (pair? t) - (or (eq? (car t) 'list*) - (eq? (car t) 'cons))) - (list* 'list* h (cdr t))] - [else - (list 'cons h t)])])) - - (-define (stx-smaller-than? stx sz) - (sz . > . (stx-size stx (add1 sz)))) - - (-define (stx-size stx up-to) - (cond - [(up-to . < . 1) 0] - [(syntax? stx) (stx-size (syntax-e stx) up-to)] - [(pair? stx) (let ([s1 (stx-size (car stx) up-to)]) - (+ s1 (stx-size (cdr stx) (- up-to s1))))] - [(vector? stx) (stx-size (vector->list stx) up-to)] - [(struct? stx) (stx-size (struct->vector stx) up-to)] - [(box? stx) (add1 (stx-size (unbox stx) (sub1 up-to)))] - [else 1])) - - ;; Generates a list-ref expression; if use-tail-pos - ;; is not #f, then the argument list is really a list* - ;; (see the note under "Input Matcher") and in that case - ;; use-tail-pos is a number indicating the list-tail - ;; position of the last element - (-define (apply-list-ref e p use-tail-pos) - (cond - [(and use-tail-pos (= p use-tail-pos)) - (cond - [(eq? p 0) e] - [(eq? p 1) `(cdr ,e)] - [(eq? p 2) `(cddr ,e)] - [(eq? p 3) `(cdddr ,e)] - [(eq? p 4) `(cddddr ,e)] - [else `(list-tail ,e ,p)])] - [(eq? p 0) `(car ,e)] - [(eq? p 1) `(cadr ,e)] - [(eq? p 2) `(caddr ,e)] - [(eq? p 3) `(cadddr ,e)] - [else `(list-ref ,e ,p)])) - ;; Returns a list that nests a pattern variable as deeply as it ;; is ellipsed. Escaping ellipses are detected. (-define get-ellipsis-nestings @@ -978,72 +533,6 @@ (sub (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipses?)] [else '()])))) - ;; Checks whether the given nesting matches a nesting in the - ;; environment prototype, returning the prototype entry if it is - ;; found, and signaling an error otherwise. If the prototype - ;; entry should be unwrapped by one, it is, and the resulting - ;; prototype is paired with #f. Otherwise, the prototype is left - ;; alone and paired with #t. There may be multiple matches; in that - ;; case, prefer unwrapping to not unwrapping (because the other one - ;; must be for a different sub-template nuder a shared ellipsis). - (-define ellipsis-sub-env - (lambda (nesting proto-r src detail-src) - (let ([vs (map (lambda (proto) - (let ([start (if (pair? proto) - (car proto) - proto)]) - (let loop ([c start] [n nesting] [unwrap? (pair? proto)]) - (cond - [(and (pair? c) (pair? n)) - (loop (car c) (car n) #t)] - [(pair? n) - (loop c (car n) #f)] - [(and (syntax? c) (syntax? n)) - (if (bound-identifier=? c n) - (cons (if unwrap? start proto) - (not unwrap?)) - #f)] - [else #f])))) - proto-r)]) - (unless (ormap values vs) - (apply - raise-syntax-error - 'syntax - "too few ellipses for pattern variable in template" - (pick-specificity - src - (let loop ([n nesting]) - (if (syntax? n) - n - (loop (car n))))))) - (or (ormap (lambda (v) (and v (not (cdr v)) v)) vs) - (ormap values vs))))) - - (-define (extract-vars proto-r) - (map (lambda (i) - (let loop ([i i]) - (if (syntax? i) - i - (loop (car i))))) - proto-r)) - - ;; Checks that a variable is not in the prototype - ;; environment, and specifically not an ellipsed - ;; variable. - (-define (check-not-pattern ssym proto-r) - (for-each (lambda (p) - (when (pair? p) - (let loop ([l (car p)]) - (cond - [(syntax? l) - (when (bound-identifier=? l ssym) - (raise-syntax-error - 'syntax - "missing ellipsis with pattern variable in template" - ssym))] - [else (loop (car l))])))) - proto-r)) - ;; Tests if x is an ellipsing pattern of the form ;; (blah ... . blah2) (-define (ellipsis? x) @@ -1067,77 +556,6 @@ (loop (cdr nestings))) (loop (cdr nestings)))))) - ;; Determines whether any ellipsis has multiple pattern - ;; variables so that a run-time check on the pattern-variable - ;; matching length will be needed - (-define (multiple-ellipsis-vars? p proto-r) - (let loop ([p p]) - (cond - [(ellipsis? p) - (or (eq? 'multi (multiple-pattern-vars (stx-car p) proto-r)) - (loop (stx-cdr (stx-cdr p))))] - [(stx-pair? p) - (let ([hd (stx-car p)]) - (if (and (identifier? hd) - (...? hd)) - #f - (or (loop hd) - (loop (stx-cdr p)))))] - [(stx-vector? p #f) - (loop (vector->list (syntax-e p)))] - [(stx-box? p) - (loop (unbox (syntax-e p)))] - [(and (syntax? p) - (prefab-struct-key (syntax-e p))) - (loop (cdr (vector->list (struct->vector (syntax-e p)))))] - [else #f]))) - - ;; Determines whether a given expression, which is under ellipses, - ;; has multiple pattern variables or the same variable at different - ;; depths; returns 'multi if so, some other internal accumulator otherwise - (-define (multiple-pattern-vars p proto-r) - (let loop ([p p] [use-ellipsis? #t] [depth 0] [found #f]) - (cond - [(identifier? p) - (if (ormap (lambda (l) - (and - (pair? l) ;; only need to track repeats - (let loop ([l l]) - (cond - [(syntax? l) - (bound-identifier=? l p)] - [else (loop (car l))])))) - proto-r) - (cond - [(not found) (cons p depth)] - [(and (bound-identifier=? p (car found)) - (= depth (cdr found))) - found] - [else 'multi]) - found)] - [(and use-ellipsis? (ellipsis? p)) - (let ([new-found (loop (stx-car p) #t (add1 depth) found)]) - (if (eq? new-found 'multi) - new-found - (loop (stx-cdr (stx-cdr p)) #t depth new-found)))] - [(stx-pair? p) - (let ([hd (stx-car p)]) - (if (and (identifier? hd) - (...? hd)) - (loop (stx-cdr p) #f depth found) - (let ([new-found (loop (stx-car p) #t depth found)]) - (if (eq? new-found 'multi) - new-found - (loop (stx-cdr p) #t depth new-found)))))] - [(stx-vector? p #f) - (loop (vector->list (syntax-e p)) use-ellipsis? depth found)] - [(stx-box? p) - (loop (unbox (syntax-e p)) use-ellipsis? depth found)] - [(and (syntax? p) - (prefab-struct-key (syntax-e p))) - (loop (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipsis? depth found)] - [else found]))) - (-define (no-ellipses? stx) (cond [(stx-pair? stx) @@ -1188,7 +606,6 @@ (s-exp-mapping-ref (set!-transformer-procedure v) 1)) (#%provide (protect make-match&env get-match-vars make-interp-match - make-pexpand make-syntax-mapping syntax-pattern-variable? syntax-mapping-depth syntax-mapping-valvar make-s-exp-mapping s-exp-pattern-variable? diff --git a/racket/collects/racket/private/stxcase.rkt b/racket/collects/racket/private/stxcase.rkt index cc3b2ec158..401f7d36fc 100644 --- a/racket/collects/racket/private/stxcase.rkt +++ b/racket/collects/racket/private/stxcase.rkt @@ -7,129 +7,6 @@ (for-syntax "stx.rkt" "small-scheme.rkt" "member.rkt" "sc.rkt" '#%kernel)) - (-define (datum->syntax/shape orig datum) - (if (syntax? datum) - datum - ;; Keeps 'paren-shape and any other properties: - (datum->syntax orig datum orig orig))) - - (-define (catch-ellipsis-error thunk sexp sloc) - ((let/ec esc - (with-continuation-mark - exception-handler-key - (lambda (exn) - (esc - (lambda () - (if (exn:break? exn) - (raise exn) - (raise-syntax-error - 'syntax - "incompatible ellipsis match counts for template" - sexp - sloc))))) - (let ([v (thunk)]) - (lambda () v)))))) - - (-define substitute-stop 'dummy) - - ;; pattern-substitute optimizes a pattern substitution by - ;; merging variables that look up the same simple mapping - (-define-syntax pattern-substitute - (lambda (stx) - (let ([pat (stx-car (stx-cdr stx))] - [subs (stx->list (stx-cdr (stx-cdr stx)))]) - (let ([ht-common (make-hash)] - [ht-map (make-hasheq)]) - ;; Determine merges: - (let loop ([subs subs]) - (unless (null? subs) - (let ([id (syntax-e (car subs))] - [expr (cadr subs)]) - (when (or (identifier? expr) - (and (stx-pair? expr) - (memq (syntax-e (stx-car expr)) - '(car cadr caddr cadddr - cdr cddr cdddr cddddr - list-ref list-tail)) - (stx-pair? (stx-cdr expr)) - (identifier? (stx-car (stx-cdr expr))))) - (let ([s-expr (syntax->datum expr)]) - (let ([new-id (hash-ref ht-common s-expr #f)]) - (if new-id - (hash-set! ht-map id new-id) - (hash-set! ht-common s-expr id)))))) - (loop (cddr subs)))) - ;; Merge: - (let ([new-pattern (if (zero? (hash-count ht-map)) - pat - (let loop ([stx pat]) - (cond - [(pair? stx) - (let ([a (loop (car stx))] - [b (loop (cdr stx))]) - (if (and (eq? a (car stx)) - (eq? b (cdr stx))) - stx - (cons a b)))] - [(symbol? stx) - (let ([new-id (hash-ref ht-map stx #f)]) - (or new-id stx))] - [(syntax? stx) - (let ([new-e (loop (syntax-e stx))]) - (if (eq? (syntax-e stx) new-e) - stx - (datum->syntax stx new-e stx stx)))] - [(vector? stx) - (list->vector (map loop (vector->list stx)))] - [(box? stx) (box (loop (unbox stx)))] - [else stx])))]) - (datum->syntax (quote-syntax here) - `(apply-pattern-substitute - ,new-pattern - (quote ,(let loop ([subs subs]) - (cond - [(null? subs) null] - [(hash-ref ht-map (syntax-e (car subs)) #f) - ;; Drop mapped id - (loop (cddr subs))] - [else - (cons (car subs) (loop (cddr subs)))]))) - . ,(let loop ([subs subs]) - (cond - [(null? subs) null] - [(hash-ref ht-map (syntax-e (car subs)) #f) - ;; Drop mapped id - (loop (cddr subs))] - [else - (cons (cadr subs) (loop (cddr subs)))]))) - stx)))))) - - (-define apply-pattern-substitute - (lambda (stx sub-ids . sub-vals) - (let loop ([stx stx]) - (cond - [(pair? stx) (let ([a (loop (car stx))] - [b (loop (cdr stx))]) - (if (and (eq? a (car stx)) - (eq? b (cdr stx))) - stx - (cons a b)))] - [(symbol? stx) - (let sloop ([sub-ids sub-ids][sub-vals sub-vals]) - (cond - [(null? sub-ids) stx] - [(eq? stx (car sub-ids)) (car sub-vals)] - [else (sloop (cdr sub-ids) (cdr sub-vals))]))] - [(syntax? stx) - (let ([new-e (loop (syntax-e stx))]) - (if (eq? (syntax-e stx) new-e) - stx - (datum->syntax/shape stx new-e)))] - [(vector? stx) - (list->vector (map loop (vector->list stx)))] - [(box? stx) (box (loop (unbox stx)))] - [else stx])))) - (-define interp-match (lambda (pat e literals immediate=?) (interp-gen-match pat e literals immediate=? #f))) @@ -502,103 +379,6 @@ m))))]))) x))))))) - (begin-for-syntax - (define-values (gen-template) - (lambda (x s-exp?) - (-define here-stx (quote-syntax here)) - (unless (and (stx-pair? x) - (let ([rest (stx-cdr x)]) - (and (stx-pair? rest) - (stx-null? (stx-cdr rest))))) - (raise-syntax-error - #f - "bad form" - x)) - (syntax-arm - (datum->syntax - here-stx - (let ([pattern (stx-car (stx-cdr x))]) - (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)]) - (let ([var-bindings - (map - (lambda (var) - (and (let ([v (syntax-local-value var (lambda () #f))]) - (and (if s-exp? - (s-exp-pattern-variable? v) - (syntax-pattern-variable? v)) - v)))) - unique-vars)]) - (if (and (or (null? var-bindings) - (not (ormap (lambda (x) x) var-bindings))) - (no-ellipses? pattern)) - ;; Constant template: - (list (if s-exp? - (quote-syntax quote) - (quote-syntax quote-syntax)) - pattern) - ;; Non-constant: - (let ([proto-r (let loop ([vars unique-vars][bindings var-bindings]) - (if (null? bindings) - null - (let ([rest (loop (cdr vars) - (cdr bindings))]) - (if (car bindings) - (cons (let loop ([v (car vars)] - [d (if s-exp? - (s-exp-mapping-depth (car bindings)) - (syntax-mapping-depth (car bindings)))]) - (if (zero? d) - v - (loop (list v) (sub1 d)))) - rest) - rest))))] - [non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings]) - (if (null? bindings) - null - (let ([rest (loop (cdr vars) - (cdr bindings))]) - (if (car bindings) - rest - (cons (car vars) rest)))))]) - (let ([build-from-template - ;; Even if we don't use the builder, we need to check - ;; for a well-formed pattern: - (make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)] - [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss]) - (cond - [(null? bindings) null] - [(car bindings) - (cons - (syntax-property - (let ([id (if s-exp? - (s-exp-mapping-valvar (car bindings)) - (syntax-mapping-valvar (car bindings)))]) - (datum->syntax - id - (syntax-e id) - x)) - 'disappeared-use - (map syntax-local-introduce (car all-varss))) - (loop (cdr vars) (cdr bindings) (cdr all-varss)))] - [else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))]) - (if (identifier? pattern) - ;; Simple syntax-id lookup: - (car r) - ;; General case: - (list (datum->syntax - here-stx - build-from-template - pattern) - (let ([len (length r)]) - (cond - [(zero? len) (quote-syntax ())] - [(= len 1) (car r)] - [else - (cons (quote-syntax list*) r)])))))))))) - x))))) - - (-define-syntax syntax (lambda (stx) (gen-template stx #f))) - (-define-syntax datum (lambda (stx) (gen-template stx #t))) - - (#%provide (all-from "ellipses.rkt") syntax-case** syntax datum + (#%require "template.rkt") + (#%provide (all-from "ellipses.rkt") syntax-case** syntax syntax/loc datum (for-syntax syntax-pattern-variable?))) diff --git a/racket/collects/racket/private/stxloc.rkt b/racket/collects/racket/private/stxloc.rkt index 0e0082a699..dd44ce271c 100644 --- a/racket/collects/racket/private/stxloc.rkt +++ b/racket/collects/racket/private/stxloc.rkt @@ -35,28 +35,6 @@ [(sc stxe kl . clause) (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)]))) - (-define (relocate loc stx) - (if (or (syntax-source loc) - (syntax-position loc)) - (datum->syntax stx - (syntax-e stx) - loc - stx) - stx)) - - ;; Like syntax, but also takes a syntax object - ;; that supplies a source location for the - ;; resulting syntax object. - (-define-syntax syntax/loc - (lambda (stx) - (syntax-case** #f #t stx () free-identifier=? #f - [(_ loc pattern) - (if (if (symbol? (syntax-e #'pattern)) - (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) - #f) - (syntax (syntax pattern)) - (syntax (relocate loc (syntax pattern))))]))) - (-define-syntax quote-syntax/prune (lambda (stx) (syntax-case** #f #t stx () free-identifier=? #f @@ -77,4 +55,5 @@ stx #'id))]))) - (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _)) + (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case + ... _ ?? ?@)) diff --git a/racket/collects/racket/private/template.rkt b/racket/collects/racket/private/template.rkt new file mode 100644 index 0000000000..9ce643a397 --- /dev/null +++ b/racket/collects/racket/private/template.rkt @@ -0,0 +1,716 @@ +(module template '#%kernel +(#%require "stx.rkt" "small-scheme.rkt" "performance-hint.rkt" + (rename "small-scheme.rkt" define -define) + (rename "small-scheme.rkt" define-syntax -define-syntax) + "ellipses.rkt" + (for-syntax "stx.rkt" "small-scheme.rkt" + (rename "small-scheme.rkt" define -define) + (rename "small-scheme.rkt" define-syntax -define-syntax) + "member.rkt" "sc.rkt" '#%kernel)) +(#%provide syntax + syntax/loc + datum + ?? ?@ + ?@! signal-absent-pvar + (protect + (for-syntax attribute-mapping + attribute-mapping? + attribute-mapping-name + attribute-mapping-var + attribute-mapping-depth + attribute-mapping-check + metafunction metafunction?))) + +;; ============================================================ +;; Syntax of templates + +;; A Template (T) is one of: +;; - pattern-variable +;; - constant (including () and non-pvar identifiers) +;; - (metafunction . T) +;; - (H . T) +;; - (H ... . T), (H ... ... . T), etc +;; - (... T) -- escapes inner ..., ??, ?@ +;; - (?? T T) +;; - #(T*) -- actually, vector->list interpreted as T +;; - #s(prefab-struct-key T*) -- likewise + +;; A HeadTemplate (H) is one of: +;; - T +;; - (?? H) +;; - (?? H H) +;; - (?@ . T) + +(define-syntax ?@! #f) ;; private, escape-ignoring version of ?@, used by unsyntax-splicing + +;; ============================================================ +;; Compile-time + +;; Parse template syntax into a Guide (AST--the name is left over from +;; when the "guide" was a data structure interpreted at run time). + +;; The AST representation is designed to coincide with the run-time +;; support, so compilation is just (datum->syntax #'here guide). The +;; variants listed below are the ones recognized and treated specially +;; by other functions (eg optimize-resyntax, relocate-guide). + +;; A Guide (G) is one of: +;; - (list 't-resyntax Expr Expr G) +;; - (list 't-const Expr) ;; constant +;; - (list 't-var Id) ;; trusted pattern variable +;; - (list 't-list G ...) +;; - (list 't-list* G ... G) +;; - (list 't-append HG G) +;; - (list 't-orelse G G) +;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions +;; -- where Subst = Nat ;; replace nth car with arg +;; | 'tail Nat ;; replace nth cdr with arg +;; | 'append Nat ;; replace nth car by appending arg +;; | 'recur Nat ;; replace nth car by recurring on it with arg +;; - other expression (must be pair!) + +;; A HeadGuide (HG) is one of: +;; - (list 'h-t G) +;; - 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 + + (define here-stx (quote-syntax here)) + + (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 + ;; (see sc.rkt) whose valvar is an identifier statically bound to an + ;; attribute-mapping. + + ;; (struct attribute-mapping (var name depth check) ...) + ;; check : #f (trusted) or Id, ref to Checker + ;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) ) + (define-values (struct:attribute-mapping attribute-mapping attribute-mapping? + attribute-mapping-ref _attribute-mapping-set!) + (make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector) + (lambda (self stx) + (if (attribute-mapping-check self) + (let ([source-name + (or (let loop ([p (syntax-property stx 'disappeared-use)]) + (cond [(identifier? p) p] + [(pair? p) (or (loop (car p)) (loop (cdr p)))] + [else #f])) + (attribute-mapping-name self))]) + (define code + `(,(attribute-mapping-check self) + ,(attribute-mapping-var self) + ,(attribute-mapping-depth self) + #t + (quote-syntax ,source-name))) + (datum->syntax here-stx code stx)) + (attribute-mapping-var self))))) + (define (attribute-mapping-var a) (attribute-mapping-ref a 0)) + (define (attribute-mapping-name a) (attribute-mapping-ref a 1)) + (define (attribute-mapping-depth a) (attribute-mapping-ref a 2)) + (define (attribute-mapping-check a) (attribute-mapping-ref a 3)) + + ;; (struct metafunction (var)) + (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!) + (make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector))) + (define (metafunction-var mf) (metafunction-ref mf 0)) + + (define (ht-guide? x) + (if (and (pair? x) (eq? (car x) 'h-t)) #t #f)) + (define (ht-guide-t x) + (if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f)) + + (define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list)))) + (define (const-guide-v x) + (if (eq? (car x) 't-list) + null + (let ([e (cadr x)]) + (if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e))))) + + (define (cons-guide g1 g2) + (cond [(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)])) + + ;; ---------------------------------------- + ;; Parsing templates + + ;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id)) + (define (parse-template ctx t stx?) + ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ] + (define env (make-hasheq)) + + ;; wrong-syntax : Syntax Format-String Any ... -> (error) + (define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x)) + + ;; disappeared-uses : (Listof Id) + (define disappeared-uses null) + ;; disappeared! : Id -> Void + (define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses))) + + ;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide) + (define (parse-t t depth esc?) + (cond [(stx-pair? t) + (if (identifier? (stx-car t)) + (parse-t-pair/command t depth esc?) + (parse-t-pair/dots t depth esc?))] + [else (parse-t-nonpair t depth esc?)])) + + ;; parse-t-pair/command : Stx Nat Boolean -> ... + ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) + (define (parse-t-pair/command t depth esc?) + (cond [esc? + (parse-t-pair/dots t depth esc?)] + [(parse-form t (quote-syntax ...) 1) + => (lambda (t) + (disappeared! (car t)) + (define-values (drivers guide) (parse-t (cadr t) depth #t)) + ;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _) + (values drivers `(t-escaped ,guide)))] + [(parse-form t (quote-syntax ??) 2) + => (lambda (t) + (disappeared! (car t)) + (define t1 (cadr t)) + (define t2 (caddr t)) + (define-values (drivers1 guide1) (parse-t t1 depth esc?)) + (define-values (drivers2 guide2) (parse-t t2 depth esc?)) + (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] + [(lookup-metafun (stx-car t)) + => (lambda (mf) + (unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported")) + (disappeared! (stx-car t)) + (define-values (drivers guide) (parse-t (stx-cdr t) depth esc?)) + (values drivers + `(t-metafun ,(metafunction-var mf) ,guide + (quote-syntax + ,(let ([tstx (and (syntax? t) t)]) + (datum->syntax tstx (cons (stx-car t) #f) tstx tstx))))))] + [else (parse-t-pair/dots t depth esc?)])) + + ;; parse-t-pair/dots : Stx Nat Boolean -> ... + ;; t is a stx pair; check for dots + (define (parse-t-pair/dots t depth esc?) + (define head (stx-car t)) + (define-values (tail nesting) + (let loop ([tail (stx-cdr t)] [nesting 0]) + (if (and (not esc?) (stx-pair? tail) + (let ([x (stx-car tail)]) + (and (identifier? x) (free-identifier=? x (quote-syntax ...))))) + (begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting))) + (values tail nesting)))) + (if (zero? nesting) + (parse-t-pair/normal t depth esc?) + (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)] + [(tdrivers tguide) (parse-t tail depth esc?)]) + (when (dset-empty? hdrivers) + (wrong-syntax head "no pattern variables before ellipsis in template")) + (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) + (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one + (stx-car (stx-drop nesting t))]) + ;; 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)] + [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) + `(t-dots ,cons? ,hguide ,(car hdriverss) + (quote ,head) (quote-syntax ,at-stx)))] + [else (let ([inner (loop (cdr hdriverss))]) + `(t-dots #f ,inner ,(car hdriverss) + (quote ,head) (quote-syntax ,at-stx)))]))) + (values (dset-union hdrivers tdrivers) + (if (equal? tguide '(t-list)) + (resyntax t hg) + (resyntax t `(t-append ,hg ,tguide))))))) + + ;; parse-t-pair/normal : Stx Nat Boolean -> ... + ;; t is a normal stx pair + (define (parse-t-pair/normal t depth esc?) + (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?)) + (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?)) + (values (dset-union hdrivers tdrivers) + (resyntax t + (if (ht-guide? hguide) + (let ([hguide (ht-guide-t hguide)]) + (if (and (const-guide? hguide) (const-guide? tguide)) + (const-guide t) + (cons-guide hguide tguide))) + (if (equal? tguide '(t-list)) + hguide + `(t-append ,hguide ,tguide)))))) + + ;; parse-t-nonpair : Syntax Nat Boolean -> ... + ;; PRE: t is not a stxpair + (define (parse-t-nonpair t depth esc?) + (define td (if (syntax? t) (syntax-e t) t)) + (cond [(identifier? t) + (cond [(and (not esc?) + (or (free-identifier=? t (quote-syntax ...)) + (free-identifier=? t (quote-syntax ??)) + (free-identifier=? t (quote-syntax ?@)))) + (wrong-syntax t "illegal use")] + [(lookup-metafun t) + (wrong-syntax t "illegal use of syntax metafunction")] + [(lookup t depth) + => (lambda (pvar) + (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) + (define-values (drivers guide) (parse-t (vector->list td) depth esc?)) + (values drivers + (cond [(const-guide? guide) (const-guide t)] + [else (resyntax t `(t-vector ,guide))]))] + [(prefab-struct-key td) + => (lambda (key) + (define-values (drivers guide) + (let ([elems (cdr (vector->list (struct->vector td)))]) + (parse-t elems depth esc?))) + (values drivers + (cond [(const-guide? guide) (const-guide t)] + [else (resyntax t `(t-struct (quote ,key) ,guide))])))] + [(box? td) + (define-values (drivers guide) (parse-t (unbox td) depth esc?)) + (values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))] + [else (values (dset) (const-guide t))])) + + ;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide) + (define (parse-h h depth esc?) + (cond [(and (not esc?) (parse-form h (quote-syntax ??) 1)) + => (lambda (h) + (disappeared! (car h)) + (define-values (drivers guide) (parse-h (cadr h) depth esc?)) + (values drivers `(h-orelse ,guide null)))] + [(and (not esc?) (parse-form h (quote-syntax ??) 2)) + => (lambda (h) + (disappeared! (car h)) + (define-values (drivers1 guide1) (parse-h (cadr h) depth esc?)) + (define-values (drivers2 guide2) (parse-h (caddr h) depth esc?)) + (values (dset-union drivers1 drivers2) + (if (and (ht-guide? guide1) (ht-guide? guide2)) + `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2))) + `(h-orelse ,guide1 ,guide2))))] + [(and (stx-pair? h) + (let ([h-head (stx-car h)]) + (and (identifier? h-head) + (or (and (free-identifier=? h-head (quote-syntax ?@)) (not esc?)) + (free-identifier=? h-head (quote-syntax ?@!)))))) + (disappeared! (stx-car h)) + (define-values (drivers guide) (parse-t (stx-cdr h) depth esc?)) + (values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))] + [else + (define-values (drivers guide) (parse-t h depth esc?)) + (values drivers `(h-t ,guide))])) + + ;; lookup : Identifier Nat -> PVar/#f + (define (lookup id depth) + (define (make-pvar var check pvar-depth) + (cond [(zero? pvar-depth) + (pvar var var check #f)] + [(>= depth pvar-depth) + (pvar var (gentemp) check (- depth pvar-depth))] + [else + (wrong-syntax id "missing ellipses with pattern variable in template")])) + (define (hash-ref! h k proc) + (let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*)))) + (let ([v (syntax-local-value id (lambda () #f))]) + (cond [(syntax-pattern-variable? v) + (hash-ref! env (cons v depth) + (lambda () + (define pvar-depth (syntax-mapping-depth v)) + (define attr + (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) + (and (attribute-mapping? attr) attr))) + (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) + (define check (and attr (attribute-mapping-check attr))) + (make-pvar var check pvar-depth)))] + [(s-exp-pattern-variable? v) + (hash-ref! env (cons v depth) + (lambda () + (define pvar-depth (s-exp-mapping-depth v)) + (define var (s-exp-mapping-valvar v)) + (make-pvar var #f pvar-depth)))] + [else + ;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute + (for-each + (lambda (pfx) + (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) + (if (and (syntax-pattern-variable? pfx-v) + (let ([valvar (syntax-mapping-valvar pfx-v)]) + (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) + (wrong-syntax id "undefined nested attribute of attribute `~a'" + (syntax-e pfx)) + (void)))) + (dotted-prefixes id)) + #f]))) + + ;; resyntax : Stx Guide -> Guide + (define (resyntax t0 g) + (if (and stx? (syntax? t0)) + (cond [(const-guide? g) (const-guide t0)] + [else (optimize-resyntax t0 g)]) + g)) + + ;; optimize-resyntax : Syntax Guide -> Guide + (define (optimize-resyntax t0 g) + (define HOLE (datum->syntax #f '_)) + (define (finish i rt rs re) + (values (sub1 i) (reverse rs) (reverse re) + (datum->syntax t0 (apply list* (reverse rt)) t0 t0))) + (define (loop-gs list*? gs i rt rs re) + (cond [(null? gs) + (finish i (cons null rt) rs re)] + [(and list*? (null? (cdr gs))) + (loop-g (car gs) i rt rs re)] + [else + (define g0 (car gs)) + (cond [(const-guide? g0) + (let ([const (const-guide-v g0)]) + (loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))] + [(eq? (car g0) 't-subst) ;; (t-subst LOC STX ) + (let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _) + [subargs (list-tail g0 3)]) + (loop-gs list*? (cdr gs) (add1 i) (cons subt rt) + (list* i 'recur rs) (cons `(list . ,subargs) re)))] + [else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt) + (cons i rs) (cons g0 re))])])) + (define (loop-g g i rt rs re) + (cond [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)] + [(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)] + [(eq? (car g) 't-append) + (loop-g (caddr g) (add1 i) (cons HOLE rt) + (list* i 'append rs) (cons (cadr g) re))] + [(eq? (car g) 't-const) + (let ([const (const-guide-v g)]) + (finish i (cons const rt) rs re))] + [else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))])) + (define-values (npairs substs exprs t*) (loop-g g 0 null null null)) + (cond [(and substs + ;; Tunable condition for choosing whether to create a t-subst. + ;; Avoid creating useless (t-subst loc stx '(tail 0) g). + (<= (length substs) (* 2 npairs))) + #;(log-message template-logger 'debug + (format "OPTIMIZED ~s" (syntax->datum t0)) #f) + `(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)] + [else + #;(log-message template-logger 'debug + (format "NOT opt ~s" (syntax->datum t0)) #f) + (let ([rep (datum->syntax t0 'STX t0 t0)]) + `(t-resyntax #f (quote-syntax ,rep) ,g))])) + + ;; const-guide : Any -> Guide + (define (const-guide x) + (cond [(null? x) `(t-list)] + [(not stx?) `(t-const (quote ,x))] + [(syntax? x) `(t-const (quote-syntax ,x))] + [else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))])) + + (let-values ([(drivers guide) (parse-t t 0 #f)]) + (values (dset->list drivers) guide disappeared-uses))) + + ;; parse-form : Stx Id Nat -> (list[arity+1] Syntax) + (define (parse-form stx form-id arity) + (and (stx-pair? stx) + (let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)]) + (and (identifier? stx-h) (free-identifier=? stx-h form-id) + (let ([stx-tl (stx->list stx-t)]) + (and (list? stx-tl) + (= (length stx-tl) arity) + (cons stx-h stx-tl))))))) + + ;; lookup-metafun : Identifier -> Metafunction/#f + (define (lookup-metafun id) + (define v (syntax-local-value id (lambda () #f))) + (and (metafunction? v) v)) + + (define (dotted-prefixes id) + (let* ([id-string (symbol->string (syntax-e id))] + [dot-locations + (let loop ([i 0]) + (if (< i (string-length id-string)) + (if (eqv? (string-ref id-string i) #\.) + (cons i (loop (add1 i))) + (loop (add1 i))) + null))]) + (map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc)))) + 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) + (set! gentemp-counter (add1 gentemp-counter)) + ((make-syntax-introducer) + (datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter))))) + + (define (stx-drop n 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) + + ;; Only relocate if relocation would affect a syntax pair originating + ;; from template structure. For example (x,y are pvars): + ;; (syntax/loc loc-stx (1 2 3)) => relocate + ;; (syntax/loc loc-stx y) => don't relocate + ;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x! + ;; Deciding whether to relocate after the fact is hard. But with explicit + ;; t-resyntax, it's much easier. + + ;; relocate-guide : Syntax Guide Id -> Guide + (define (relocate-guide ctx g0 loc-id) + (define (loop g) + (define gtag (car g)) + (cond [(eq? gtag 't-resyntax) + `(t-resyntax ,loc-id . ,(cddr g))] + [(eq? gtag 't-const) + `(t-relocate ,g ,loc-id)] + [(eq? gtag 't-subst) + `(t-subst ,loc-id . ,(cddr g))] + ;; ---- + [(eq? gtag 't-escaped) + `(t-escaped ,(loop (cadr g)))] + [(eq? gtag 't-orelse) + `(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))] + ;; ---- + ;; Nothing else should be relocated + [else g])) + (loop g0)) + + ;; ---------------------------------------- + + ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax + (define (do-template ctx tstx loc-id stx?) + (define-values (pvars pre-guide disappeared-uses) + (parse-template ctx tstx stx?)) + (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide)) + (define ell-pvars (filter pvar-dd pvars)) + (define pre-code + (if (const-guide? guide) + (if stx? `(quote-syntax ,tstx) `(quote ,tstx)) + (let ([lvars (map pvar-lvar ell-pvars)] + [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))) + (syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses))) + ) + +(define-syntax (syntax stx) + (define s (syntax->list stx)) + (if (and (list? s) (= (length s) 2)) + (do-template stx (cadr s) #f #t) + (raise-syntax-error #f "bad syntax" stx))) + +(define-syntax (syntax/loc stx) + (define s (syntax->list stx)) + (if (and (list? s) (= (length s) 3)) + (let ([loc-id (quote-syntax loc)]) + (define code + `(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))]) + ,(do-template stx (caddr s) loc-id #t))) + (syntax-arm (datum->syntax here-stx code stx))) + (raise-syntax-error #f "bad syntax" stx))) + +(define-syntax (datum stx) + (define s (syntax->list stx)) + (if (and (list? s) (= (length s) 2)) + (do-template stx (cadr s) #f #f) + (raise-syntax-error #f "bad syntax" stx))) + +(define (check-loc who x) + (if (syntax? x) x (raise-argument-error who "syntax?" x))) + + +;; ============================================================ +;; Run-time support + +;; (t-dots cons? hguide hdrivers) : Expr[(Listof Syntax)] +(define-syntax (t-dots stx) + (define s (syntax->list stx)) + (define cons? (syntax-e (list-ref s 1))) + (define head (list-ref s 2)) + (define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar) + (define in-stx (list-ref s 4)) + (define at-stx (list-ref s 5)) + (cond + ;; Case 1: (x ...) where x is trusted + [(and cons? (let ([head-s (syntax->list head)]) + (and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var)))) + head] + ;; General case + [else + ;; var-value-expr : Id Id/#'#f -> Expr[List] + (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-syntax (t-orelse stx) + (define s (syntax->list stx)) + (datum->syntax here-stx `(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s))))) +(define-syntax h-orelse (make-rename-transformer (quote-syntax t-orelse))) + +(#%require (rename '#%kernel t-const #%expression) + (rename '#%kernel t-var #%expression) + ;; (rename '#%kernel t-append append) + (rename '#%kernel t-list list) + (rename '#%kernel t-list* list*) + (rename '#%kernel t-escaped #%expression) + (rename '#%kernel t-vector list->vector) + (rename '#%kernel t-box box-immutable) + (rename '#%kernel h-t list)) + +(begin-encourage-inline + +(define (t-append xs ys) (if (null? ys) xs (append xs ys))) +(define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx)) +(define (t-relocate g loc) (datum->syntax g (syntax-e g) loc g)) +(define (t-orelse* g1 g2) + ((let/ec escape + (with-continuation-mark + absent-pvar-escape-key + (lambda () (escape g2)) + (let ([v (g1)]) (lambda () v)))))) +(define (t-struct key g) (apply make-prefab-struct key g)) +(define (t-metafun mf g stx) + (mf (datum->syntax stx (cons (stx-car stx) g) stx stx))) +(define (h-splice g in-stx at-stx) + (if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx))) + +#| end begin-encourage-inline |#) + +;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax +;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs) +;; There is one arg for each index in substs. See also defn of Guide above. +(define (t-subst loc stx substs . args) + (define (loop/mode s i mode seek substs args) + (cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))] + [(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))] + [(eq? mode 'tail) (car args)] + [(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))] + [(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args)) + (loop (cdr s) (add1 i) substs (cdr args)))])) + (define (loop s i substs args) + (cond [(null? substs) s] + [(symbol? (car substs)) + (loop/mode s i (car substs) (cadr substs) (cddr substs) args)] + [else (loop/mode s i #f (car substs) (cdr substs) args)])) + (define v (loop (syntax-e stx) 0 substs args)) + (datum->syntax stx v (or loc stx) stx)) + +(define absent-pvar-escape-key (gensym 'absent-pvar-escape)) + +;; signal-absent-pvar : -> escapes or #f +;; Note: Only escapes if in ?? form. +(define (signal-absent-pvar) + (let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)]) + (if escape (escape) #f))) + +;; error/splice : Any Stx Stx -> (escapes) +(define (error/splice r in-stx at-stx) + (raise-syntax-error 'syntax + (format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx)) + +;; check-same-length : Stx Stx List ... -> Void +(define check-same-length + (case-lambda + [(in at a) (void)] + [(in at a b) + (if (= (length a) (length b)) + (void) + (raise-syntax-error 'syntax "incompatible ellipsis match counts for template" + (list in '...) at))] + [(in at a . bs) + (define alen (length a)) + (for-each (lambda (b) + (if (= alen (length b)) + (void) + (raise-syntax-error 'syntax "incompatible ellipsis match counts for template" + (list in '...) at))) + bs)])) + +) diff --git a/racket/collects/syntax/parse/experimental/dset.rkt b/racket/collects/syntax/parse/experimental/dset.rkt deleted file mode 100644 index 57c53e5d1c..0000000000 --- a/racket/collects/syntax/parse/experimental/dset.rkt +++ /dev/null @@ -1,54 +0,0 @@ -#lang racket/base - -;; A dset is an `equal?`-based set, but it preserves order based on -;; the history of additions, so that if items are added in a -;; deterministic order, they come back out in a deterministic order. - -(provide dset - dset-empty? - dset->list - dset-add - dset-union - dset-subtract - dset-filter) - -(define dset - (case-lambda - [() (hash)] - [(e) (hash e 0)])) - -(define (dset-empty? ds) - (zero? (hash-count ds))) - -(define (dset->list ds) - (map cdr - (sort (for/list ([(k v) (in-hash ds)]) - (cons v k)) - < - #:key car))) - -(define (dset-add ds e) - (if (hash-ref ds e #f) - ds - (hash-set ds e (hash-count ds)))) - -(define (dset-union ds1 ds2) - (cond - [((hash-count ds1) . > . (hash-count ds2)) - (dset-union ds2 ds1)] - [else - (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) - (dset-add ds2 e))])) - -(define (dset-subtract ds1 ds2) - ;; ! takes O(size(ds2)) time ! - (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) - (if (hash-ref ds2 e #f) - r - (dset-add r e)))) - -(define (dset-filter ds pred) - (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) - (if (pred e) - (dset-add r e) - r))) diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt index d030bcf5f6..05906c5376 100644 --- a/racket/collects/syntax/parse/experimental/template.rkt +++ b/racket/collects/syntax/parse/experimental/template.rkt @@ -1,492 +1,16 @@ #lang racket/base -(require (for-syntax racket/base - "dset.rkt" - racket/syntax - syntax/parse/private/minimatch - racket/private/stx ;; syntax/stx - racket/private/sc) - syntax/parse/private/residual - racket/private/stx - racket/performance-hint - racket/private/promise) -(provide template - template/loc - datum-template - quasitemplate - quasitemplate/loc - define-template-metafunction - ?? - ?@) - -;; ============================================================ -;; Syntax of templates - -;; A Template (T) is one of: -;; - pattern-variable -;; - constant (including () and non-pvar identifiers) -;; - (metafunction . T) -;; - (H . T) -;; - (H ... . T), (H ... ... . T), etc -;; - (?? T T) -;; - #(T*) -;; - #s(prefab-struct-key T*) -;; * (unsyntax expr) - -;; A HeadTemplate (H) is one of: -;; - T -;; - (?? H) -;; - (?? H H) -;; - (?@ . T) -;; * (unquote-splicing expr) - -(define-syntaxes (?? ?@) - (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) - (values tx tx))) - -(define-syntax ?@! #f) ;; private, escape-ignoring version of ?@, used by unsyntax-splicing - -;; ============================================================ -;; Compile-time - -;; Parse template syntax into a Guide (AST--the name is left over from -;; when the "guide" was a data structure interpreted at run time). - -;; The AST representation is designed to coincide with the run-time -;; support, so compilation is just (datum->syntax #'here guide). - -;; A Guide (G) is one of: -;; - (list 't-resyntax G) ;; template is syntax; re-syntax result -;; - (list 't-const) ;; constant -;; - (list 't-var PVar Boolean) ;; pattern variable -;; - (list 't-cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr} -;; - (list 't-vector G) ;; template is non-syntax vector -;; - (list 't-struct G) ;; template is non-syntax prefab struct -;; - (list 't-box G) ;; template is non-syntax box -;; - (list 't-dots HG (listof (listof PVar)) Nat G/#f #f Boolean) -;; - (list 't-dots G (listof (listof PVar)) Nat G/#f #t Boolean) -;; - (list 't-append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr} -;; - (list 't-escaped G) -;; - (list 't-orelse G G) -;; - (list 't-metafun Id G) -;; - (list 't-relocate G Id) ;; relocate syntax -;; - (list 't-resyntax/loc G Id) ;; like t-resyntax, but use alt srcloc -;; For 't-var and 't-dots, the final boolean indicates whether the template -;; fragment is in the left-hand side of an orelse (??). - -;; A HeadGuide (HG) is one of: -;; - (list 'h-t G) -;; - (list 'h-orelse HG HG/#f) -;; - (list 'h-splice G) - -;; A PVar is (pvar Id Id Boolean 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 boolean is #f if var is trusted to have a -;; (Listof^depth Syntax) value, #t 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) ...) ...))) -;; -;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for -;; z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis -;; form at which the variable should be moved to the loop-env. That is, the -;; template above should be interpreted as roughly similar to -;; -;; (let ([x (pvar-value-of x)] -;; [y (pvar-value-of y)] -;; [z (pvar-value-of z)]) -;; (for ([Lz (in-list z)]) ;; depth 0 -;; (for ([Ly (in-list y)] ;; depth 1 -;; [Lz (in-list Lz)]) -;; (___ x Ly Lz ___)))) - -(begin-for-syntax - - (define-logger template) - - (struct pvar (var lvar check? dd) #:prefab) - (struct template-metafunction (var)) - - (define (ht-guide? x) (match x [(list 'h-t _) #t] [_ #f])) - (define (ht-guide-t x) (match x [(list 'h-t g) g])) - - (define const-guide '(t-const)) - (define (const-guide? x) (equal? x const-guide)) - - ;; ---------------------------------------- - ;; Parsing templates - - ;; parse-template : Syntax Boolean -> (values (listof PVar) Guide) - (define (parse-template t stx?) - ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ] - (define env (make-hasheq)) - - ;; parse-t : Stx Nat Boolean Boolean -> (values (dsetof PVar) Guide) - (define (parse-t t depth esc? in-try?) - (cond [(stx-pair? t) - (if (identifier? (stx-car t)) - (parse-t-pair/command t depth esc? in-try?) - (parse-t-pair/dots t depth esc? in-try?))] - [else (parse-t-nonpair t depth esc? in-try?)])) - - ;; parse-t-pair/command : Stx Nat Boolean Boolean -> ... - ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) - (define (parse-t-pair/command t depth esc? in-try?) - (syntax-case t (??) - [(DOTS template) - (and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...))) - (let-values ([(drivers guide) (parse-t #'template depth #t in-try?)]) - (values drivers `(t-escaped ,guide)))] - [(?? t1 t2) - (not esc?) - (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc? #t)] - [(drivers2 guide2) (parse-t #'t2 depth esc? in-try?)]) - (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] - [(mf-id . _) - (and (not esc?) (lookup-metafun #'mf-id)) - (let-values ([(mf) (lookup-metafun #'mf-id)] - [(drivers guide) (parse-t (stx-cdr t) depth esc? in-try?)]) - (unless stx? (wrong-syntax "metafunctions not supported" #'mf-id)) - (values drivers `(t-metafun ,(template-metafunction-var mf) ,guide)))] - [_ (parse-t-pair/dots t depth esc? in-try?)])) - - ;; parse-t-pair/dots : Stx Nat Boolean Boolean -> ... - ;; t is a stx pair; check for dots - (define (parse-t-pair/dots t depth esc? in-try?) - (define head (stx-car t)) - (define-values (tail nesting) - (let loop ([tail (stx-cdr t)] [nesting 0]) - (if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail))) - (loop (stx-cdr tail) (add1 nesting)) - (values tail nesting)))) - (if (zero? nesting) - (parse-t-pair/normal t depth esc? in-try?) - (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc? in-try?)] - [(tdrivers tguide) - (if (null? tail) - (values (dset) #f) - (parse-t tail depth esc? in-try?))]) - (when (dset-empty? hdrivers) - (wrong-syntax head "no pattern variables before ellipsis in template")) - (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) - (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one - (stx-car (stx-drop nesting t))]) - ;; FIXME: improve error message? - (wrong-syntax bad-dots "too many ellipses in template"))) - ;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level - (define hdriverss ;; per level - (for/list ([i (in-range nesting)]) - (dset-filter hdrivers (pvar/dd<=? (+ depth i))))) - (define new-hdriverss ;; per level - (let loop ([raw hdriverss] [last (dset)]) - (cond [(null? raw) null] - [else - (define new-hdrivers (dset->list (dset-subtract (car raw) last))) - (cons new-hdrivers (loop (cdr raw) (car raw)))]))) - (values (dset-union hdrivers tdrivers) - (let ([cons? (ht-guide? hguide)] - [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) - (resyntax t `(t-dots ,hguide ,new-hdriverss ,nesting ,tguide ,cons? ,in-try?))))))) - - ;; parse-t-pair/normal : Stx Nat Boolean Boolean -> ... - ;; t is a normal stx pair - (define (parse-t-pair/normal t depth esc? in-try?) - (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc? in-try?)) - (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc? in-try?)) - (values (dset-union hdrivers tdrivers) - (let ([kind (if (ht-guide? hguide) 't-cons/p 't-append/p)] - [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) - (resyntax t `(,kind ,hguide ,tguide))))) - - ;; parse-t-nonpair : Stx Nat Boolean Boolean -> ... - ;; PRE: t is not a stxpair - (define (parse-t-nonpair t depth esc? in-try?) - (syntax-case t (?? ?@) - [id - (identifier? #'id) - (cond [(and (not esc?) - (or (free-identifier=? #'id (quote-syntax ...)) - (free-identifier=? #'id (quote-syntax ??)) - (free-identifier=? #'id (quote-syntax ?@)))) - (wrong-syntax #'id "illegal use")] - [(lookup-metafun #'id) - (wrong-syntax t "illegal use of syntax metafunction")] - [(lookup #'id depth) - => (lambda (pvar) (values (dset pvar) `(t-var ,pvar ,in-try?)))] - [else (values (dset) const-guide)])] - [vec - (vector? (syntax-e #'vec)) - (let-values ([(drivers guide) - (parse-t (vector->list (syntax-e #'vec)) depth esc? in-try?)]) - (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-vector ,guide)))))] - [pstruct - (prefab-struct-key (syntax-e #'pstruct)) - (let-values ([(drivers guide) - (let ([elems (cdr (vector->list (struct->vector (syntax-e #'pstruct))))]) - (parse-t elems depth esc? in-try?))]) - (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-struct ,guide)))))] - [#&template - (let-values ([(drivers guide) - (parse-t #'template depth esc? in-try?)]) - (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-box ,guide)))))] - [const - (values (dset) const-guide)])) - - ;; parse-h : Syntax Nat Boolean Boolean -> (values (dsetof PVar) HeadGuide) - (define (parse-h h depth esc? in-try?) - (syntax-case h (?? ?@ ?@!) - [(?? t) - (not esc?) - (let-values ([(drivers guide) (parse-h #'t depth esc? #t)]) - (values drivers `(h-orelse ,guide #f)))] - [(?? t1 t2) - (not esc?) - (let-values ([(drivers1 guide1) (parse-h #'t1 depth esc? #t)] - [(drivers2 guide2) (parse-h #'t2 depth esc? in-try?)]) - (values (dset-union drivers1 drivers2) - (if (and (ht-guide? guide1) (ht-guide? guide2)) - `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2))) - `(h-orelse ,guide1 ,guide2))))] - [(?@ . _) - (not esc?) - (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)]) - (values drivers `(h-splice ,guide)))] - [(?@! . _) - (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)]) - (values drivers `(h-splice ,guide)))] - [t - (let-values ([(drivers guide) (parse-t #'t depth esc? in-try?)]) - (values drivers `(h-t ,guide)))])) - - ;; lookup : Identifier Nat -> PVar/#f - (define (lookup id depth) - (define variable? (if stx? syntax-pattern-variable? s-exp-pattern-variable?)) - (let ([v (syntax-local-value/record id variable?)]) - (cond [(syntax-pattern-variable? v) - (hash-ref! env (cons v depth) - (lambda () - (define pvar-depth (syntax-mapping-depth v)) - (define attr - (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) - (and (attribute-mapping? attr) attr))) - (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) - (define check? (and attr (not (attribute-mapping-syntax? attr)))) - (cond [(zero? pvar-depth) - (pvar var var check? #f)] - [(>= depth pvar-depth) - (define lvar (car (generate-temporaries #'(pv_)))) - (pvar var lvar check? (- depth pvar-depth))] - [else - (wrong-syntax id "missing ellipses with pattern variable in template")])))] - [(s-exp-pattern-variable? v) - (hash-ref! env (cons v depth) - (lambda () - (define pvar-depth (s-exp-mapping-depth v)) - (define var (s-exp-mapping-valvar v)) - (define check? #f) - (cond [(zero? pvar-depth) - (pvar var var #f #f)] - [(>= depth pvar-depth) - (define lvar (car (generate-temporaries #'(pv_)))) - (pvar var lvar #f (- depth pvar-depth))] - [else - (wrong-syntax id "missing ellipses with pattern variable in template")])))] - [else - ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute - (for ([pfx (in-list (dotted-prefixes id))]) - (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) - (when (and (syntax-pattern-variable? pfx-v) - (let ([valvar (syntax-mapping-valvar pfx-v)]) - (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) - (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) - #f]))) - - ;; resyntax : Stx Guide -> Guide - (define (resyntax t g) (if (and stx? (syntax? t)) `(t-resyntax ,g) g)) - - (let-values ([(drivers guide) (parse-t t 0 #f #f)]) - (values (dset->list drivers) guide))) - - ;; lookup-metafun : Identifier -> Metafunction/#f - (define (lookup-metafun id) - (syntax-local-value/record id template-metafunction?)) - - (define (dotted-prefixes id) - (let* ([id-string (symbol->string (syntax-e id))] - [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))]) - (for/list ([loc (in-list dot-locations)]) - (datum->syntax id (string->symbol (substring id-string 0 loc)))))) - - (define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...)))) - - (define (cons/p-guide g1 g2) - (if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons/p ,g1 ,g2))) - - (define ((pvar/dd<=? expected-dd) x) - (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))) - - (define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) - - (define (restx ctx v) (if (syntax? ctx) (datum->syntax ctx v ctx ctx) v)) - - ;; ---------------------------------------- - ;; Relocating (eg, template/loc) - - ;; Only relocate if relocation would affect a syntax pair originating - ;; from template structure. For example: - ;; (template/loc loc-stx (1 2 3)) => okay - ;; (template/loc loc-stx pvar) => don't relocate - - ;; relocate-guide : Guide Id -> Guide - (define (relocate-guide g0 loc-id) - (define (error/no-relocate) - (wrong-syntax #f "cannot apply syntax location to template")) - (define (loop g) - (match g - [(list 't-resyntax g1) - (list 't-resyntax/loc g1 loc-id)] - [(list 't-const) - `(t-relocate ,g ,loc-id)] - ;; ---- - [(list 't-escaped g1) - (list 't-escaped (loop g1))] - [(list 't-orelse g1 g2) - (list 't-orelse (loop g1) (loop g2))] - ;; ---- - ;; Variables shouldn't be relocated. - [(list 't-var pvar in-try?) g] - ;; ---- - ;; Otherwise, cannot relocate: t-metafun, anything else? - [_ (error/no-relocate)])) - (loop g0)) - - ;; ---------------------------------------- - ;; Compilation - - ;; compile-guide : Guide -> Syntax[Expr] - (define (compile-guide g) (datum->syntax #'here g)) - - ;; ---------------------------------------- - - ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax - (define (do-template ctx tstx loc-id stx?) - (with-disappeared-uses - (parameterize ((current-syntax-context ctx)) - (define-values (pvars pre-guide) (parse-template tstx stx?)) - (define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide)) - (syntax-arm - (with-syntax ([t tstx] - [quote-template (if stx? #'quote-syntax #'quote)] - [((var . pvar-val-var) ...) - (for/list ([pvar (in-list pvars)] #:when (pvar-dd pvar)) - (cons (pvar-lvar pvar) (pvar-var pvar)))]) - #`(let ([var pvar-val-var] ...) - (let ([tstx0 (quote-template t)]) - (#,(compile-guide guide) tstx0)))))))) - ) - -(define-syntax (template stx) - (syntax-case stx () - [(template t) - (do-template stx #'t #f #t)] - [(template t #:properties _) - (begin - (log-template-error "template #:properties argument no longer supported: ~e" stx) - (do-template stx #'t #f))])) - -(define-syntax (template/loc stx) - (syntax-case stx () - [(template/loc loc-expr t) - (syntax-arm - (with-syntax ([main-expr (do-template stx #'t #'loc-var #t)]) - #'(let ([loc-var (handle-loc '?/loc loc-expr)]) - main-expr)))])) - - -(define-syntax (datum-template stx) - (syntax-case stx () - [(datum-template t) - (do-template stx #'t #f #f)])) - -(define (handle-loc who x) - (if (syntax? x) x (raise-argument-error who "syntax?" x))) - -;; ============================================================ - -(begin-for-syntax - ;; process-quasi : Syntax -> (list Syntax[with-syntax-bindings] Syntax[expr]) - (define (process-quasi t0) - (define bindings null) - (define (add! binding) (set! bindings (cons binding bindings))) - (define (process t depth) - (define (loop t) (process t depth)) - (define (loop- t) (process t (sub1 depth))) - (define (loop+ t) (process t (add1 depth))) - (syntax-case t (unsyntax unsyntax-splicing quasitemplate) - [(unsyntax expr) - (cond [(zero? depth) - (with-syntax ([(us) (generate-temporaries #'(us))] - [ctx (datum->syntax #'expr 'ctx #'expr)]) - (add! (list #'us #'(check-unsyntax expr (quote-syntax ctx)))) - #'us)] - [else - (restx t (cons (stx-car t) (loop- (stx-cdr t))))])] - [((unsyntax-splicing expr) . _) - (cond [(zero? depth) - (with-syntax ([(us) (generate-temporaries #'(us))] - [ctx (datum->syntax #'expr 'ctx #'expr)]) - (add! (list #'us #'(check-unsyntax-splicing expr (quote-syntax ctx)))) - (restx t (cons #'(?@! . us) (loop (stx-cdr t)))))] - [else - (let ([tcar (stx-car t)] - [tcdr (stx-cdr t)]) - (restx t (cons (restx tcar (cons (stx-car tcar) (loop- (stx-cdr tcar)))) - (loop tcdr))))])] - [(quasitemplate _) - (restx t (cons (stx-car t) (loop+ (stx-cdr t))))] - [unsyntax - (raise-syntax-error #f "misuse within quasitemplate" t0 t)] - [unsyntax-splicing - (raise-syntax-error #f "misuse within quasitemplate" t0 t)] - [_ - (let ([d (if (syntax? t) (syntax-e t) t)]) - (cond [(pair? d) (restx t (cons (loop (car d)) (loop (cdr d))))] - [(vector? d) (restx t (list->vector (loop (vector->list d))))] - [(box? d) (restx t (box (loop (unbox d))))] - [(prefab-struct-key d) - => (lambda (key) - (apply make-prefab-struct key (loop (cdr (vector->list (struct->vector d))))))] - [else t]))])) - (define t* (process t0 0)) - (list (reverse bindings) t*))) - -(define-syntax (quasitemplate stx) - (syntax-case stx () - [(quasitemplate t) - (with-syntax ([(bindings t*) (process-quasi #'t)]) - #'(with-syntax bindings (template t*)))])) - -(define-syntax (quasitemplate/loc stx) - (syntax-case stx () - [(quasitemplate/loc loc-expr t) - (with-syntax ([(bindings t*) (process-quasi #'t)]) - #'(with-syntax bindings - (template/loc (handle-loc 'quasitemplate/loc loc-expr) t*)))])) - -(define (check-unsyntax v ctx) - (datum->syntax ctx v ctx)) -(define (check-unsyntax-splicing v ctx) - (unless (stx-list? v) (raise-argument-error 'unsyntax-splicing "syntax->list" v)) - (datum->syntax ctx v ctx)) +(require (for-syntax racket/base) + (only-in racket/private/template + metafunction)) +(provide (rename-out [syntax template] + [syntax/loc template/loc] + [quasisyntax quasitemplate] + [quasisyntax/loc quasitemplate/loc]) + ?? ?@ + define-template-metafunction) ;; ============================================================ +;; Metafunctions (define-syntax (define-template-metafunction stx) (syntax-case stx () @@ -495,191 +19,17 @@ [(dsm id expr) (identifier? #'id) (with-syntax ([(internal-id) (generate-temporaries #'(id))]) - #'(begin (define internal-id expr) - (define-syntax id - (template-metafunction (quote-syntax internal-id)))))])) - - -;; ============================================================ -;; Run-time support - -;; Template transcription involves traversing the template syntax object, -;; substituting pattern variables etc. The interpretation of the template is -;; known at compile time, but we still need the template syntax at run time, -;; because it is the basis for generated syntax objects (via datum->syntax). - -;; A template fragment (as opposed to the whole template expression) is compiled -;; to a function of type (Stx -> Stx). It receives the corresponding template -;; stx fragment as its argument. Pattern variables are passed through the -;; environment. We rely on Racket's inliner and optimizer to simplify the -;; resulting code to nearly first-order so that a new tree of closures is not -;; allocated for each template transcription. - -;; Note: as an optimization, we track syntax vs non-syntax pairs in the template -;; so we can generate more specific code (hopefully smaller and faster). - -(define-syntax (t-var stx) - (syntax-case stx () - [(t-var #s(pvar var lvar check? _) in-try?) - (cond [(syntax-e #'check?) - #`(lambda (stx) (check-stx stx lvar in-try?))] - [else - #`(lambda (stx) lvar)])])) - -(define-syntax (t-dots stx) - (syntax-case stx () - ;; Case 1: (x ...) where x is trusted. - [(t-dots (t-var #s(pvar _ lvar #f _) _) _drivers 1 #f #t _) - (begin - (log-template-debug "dots case 1: (x ...) where x is trusted") - #'(lambda (stx) lvar))] - ;; General case - [(t-dots head ((#s(pvar _ lvar check? _) ...) ...) nesting tail cons? in-try?) - (let ([cons? (syntax-e #'cons?)] - [lvarss (map syntax->list (syntax->list #'((lvar ...) ...)))] - [check?ss (syntax->datum #'((check? ...) ...))]) - (log-template-debug "dots general case: nesting = ~s, cons? = ~s, #vars = ~s" - (syntax-e #'nesting) cons? (apply + (map length lvarss))) - ;; AccElem = Stx if cons? is true, (Listof Stx) otherwise - ;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)] - ;; -> Syntax[(Listof AccElem) -> (Listof AccElem)] - (define (gen-level lvars check?s inner) - (with-syntax ([(lvar ...) lvars] - [(var-value ...) (map var-value-expr lvars check?s)]) - #`(lambda (acc) - (let loop ([acc acc] [lvar var-value] ...) - (check-same-length lvar ...) - (if (and (pair? lvar) ...) - (loop (let ([lvar (car lvar)] ...) - (#,inner acc)) ;; inner has free refs to {var ...} - (cdr lvar) ...) - acc))))) - ;; var-value-expr : Id Boolean -> Syntax[List] - (define (var-value-expr lvar check?) - (if check? #`(check-list/depth stx #,lvar 1 in-try?) lvar)) - (define head-loop-code - (let nestloop ([lvarss lvarss] [check?ss check?ss] [old-lvars null] [old-check?s null]) - (cond [(null? lvarss) - #'(lambda (acc) (cons (head stx) acc))] - [else - (define lvars* (append (car lvarss) old-lvars)) - (define check?s* (append (car check?ss) old-check?s)) - (gen-level lvars* check?s* - (nestloop (cdr lvarss) (cdr check?ss) lvars* check?s*))]))) - (if cons? - #`(t-dots1* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const))) - #`(t-dots* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))))])) - -(begin-encourage-inline - -(define (stx-cadr x) (stx-car (stx-cdr x))) -(define (stx-cddr x) (stx-cdr (stx-cdr x))) -(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x)))) -(define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) -(define (restx basis val) - (if (syntax? basis) (datum->syntax basis val basis basis) val)) - -(define ((t-resyntax g) stx) (datum->syntax stx (g (syntax-e stx)) stx stx)) -(define ((t-relocate g loc) stx) - (define new-stx (g stx)) - (datum->syntax new-stx (syntax-e new-stx) loc new-stx)) -(define ((t-resyntax/loc g loc) stx) - (datum->syntax stx (g (syntax-e stx)) loc stx)) - -(define ((t-const) stx) stx) -(define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx)))) -(define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx)))) -(define ((t-dots* h n t) stx) (revappend* (h (car stx)) (t (stx-drop (add1 n) stx)))) -(define ((t-dots1* h n t) stx) (revappend (h (car stx)) (t (stx-drop (add1 n) stx)))) -(define ((t-escaped g) stx) (g (stx-cadr stx))) -(define ((t-orelse g1 g2) stx) - (with-handlers ([absent-pvar? (lambda (e) (if g2 (g2 (stx-caddr stx)) null))]) - (g1 (stx-cadr stx)))) -(define ((t-vector g) stx) (list->vector (g (vector->list stx)))) -(define ((t-box g) stx) (box (g (unbox stx)))) -(define ((t-struct g) stx) - (define key (prefab-struct-key stx)) - (define elems (cdr (vector->list (struct->vector stx)))) - (apply make-prefab-struct key (g elems))) -(define ((t-metafun mf g) stx) - (define stx* (if (syntax? stx) stx (datum->syntax #f stx))) - (define v (restx stx* (cons (stx-car stx) (g (stx-cdr stx))))) - (apply-metafun mf stx* v)) -(define ((h-t g) stx) (list (g stx))) -(define (h-orelse g1 g2) (t-orelse g1 g2)) -(define ((h-splice g) stx) - (let ([r (g (stx-cdr stx))]) - (or (stx->list r) (error/splice stx r)))) -#| end begin-encourage-inline |#) - -(define (apply-metafun mf stx v) - (define mark (make-syntax-introducer)) - (define old-mark (current-template-metafunction-introducer)) - (parameterize ((current-template-metafunction-introducer mark)) - (define r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))) - (unless (syntax? r) - (raise-syntax-error #f "result of template metafunction was not syntax" stx)) - (old-mark (mark r)))) - -(define (error/splice stx r) - (raise-syntax-error 'template "splicing template did not produce a syntax list" stx)) - -;; revappend* : (Listof (Listof X)) (Listof X) -> (Listof X) -(define (revappend* xss ys) - (if (null? xss) ys (revappend* (cdr xss) (append (car xss) ys)))) - -;; revappend : (Listof X) (Listof X) -> (Listof X) -(define (revappend xs ys) - (if (null? xs) ys (revappend (cdr xs) (cons (car xs) ys)))) + #'(begin (define internal-id (make-hygienic-metafunction expr)) + (define-syntax id (metafunction (quote-syntax internal-id)))))])) (define current-template-metafunction-introducer (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) -;; Used to indicate absent pvar in template; ?? catches -;; Note: not an exn, don't need continuation marks -(struct absent-pvar (ctx)) - -(define (check-stx ctx v in-try?) - (cond [(syntax? v) v] - [(promise? v) (check-stx ctx (force v) in-try?)] - [(and in-try? (eq? v #f)) (raise (absent-pvar ctx))] - [else (err/not-syntax ctx v)])) - -(define (check-list/depth ctx v0 depth0 in-try?) - (let depthloop ([v v0] [depth depth0]) - (cond [(zero? depth) v] - [(and (= depth 1) (list? v)) v] - [else - (let loop ([v v]) - (cond [(null? v) - null] - [(pair? v) - (let ([new-car (depthloop (car v) (sub1 depth))] - [new-cdr (loop (cdr v))]) - ;; Don't copy unless necessary - (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v))) - v - (cons new-car new-cdr)))] - [(promise? v) - (loop (force v))] - [(and in-try? (eq? v #f)) - (raise (absent-pvar ctx))] - [else (err/not-syntax ctx v0)]))]))) - -;; FIXME: use raise-syntax-error instead, pass stx args -(define check-same-length - (case-lambda - [(a) (void)] - [(a b) - (unless (= (length a) (length b)) - (error 'syntax "incompatible ellipsis match counts for template"))] - [(a . bs) - (define alen (length a)) - (for ([b (in-list bs)]) - (unless (= alen (length b)) - (error 'template "incompatible ellipsis match counts for template")))])) - -;; Note: slightly different from error msg in syntax/parse/private/residual: -;; here says "contains" instead of "is bound to", because might be within list -(define (err/not-syntax ctx v) - (raise-syntax-error #f (format "attribute contains non-syntax value\n value: ~e" v) ctx)) +(define ((make-hygienic-metafunction transformer) stx) + (define mark (make-syntax-introducer)) + (define old-mark (current-template-metafunction-introducer)) + (parameterize ((current-template-metafunction-introducer mark)) + (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx)))))) + (unless (syntax? r) + (raise-syntax-error #f "result of template metafunction was not syntax" stx)) + (old-mark (mark r)))) diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt index a1fe5ff2d7..27e503780e 100644 --- a/racket/collects/syntax/parse/private/residual.rkt +++ b/racket/collects/syntax/parse/private/residual.rkt @@ -10,35 +10,8 @@ (require (for-syntax racket/private/sc "residual-ct.rkt")) (provide (for-syntax (all-from-out "residual-ct.rkt"))) -(begin-for-syntax - ;; == from runtime.rkt - - (provide make-attribute-mapping - attribute-mapping? - attribute-mapping-var - attribute-mapping-name - attribute-mapping-depth - attribute-mapping-syntax?) - - (define-struct attribute-mapping (var name depth syntax?) - #:omit-define-syntaxes - #:property prop:procedure - (lambda (self stx) - (if (attribute-mapping-syntax? self) - #`(#%expression #,(attribute-mapping-var self)) - (let ([source-name - (or (let loop ([p (syntax-property stx 'disappeared-use)]) - (cond [(identifier? p) p] - [(pair? p) (or (loop (car p)) (loop (cdr p)))] - [else #f])) - (attribute-mapping-name self))]) - #`(let ([value #,(attribute-mapping-var self)]) - (if (syntax-list^depth? '#,(attribute-mapping-depth self) value) - value - (check/force-syntax-list^depth '#,(attribute-mapping-depth self) - value - (quote-syntax #,source-name)))))))) - ) +(require racket/private/template) +(provide (for-syntax attribute-mapping attribute-mapping?)) ;; ============================================================ ;; Run-time @@ -54,10 +27,10 @@ this-context-syntax attribute attribute-binding + check-attr-value stx-list-take stx-list-drop/cx datum->syntax/with-clause - check/force-syntax-list^depth check-literal* error/null-eh-match begin-for-syntax/once @@ -113,7 +86,7 @@ (if (attribute-mapping? value) #`(quote #,(make-attr (attribute-mapping-name value) (attribute-mapping-depth value) - (attribute-mapping-syntax? value))) + (if (attribute-mapping-check value) #f #t))) #'(quote #f))) #'(quote #f)))])) @@ -136,60 +109,28 @@ (if (syntax? x) x cx) (sub1 n))))) -;; check/force-syntax-list^depth : nat any id -> (listof^depth syntax) -;; Checks that value is (listof^depth syntax); forces promises. -;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already. -(define (check/force-syntax-list^depth depth value0 source-id) - (define (bad sub-depth sub-value) - (attribute-not-syntax-error depth value0 source-id sub-depth sub-value)) - (define (loop depth value) - (cond [(promise? value) - (loop depth (force value))] - [(zero? depth) - (if (syntax? value) value (bad depth value))] - [else (loop-list depth value)])) - (define (loop-list depth value) - (cond [(promise? value) - (loop-list depth (force value))] - [(pair? value) - (let ([new-car (loop (sub1 depth) (car value))] - [new-cdr (loop-list depth (cdr value))]) - ;; Don't copy unless necessary - (if (and (eq? new-car (car value)) - (eq? new-cdr (cdr value))) - value - (cons new-car new-cdr)))] - [(null? value) - null] - [else - (bad depth value)])) - (loop depth value0)) - -(define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value) - (raise-syntax-error #f - (format (string-append "bad attribute value for syntax template" - "\n attribute value: ~e" - "\n expected for attribute: ~a" - "\n sub-value: ~e" - "\n expected for sub-value: ~a") - value0 - (describe-depth depth0) - sub-value - (describe-depth sub-depth)) - source-id)) - -(define (describe-depth depth) - (cond [(zero? depth) "syntax"] - [else (format "list of depth ~s of syntax" depth)])) - -;; syntax-list^depth? : nat any -> boolean -;; Returns true iff value is (listof^depth syntax). -(define (syntax-list^depth? depth value) - (if (zero? depth) - (syntax? value) - (and (list? value) - (for/and ([part (in-list value)]) - (syntax-list^depth? (sub1 depth) part))))) +;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) +(define (check-attr-value v0 depth0 base? ctx) + (define (bad kind v) + (raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx)) + (define (depthloop depth v) + (if (zero? depth) + (if base? (baseloop v) v) + (let listloop ([v v] [root? #t]) + (cond [(null? v) null] + [(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))] + [new-cdr (listloop (cdr v) #f)]) + (cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v] + [else (cons new-car new-cdr)]))] + [(promise? v) (listloop (force v) root?)] + [(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))] + [else (bad 'list v)])))) + (define (baseloop v) + (cond [(syntax? v) v] + [(promise? v) (baseloop (force v))] + [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))] + [else (bad 'syntax v)])) + (depthloop depth0 v0)) ;; datum->syntax/with-clause : any -> syntax (define (datum->syntax/with-clause x) diff --git a/racket/collects/syntax/parse/private/runtime.rkt b/racket/collects/syntax/parse/private/runtime.rkt index 709b686bc0..d100d2c564 100644 --- a/racket/collects/syntax/parse/private/runtime.rkt +++ b/racket/collects/syntax/parse/private/runtime.rkt @@ -106,8 +106,9 @@ residual.rkt. (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] [(stmp ...) (generate-temporaries #'(name ...))]) #'(letrec-syntaxes+values - ([(stmp) (make-attribute-mapping (quote-syntax vtmp) - 'name 'depth 'syntax?)] ...) + ([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth + (if 'syntax? #f (quote-syntax check-attr-value)))] + ...) ([(vtmp) value] ...) (letrec-syntaxes+values ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) @@ -143,8 +144,8 @@ residual.rkt. [(stmp ...) (generate-temporaries #'(name ...))]) #'(begin (define-values (vtmp ...) (apply values packed)) (define-syntax stmp - (make-attribute-mapping (quote-syntax vtmp) - 'name 'depth 'syntax?)) + (attribute-mapping (quote-syntax vtmp) 'name 'depth + (if 'syntax? #f (quote-syntax check-attr-value)))) ... (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) ...)))]))