diff --git a/ddd-forms.rkt b/ddd-forms.rkt
index 3dbe0c9..58e7487 100644
--- a/ddd-forms.rkt
+++ b/ddd-forms.rkt
@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/base
(provide begin
define
let
@@ -7,7 +7,8 @@
??
?@)
-(require subtemplate/ddd
+(require racket/list
+ subtemplate/ddd
stxparse-info/case
stxparse-info/parse
phc-toolkit/untyped
@@ -15,7 +16,8 @@
begin let lambda define))
(prefix-in - (only-in stxparse-info/case
define/with-syntax))
- (for-syntax racket/list
+ (for-syntax racket/base
+ racket/list
stxparse-info/parse
stxparse-info/parse/experimental/template
phc-toolkit/untyped)
@@ -104,10 +106,12 @@
[{~and (_ fn arg:arg …)
{~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
;#'(#%app apply fn (#%app append arg.expanded …))
- #'(#%app apply fn (#%app splice-append arg.expanded …))]
+ (syntax/top-loc this-syntax
+ (#%app apply fn (#%app splice-append arg.expanded …)))]
[(_ arg:arg …) ;; shorthand for list creation
;#'(#%app apply list (#%app append arg.expanded …))
- #'(#%app apply list (#%app splice-append arg.expanded …))]))
+ (syntax/top-loc this-syntax
+ (#%app apply list (#%app splice-append arg.expanded …)))]))
(define (splice-append . l*) (splice-append* l*))
(define (splice-append* l*)
diff --git a/info.rkt b/info.rkt
index d8c9079..5c45faa 100644
--- a/info.rkt
+++ b/info.rkt
@@ -13,4 +13,4 @@
(define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library))))
(define pkg-desc "Description Here")
(define version "0.0")
-(define pkg-authors '(georges))
+(define pkg-authors '("Georges Dupéron"))
diff --git a/main.rkt b/main.rkt
index b3467da..7bc35af 100644
--- a/main.rkt
+++ b/main.rkt
@@ -1,493 +1 @@
-#lang racket
-
-(require racket/require
- phc-toolkit/untyped
- phc-toolkit/untyped-only/syntax-parse
- racket/stxparam
- stxparse-info/parse
- stxparse-info/case
- stxparse-info/current-pvars
- stxparse-info/parse/experimental/template
- (prefix-in - stxparse-info/parse/private/residual)
- (prefix-in dbg: stxparse-info/parse/private/runtime)
- syntax/id-table
- (subtract-in racket/syntax stxparse-info/case)
- "copy-attribute.rkt"
- (for-syntax "patch-arrows.rkt"
- racket/format
- stxparse-info/parse
- racket/private/sc
- racket/syntax
- racket/list
- racket/function
- phc-toolkit/untyped
- syntax/strip-context
- srfi/13
- (subtract-in racket/string srfi/13)
- syntax/contract
- racket/contract))
-
-(provide subtemplate
- quasisubtemplate)
-
-(define derived-valvar-cache (make-weak-hash))
-
-(begin-for-syntax
- (define/contract (string-suffix a b)
- (-> string? string? string?)
- (define suffix-length (string-suffix-length a b))
- (substring a
- (- (string-length a) suffix-length)))
-
- (define/contract (subscript-binder? bound binder)
- (-> identifier? identifier? (or/c #f string?))
- (and (syntax-pattern-variable?
- (syntax-local-value binder
- (thunk #f)))
- (let* ([bound-string (symbol->string (syntax-e bound))]
- [binder-string (symbol->string (syntax-e binder))]
- [suffix (string-suffix bound-string binder-string)]
- [subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)])
- (and subs (car subs)))))
-
- (define/contract (extract-subscripts id)
- (-> identifier? string?)
- (car (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$"
- (symbol->string (syntax-e id)))))
-
- (define/contract (subscript-equal? bound binder)
- (-> identifier? identifier? (or/c #f string?))
- (let* ([binder-subscripts (extract-subscripts binder)]
- [bound-subscripts (extract-subscripts bound)])
- (and (string=? binder-subscripts bound-subscripts)
- (not (string=? binder-subscripts ""))
- binder-subscripts)))
-
- (define/contract (drop-subscripts id)
- (-> identifier? identifier?)
- (let* ([str (symbol->string (syntax-e id))]
- [sub (extract-subscripts id)]
- [new-str (substring str 0 (- (string-length str)
- (string-length sub)))])
- (datum->syntax id (string->symbol new-str) id id)))
-
- (define/contract (nest-ellipses stx n)
- (-> syntax? exact-nonnegative-integer? syntax?)
- (if (= n 0)
- stx
- #`(#,(nest-ellipses stx (sub1 n))
- (… …))))
-
- (define/contract (find-subscript-binder bound)
- (-> identifier?
- (or/c #f (list/c identifier? ; bound
- (syntax/c (listof identifier?)) ; binders
- (syntax/c (listof identifier?)) ; unique-at-runtime ids
- exact-nonnegative-integer?))) ; ellipsis-depth
-
- (let/cc return
- ;; EARLY RETURN (already a pattern variable)
- (when (syntax-pattern-variable?
- (syntax-local-value bound (thunk #f)))
- (return #f))
-
- (define/with-syntax ([binder . unique-at-runtime-id] …)
- (filter (compose (conjoin identifier?
- (λ~> (syntax-local-value _ (thunk #f))
- syntax-pattern-variable?)
- ;; force call syntax-local-value to prevent
- ;; ambiguous bindings, as syntax-local-value
- ;; triggers an error for those.
- ;; Must be done before the free-identifier=?
- ;; which just returns #false
- (λ~> (datum->syntax _ (syntax-e bound))
- (syntax-local-value _ (thunk #f))
- (thunk* #t)) ;; ok if no error.
- (λ~> (datum->syntax _ (syntax-e bound))
- (free-identifier=? _ bound))
- (λ~> (subscript-equal? bound _)))
- car)
- (current-pvars+unique)))
-
- ;; Or write it as:
-
- #;(define/with-syntax ([binder . unique-at-runtime] …)
- (for/list ([binder (current-pvars+unique)]
- #:when (identifier? (car binder))
- #:when (syntax-pattern-variable?
- (syntax-local-value (car binder) (thunk #f)))
- ;; force call syntax-local-value to prevent ambiguous
- ;; bindings, as syntax-local-value triggers an error for
- ;; those.
- ;; Must be done before the free-identifier=? which just
- ;; returns #false
- #:when (begin
- (syntax-local-value
- (datum->syntax _ (syntax-e bound))
- (thunk #f))
- #t) ;; ok if no error.
- #:when (free-identifier=? (datum->syntax (car binder)
- (syntax-e bound))
- bound)
- #:when (subscript-equal? bound (car binder)))
- binder))
-
- ;; EARLY RETURN (no candidate binders found)
- (when (stx-null? #'(binder …))
- (return #f))
-
- (define depths
- (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
-
- ;; EARLY ERROR (inconsistent depths)
- (unless (or (< (length depths) 2) (apply = depths))
- (car depths)
- (raise-syntax-error 'subtemplate
- (format "inconsistent depths: ~a"
- (syntax->list #'(binder …)))
- bound))
-
- ;; FINAL RETURN (list of same-depth binders + their depth)
- (return (list bound
- #'(binder …)
- #'(unique-at-runtime-id …)
- (car depths))))))
-
-;; Checks that all the given attribute values have the same structure.
-;;
-;; ellipsis-count/c works with the value of pattern variables and of attributes
-;; too, including those missing (optional) elements in the lists, at any level.
-;;
-;; The lists must have the same lengths across all attribute values, including
-;; the missing #f elements.
-;;
-;; If same-shape is #true, a #f in one attribute value implies #f in all other
-;; attribute values at the same position. The same-shape check is not
-;; performed on the bottommost #f values (as they do not influence the shape of
-;; the tree).
-(define/contract (ellipsis-count/c depth
- [bottom-predicate any/c]
- #:same-shape [same-shape #f])
- (->* {exact-nonnegative-integer?}
- {flat-contract?
- #:same-shape boolean?}
- flat-contract?)
- ;; Must be lazy, otherwise ellipsis-count/c would immediately call itself
- (define (recur/c sublists)
- ((ellipsis-count/c (sub1 depth) bottom-predicate #:same-shape same-shape)
- sublists))
- (flat-named-contract
- (apply build-compound-type-name
- (list* 'ellipsis-count/c depth bottom-predicate
- (if same-shape
- (list '#:same-shape same-shape)
- (list))))
- (λ (l*)
- (true?
- (and (list? l*)
- (if (and same-shape (> depth 0))
- (or (andmap false? l*) ;; all #f
- (andmap identity l*)) ;; all non-#f
- #t)
- (let ([l* (filter identity l*)])
- (if (= depth 0)
- (andmap bottom-predicate l*)
- (let ([lengths (map length l*)])
- (and (or (< (length lengths) 2) (apply = lengths))
- (or (empty? l*)
- (apply andmap
- (λ sublists
- (recur/c sublists))
- l*)))))))))))
-
-(define/contract (map-merge-stx-depth f l* depth)
- (->i {[f (-> (listof any/c) any/c)]
- [l* (depth) (ellipsis-count/c depth any/c)]
- [depth exact-nonnegative-integer?]}
- {result (depth l*)
- (λ (r) ((ellipsis-count/c depth) (cons r l*)))})
- (let ([l* (filter identity l*)])
- (if (= depth 0)
- (f l*)
- (if (empty? l*)
- #f
- (apply map
- (λ sublists
- (map-merge-stx-depth f
- sublists
- (sub1 depth)))
- l*)))))
-
-(define-for-syntax (sub*template self-form tmpl-form)
- (syntax-parser
- [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}}
- {~optkw #:props (prop:id ...)}
- ;; #: marks end of options (so that we can have implicit ?@ later)
- {~optional #:}
- tmpl)
- (unless (attribute force-no-stxinfo)
- (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser
- syntax-case define/with-syntax with-syntax))])
- (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))]
- [good (datum->syntax #'here sym)])
- (when (or (not (identifier-binding shadower))
- (not (free-identifier=? shadower good)))
- (raise-syntax-error self-form
- (~a sym (if (identifier-binding shadower)
- (~a " resolves to the official "
- sym ",")
- " seems undefined,")
- " but subtemplate needs the patched"
- " version from stxparse-info. Use (require"
- " stxparse-info/parse) and (require"
- " stxparse-info/case) to fix this. This"
- " message can be disabled with (" self-form
- " #:force-no-stxinfo …), if you know what"
- " you're doing."))))))
-
- (define acc '())
-
- ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ
- ;; bindings
- (define (fold-process stx rec)
- (syntax-case stx ()
- [(id . _) (and (identifier? #'id)
- (free-identifier=? #'id #'unsyntax))
- stx]
- [id (identifier? #'id)
- (let ([binders+info (find-subscript-binder #'id)])
- (when binders+info
- (set! acc (cons binders+info acc)))
- #'id)]
- [other (rec #'other)]))
- ;; Process the syntax, extract the derived bindings into acc
- ;; Does not take zᵢ identifiers generated by template metafunctions into
- ;; account for now.
- (fold-syntax fold-process #'tmpl)
-
- ;; define the result, which looks like (template . tmpl) or
- ;; like (quasitemplate . tmpl)
- (define result
- (quasisyntax/top-loc #'self
- (#,tmpl-form tmpl
- #,@(if (attribute props) #'(#:props (prop ...)) #'()))))
- ;; Make sure that we remove duplicates, otherwise we'll get errors if we
- ;; define the same derived id twice.
- (define/with-syntax ([bound
- (binder …)
- unique-at-runtime-ids
- ellipsis-depth]
- …)
- (remove-duplicates acc bound-identifier=? #:key car))
-
- (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate))
-
- #`(let-values ()
- (define-values (whole-form-id) (quote-syntax #,this-syntax))
- (derive
- bound (binder …) unique-at-runtime-ids ellipsis-depth whole-form-id)
- …
- (let-values ()
- ;; check that all the binders for a given bound are compatible.
- ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) …
- ;; actually call template or quasitemplate
- #,result))]))
-
-(define-syntax subtemplate
- (sub*template 'subtemplate #'template))
-(define-syntax quasisubtemplate
- (sub*template 'quasisubtemplate #'quasitemplate))
-
-(define/contract (multi-hash-ref! h keys to-set)
- ;; This assumes that the hash does not get mutated during the execution of
- ;; this function.
- (-> (and/c (hash/c symbol? any/c #:immutable #f) hash-weak?)
- (listof symbol?)
- any/c
- any/c)
- (define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f))
- to-set))
- ;; Set the existing value (or new to-set if none) on all keys which
- ;; are not present in the hash table.
- (for ([k (in-list keys)]) (hash-ref! h k val))
- val)
-
-(define formattable/c (or/c number? string? symbol? bytes?))
-
-(define/contract
- (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form)
- (->i {[depth exact-nonnegative-integer?]
- [bound identifier?]
- [binder₀ identifier?]
- [format (-> formattable/c string?)]
- [l* (depth) (listof (attribute-val/c depth))]
- [attribute-names (l*) (and/c (listof identifier?)
- (λ (a) (= (length l*) (length a))))]
- [whole-form syntax?]}
- #:pre (l* depth attribute-names whole-form bound)
- (if ((ellipsis-count/c depth) l*)
- #t
- (raise-syntax-error
- (syntax-case whole-form ()
- [(self . _) (syntax-e #'self)]
- [_ 'subtemplate])
- "incompatible ellipsis match counts for subscripted variables:"
- whole-form
- bound
- attribute-names))
- {result (depth l*)
- (and/c (attribute-val/c depth identifier?)
- (λ (r) ((ellipsis-count/c depth) (cons r l*))))})
-
-
- (define (gen bottom*)
- (define v
- (let ([vs (filter-map (λ (v)
- (cond [(formattable/c v) v]
- [(formattable/c (syntax-e v)) (syntax-e v)]
- [else #f]))
- bottom*)])
- (if (empty? vs)
- (syntax-e (generate-temporary binder₀))
- (car vs))))
- (datum->syntax ((make-syntax-introducer) bound)
- (string->symbol (format v))))
-
- (map-merge-stx-depth gen l* depth))
-
-(define-syntax/case (derive bound
- (binder₀ binderᵢ …)
- (unique-at-runtime-idᵢ …)
- ellipsis-depth
- whole-form-id) ()
- (define depth (syntax-e #'ellipsis-depth))
- (define/with-syntax bound-ddd (nest-ellipses #'bound depth))
- (define/with-syntax tmp-id
- (format-id #'here "~a/~a" #'binder₀ (drop-subscripts #'bound)))
- (define/with-syntax tmp-str
- (datum->syntax #'tmp-id
- (symbol->string
- (syntax-e
- (format-id #'here "~~a/~a" (drop-subscripts #'bound))))))
- (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
- (define/with-syntax binder-ddd (nest-ellipses #'binder₀ depth))
-
- ;; Draw arrows in DrRacket.
- (with-arrows
- (define subscripts (subscript-equal? #'bound #'binder₀))
- (define bound-id-str (identifier->string #'bound))
- (for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))])
- (define binder-id-str (identifier->string binder))
- (record-sub-range-binders! (vector #'bound
- (- (string-length bound-id-str)
- (string-length subscripts))
- (string-length subscripts)
- binder
- (- (string-length binder-id-str)
- (string-length subscripts))
- (string-length subscripts))))
- #;(define binder0-id-str (identifier->string #'binder0))
- #;(record-sub-range-binders! (vector #'bound
- (- (string-length bound-id-str)
- (string-length subscripts))
- (string-length subscripts)
- #'binder0
- (- (string-length binder0-id-str)
- (string-length subscripts))
- (string-length subscripts)))
- (define/with-syntax temp-derived (generate-temporary #'bound))
- (define/with-syntax temp-valvar (generate-temporary #'bound))
- (define/with-syntax temp-cached (generate-temporary #'bound))
- (define/with-syntax temp-generated (generate-temporary #'bound))
- (define/with-syntax temp-id-table (generate-temporary #'bound))
- ;; HERE: cache the define-temp-ids in the free-id-table, and make sure
- ;; that we retrieve the cached ones, so that two subtemplate within the same
- ;; syntax-case or syntax-parse clause use the same derived ids.
- ;;
- ;; We mark specially those bindings bound by (derive …) so that they are
- ;; not seen as original bindings in nested subtemplates (e.g. with an
- ;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
- ;; (syntax-parse #'(a b c)
- ;; [(xᵢ …)
- ;; (quasisubtemplate (yᵢ …
- ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
- ;; zᵢ …))])
- ;; the test above is not exactly right (zᵢ will still have the correct
- ;; binding), but it gives the general idea.
- #`(begin
- (define-values (temp-generated)
- (generate-nested-ids 'ellipsis-depth
- (quote-syntax bound)
- (quote-syntax binder₀)
- (λ (v) (format tmp-str v))
- (list (attribute* binder₀)
- (attribute* binderᵢ)
- …)
- (list (quote-syntax binder₀)
- (quote-syntax binderᵢ)
- …)
- whole-form-id))
- (define-values (temp-id-table)
- (multi-hash-ref! derived-valvar-cache
- (list unique-at-runtime-idᵢ
- …)
- (make-free-id-table)))
- (define-values (temp-cached)
- (free-id-table-ref! temp-id-table
- (quote-syntax bound)
- temp-generated))
- ;; TODO: we should check that if the hash-table access worked,
- ;; any new pvars are compatible with the old ones on which the cache is
- ;; based (in the sense of "no new non-#f positions")
-
- ;; Check that all derived pvars for this subscript from all binders
- ;; have the same shape, i.e. we wouldn't want some elements to be missing
- ;; (as in ~optional) at some position from one derived pvar, but not from
- ;; others. This check implies that the original binder used did not
- ;; introduce new elements compared to the binders used for other derived
- ;; pvars, e.g:
- ;; (syntax-parse #'([1 2 3] #f)
- ;; [({~and {~or (xᵢ ...) #f}} ...)
- ;; (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
- ;; (syntax-case #'([a b c] [d e]) ()
- ;; ;; introduces elements [d e] which were unknown when yᵢ was
- ;; ;; generated:
- ;; [((wᵢ ...) ...)
- ;; ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
- ;; ;; inconsistent with the shape of yᵢ.
- ;; (subtemplate ({?? (zᵢ ...) _} ...))])])
- ;; The check must also compare temp-generated, even if it was not
- ;; assigned to #'bound, so that it also cathes the error if we replace
- ;; zᵢ with yᵢ in the example above.
- (unless ((ellipsis-count/c ellipsis-depth #:same-shape #t)
- (cons temp-generated
- (free-id-table-map temp-id-table (λ (k v) v))))
- ;; TODO: For now this will just blow up, a better error message would
- ;; be nice. Especially saying which one failed.
- (raise-syntax-error
- 'sublist
- (format (string-append
- "some derived variables do not have the same ellipsis"
- " shape\n"
- " depth: ~a\n"
- " attributes...:\n"
- " ~a\n"
- " attribute ~a if it were generated here...:\n"
- " ~a")
- 'ellipsis-depth
- (string-join (free-id-table-map
- temp-id-table
- (λ (k v)
- (format "~a => ~a"
- (syntax-e k)
- (syntax->datum
- (datum->syntax #f v)))))
- "\n ")
- 'bound
- (syntax->datum
- (datum->syntax #f temp-generated)))
- (quote-syntax whole-form-id)
- (quote-syntax bound)
- (free-id-table-map temp-id-table (λ (k v) k))))
-
- (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t))))
+#lang racket/base
diff --git a/override.rkt b/override.rkt
index 5539969..19b9705 100644
--- a/override.rkt
+++ b/override.rkt
@@ -1,6 +1,6 @@
#lang racket
(require racket/require
- (rename-in subtemplate
+ (rename-in subtemplate/template-subscripts
[subtemplate syntax]
[quasisubtemplate quasisyntax])
stxparse-info/parse
@@ -11,7 +11,7 @@
quasitemplate/loc)
stxparse-info/case
(subtract-in racket/syntax stxparse-info/case))
-(provide (all-from-out subtemplate
+(provide (all-from-out subtemplate/template-subscripts
stxparse-info/parse
stxparse-info/parse/experimental/template
stxparse-info/case
diff --git a/scribblings/subtemplate.scrbl b/scribblings/subtemplate.scrbl
index 108aaba..f2ca6f0 100644
--- a/scribblings/subtemplate.scrbl
+++ b/scribblings/subtemplate.scrbl
@@ -1,13 +1,13 @@
#lang scribble/manual
@require[scriblib/footnote
- @for-label[subtemplate
+ @for-label[subtemplate/template-subscripts
syntax/parse/experimental/template
racket/base]]
@title{Subtemplate}
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
-@defmodule[subtemplate]
+@defmodule[subtemplate/template-subscripts]
@defform*[{(subtemplate template)
(subtemplate template #:properties (prop ...))}
diff --git a/subscripts.rkt b/subscripts.rkt
new file mode 100644
index 0000000..3bd0f31
--- /dev/null
+++ b/subscripts.rkt
@@ -0,0 +1,147 @@
+#lang racket/base
+
+(provide subscript-equal?
+ drop-subscripts
+ find-subscript-binders)
+
+(require (for-template stxparse-info/current-pvars)
+ racket/private/sc
+ racket/function
+ racket/list
+ phc-toolkit/untyped
+ racket/contract
+ racket/string
+ racket/syntax)
+
+(define/contract (extract-subscripts id)
+ (-> identifier? string?)
+ (cadr (regexp-match #px".(_.+|[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*)$"
+ (symbol->string (syntax-e id)))))
+
+(define/contract (string-replace* str from* to*)
+ (->i ([str string?]
+ [from* (listof string?)]
+ [to* (from*)
+ (and/c (listof string?)
+ (λ (to*) (= (length from*) (length to*))))])
+ [range string?])
+ (if (null? from*)
+ str
+ (string-replace* (string-replace str (car from*) (car to*))
+ (cdr from*)
+ (cdr to*))))
+
+
+(define/contract (normalize-subscripts sub)
+ (-> string? string?)
+ (if (or (string=? sub "")
+ (equal? (string-ref sub 0) #\_))
+ sub
+ (string-append
+ "_"
+ (string-replace* sub
+ (map symbol->string
+ '(ₐ ₑ ₕ ᵢ ⱼ ₖ ₗ ₘ ₙ ₒ ₚ ᵣ ₛ ₜ ᵤ ᵥ ₓ ᵦ ᵧ ᵨ ᵩ ᵪ))
+ (map symbol->string
+ '(A E H I J K L M N O P R S T U V X β γ ρ ϕ χ))))))
+
+(define/contract (subscript-equal? bound binder)
+ (-> identifier? identifier? (or/c #f string?))
+ (let* ([binder-subscripts (normalize-subscripts (extract-subscripts binder))]
+ [bound-subscripts (normalize-subscripts (extract-subscripts bound))])
+ (and (string=? binder-subscripts bound-subscripts)
+ (not (string=? binder-subscripts ""))
+ binder-subscripts)))
+
+(define/contract (drop-subscripts id)
+ (-> identifier? identifier?)
+ (let* ([str (symbol->string (syntax-e id))]
+ [sub (extract-subscripts id)]
+ [new-str (substring str 0 (- (string-length str)
+ (string-length sub)))])
+ (datum->syntax id (string->symbol new-str) id id)))
+
+(define (filter-current-pvars bound)
+ (remove-duplicates
+ (map (λ (pv+u) (cons (syntax-local-get-shadower (car pv+u))
+ (cdr pv+u)))
+ (filter (compose (conjoin identifier?
+ (λ~> (syntax-local-value _ (thunk #f))
+ syntax-pattern-variable?)
+ ;; force call syntax-local-value to prevent
+ ;; ambiguous bindings, as syntax-local-value
+ ;; triggers an error for those.
+ ;; Must be done before the free-identifier=?
+ ;; which just returns #false
+ (λ~> (datum->syntax _ (syntax-e bound))
+ (syntax-local-value _ (thunk #f))
+ (thunk* #t)) ;; ok if no error.
+ (λ~> (datum->syntax _ (syntax-e bound))
+ (free-identifier=? _ bound))
+ (λ~> (subscript-equal? bound _)))
+ car)
+ (current-pvars+unique)))
+ bound-identifier=?
+ #:key car))
+
+;; Or write it as:
+#;(define (filter-current-pvars bound)
+ (for/list ([binder (current-pvars+unique)]
+ #:when (identifier? (car binder))
+ #:when (syntax-pattern-variable?
+ (syntax-local-value (car binder) (thunk #f)))
+ ;; force call syntax-local-value to prevent ambiguous
+ ;; bindings, as syntax-local-value triggers an error for
+ ;; those.
+ ;; Must be done before the free-identifier=? which just
+ ;; returns #false
+ #:when (begin
+ (syntax-local-value
+ (datum->syntax _ (syntax-e bound))
+ (thunk #f))
+ #t) ;; ok if no error.
+ #:when (free-identifier=? (datum->syntax (car binder)
+ (syntax-e bound))
+ bound)
+ #:when (subscript-equal? bound (car binder)))
+ binder))
+
+(define/contract (find-subscript-binders bound)
+ (-> identifier?
+ (or/c #f (list/c identifier? ; bound
+ (syntax/c (listof identifier?)) ; binders
+ (syntax/c (listof identifier?)) ; unique-at-runtime ids
+ exact-nonnegative-integer?))) ; ellipsis-depth
+
+ (let/cc return
+ ;; EARLY RETURN (already a pattern variable)
+ (when (syntax-pattern-variable?
+ (syntax-local-value bound (thunk #f)))
+ (return #f))
+
+ (define/with-syntax ([binder . unique-at-runtime-id] …)
+ (filter-current-pvars bound))
+
+ ;; EARLY RETURN (no candidate binders found)
+ (when (stx-null? #'(binder …))
+ (return #f))
+
+ (define depths
+ (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
+
+ ;; EARLY ERROR (inconsistent depths)
+ (unless (or (< (length depths) 2) (apply = depths))
+ (car depths)
+ (raise-syntax-error 'subtemplate
+ (format "inconsistent depths: ~a"
+ (map cons
+ (syntax->datum #'(binder …))
+ depths))
+ bound
+ (syntax->list #'(binder …))))
+
+ ;; FINAL RETURN (list of same-depth binders + their depth)
+ (return (list bound
+ #'(binder …)
+ #'(unique-at-runtime-id …)
+ (car depths)))))
diff --git a/template-subscripts.rkt b/template-subscripts.rkt
new file mode 100644
index 0000000..e981e68
--- /dev/null
+++ b/template-subscripts.rkt
@@ -0,0 +1,388 @@
+#lang racket/base
+
+(require racket/require
+ racket/list
+ racket/string
+ racket/function
+ racket/contract
+ phc-toolkit/untyped
+ phc-toolkit/untyped-only/syntax-parse
+ racket/stxparam
+ stxparse-info/parse
+ stxparse-info/case
+ stxparse-info/current-pvars
+ stxparse-info/parse/experimental/template
+ (prefix-in - stxparse-info/parse/private/residual)
+ (prefix-in dbg: stxparse-info/parse/private/runtime)
+ syntax/id-table
+ (subtract-in racket/syntax stxparse-info/case)
+ "copy-attribute.rkt"
+ (for-syntax (subtract-in racket/base srfi/13)
+ "patch-arrows.rkt"
+ "subscripts.rkt"
+ racket/format
+ stxparse-info/parse
+ racket/private/sc
+ racket/syntax
+ racket/list
+ racket/function
+ phc-toolkit/untyped
+ syntax/strip-context
+ srfi/13
+ (subtract-in racket/string srfi/13)
+ syntax/contract
+ racket/contract))
+
+(provide subtemplate
+ quasisubtemplate
+ derive
+ ellipsis-count/c) ;; TODO: don't provide this here.
+
+(define derived-valvar-cache (make-weak-hash))
+
+(begin-for-syntax
+ (define/contract (nest-ellipses stx n)
+ (-> syntax? exact-nonnegative-integer? syntax?)
+ (if (= n 0)
+ stx
+ #`(#,(nest-ellipses stx (sub1 n))
+ (… …)))))
+
+;; Checks that all the given attribute values have the same structure.
+;;
+;; ellipsis-count/c works with the value of pattern variables and of attributes
+;; too, including those missing (optional) elements in the lists, at any level.
+;;
+;; The lists must have the same lengths across all attribute values, including
+;; the missing #f elements.
+;;
+;; If same-shape is #true, a #f in one attribute value implies #f in all other
+;; attribute values at the same position. The same-shape check is not
+;; performed on the bottommost #f values (as they do not influence the shape of
+;; the tree).
+(define/contract (ellipsis-count/c depth
+ [bottom-predicate any/c]
+ #:same-shape [same-shape #f])
+ (->* {exact-nonnegative-integer?}
+ {flat-contract?
+ #:same-shape boolean?}
+ flat-contract?)
+ ;; Must be lazy, otherwise ellipsis-count/c would immediately call itself
+ (define (recur/c sublists)
+ ((ellipsis-count/c (sub1 depth) bottom-predicate #:same-shape same-shape)
+ sublists))
+ (flat-named-contract
+ (apply build-compound-type-name
+ (list* 'ellipsis-count/c depth bottom-predicate
+ (if same-shape
+ (list '#:same-shape same-shape)
+ (list))))
+ (λ (l*)
+ (true?
+ (and (list? l*)
+ (if (and same-shape (> depth 0))
+ (or (andmap false? l*) ;; all #f
+ (andmap identity l*)) ;; all non-#f
+ #t)
+ (let ([l* (filter identity l*)])
+ (if (= depth 0)
+ (andmap bottom-predicate l*)
+ (let ([lengths (map length l*)])
+ (and (or (< (length lengths) 2) (apply = lengths))
+ (or (empty? l*)
+ (apply andmap
+ (λ sublists
+ (recur/c sublists))
+ l*)))))))))))
+
+(define/contract (map-merge-stx-depth f l* depth)
+ (->i {[f (-> (listof any/c) any/c)]
+ [l* (depth) (ellipsis-count/c depth any/c)]
+ [depth exact-nonnegative-integer?]}
+ {result (depth l*)
+ (λ (r) ((ellipsis-count/c depth) (cons r l*)))})
+ (let ([l* (filter identity l*)])
+ (if (= depth 0)
+ (f l*)
+ (if (empty? l*)
+ #f
+ (apply map
+ (λ sublists
+ (map-merge-stx-depth f
+ sublists
+ (sub1 depth)))
+ l*)))))
+
+(define-for-syntax (sub*template self-form tmpl-form)
+ (syntax-parser
+ [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}}
+ {~optkw #:props (prop:id ...)}
+ ;; #: marks end of options (so that we can have implicit ?@ later)
+ {~optional #:}
+ tmpl)
+ (unless (attribute force-no-stxinfo)
+ (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser
+ syntax-case define/with-syntax with-syntax))])
+ (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))]
+ [good (datum->syntax #'here sym)])
+ (when (or (not (identifier-binding shadower))
+ (not (free-identifier=? shadower good)))
+ (raise-syntax-error self-form
+ (~a sym (if (identifier-binding shadower)
+ (~a " resolves to the official "
+ sym ",")
+ " seems undefined,")
+ " but subtemplate needs the patched"
+ " version from stxparse-info. Use (require"
+ " stxparse-info/parse) and (require"
+ " stxparse-info/case) to fix this. This"
+ " message can be disabled with (" self-form
+ " #:force-no-stxinfo …), if you know what"
+ " you're doing."))))))
+
+ (define acc '())
+
+ ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ
+ ;; bindings
+ (define (fold-process stx rec)
+ (syntax-case stx ()
+ [(id . _) (and (identifier? #'id)
+ (free-identifier=? #'id #'unsyntax))
+ stx]
+ [id (identifier? #'id)
+ (let ([binders+info (find-subscript-binders #'id)])
+ (when binders+info
+ (set! acc (cons binders+info acc)))
+ #'id)]
+ [other (rec #'other)]))
+ ;; Process the syntax, extract the derived bindings into acc
+ ;; Does not take zᵢ identifiers generated by template metafunctions into
+ ;; account for now.
+ (fold-syntax fold-process #'tmpl)
+
+ ;; define the result, which looks like (template . tmpl) or
+ ;; like (quasitemplate . tmpl)
+ (define result
+ (quasisyntax/top-loc #'self
+ (#,tmpl-form tmpl
+ #,@(if (attribute props) #'(#:props (prop ...)) #'()))))
+ ;; Make sure that we remove duplicates, otherwise we'll get errors if we
+ ;; define the same derived id twice.
+ (define/with-syntax ([bound
+ (binder …)
+ unique-at-runtime-ids
+ ellipsis-depth]
+ …)
+ (remove-duplicates acc bound-identifier=? #:key car))
+
+ (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate))
+
+ #`(let-values ()
+ (define-values (whole-form-id) (quote-syntax #,this-syntax))
+ (derive
+ bound (binder …) unique-at-runtime-ids ellipsis-depth whole-form-id)
+ …
+ (let-values ()
+ ;; check that all the binders for a given bound are compatible.
+ ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) …
+ ;; actually call template or quasitemplate
+ #,result))]))
+
+(define-syntax subtemplate
+ (sub*template 'subtemplate #'template))
+(define-syntax quasisubtemplate
+ (sub*template 'quasisubtemplate #'quasitemplate))
+
+(define/contract (multi-hash-ref! h keys to-set)
+ ;; This assumes that the hash does not get mutated during the execution of
+ ;; this function.
+ (-> (and/c (hash/c symbol? any/c #:immutable #f) hash-weak?)
+ (listof symbol?)
+ any/c
+ any/c)
+ (define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f))
+ to-set))
+ ;; Set the existing value (or new to-set if none) on all keys which
+ ;; are not present in the hash table.
+ (for ([k (in-list keys)]) (hash-ref! h k val))
+ val)
+
+(define formattable/c (or/c number? string? symbol? bytes?))
+
+(define/contract
+ (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form)
+ (->i {[depth exact-nonnegative-integer?]
+ [bound identifier?]
+ [binder₀ identifier?]
+ [format (-> formattable/c string?)]
+ [l* (depth) (listof (attribute-val/c depth))]
+ [attribute-names (l*) (and/c (listof identifier?)
+ (λ (a) (= (length l*) (length a))))]
+ [whole-form syntax?]}
+ #:pre (l* depth attribute-names whole-form bound)
+ (if ((ellipsis-count/c depth) l*)
+ #t
+ (raise-syntax-error
+ (syntax-case whole-form ()
+ [(self . _) (syntax-e #'self)]
+ [_ 'subtemplate])
+ "incompatible ellipsis match counts for subscripted variables:"
+ whole-form
+ bound
+ attribute-names))
+ {result (depth l*)
+ (and/c (attribute-val/c depth identifier?)
+ (λ (r) ((ellipsis-count/c depth) (cons r l*))))})
+
+
+ (define (gen bottom*)
+ (define v
+ (let ([vs (filter-map (λ (v)
+ (cond [(formattable/c v) v]
+ [(formattable/c (syntax-e v)) (syntax-e v)]
+ [else #f]))
+ bottom*)])
+ (if (empty? vs)
+ (syntax-e (generate-temporary binder₀))
+ (car vs))))
+ (datum->syntax ((make-syntax-introducer) bound)
+ (string->symbol (format v))))
+
+ (map-merge-stx-depth gen l* depth))
+
+(define-syntax/case (derive bound
+ (binder₀ binderᵢ …)
+ (unique-at-runtime-idᵢ …)
+ ellipsis-depth
+ whole-form-id) ()
+ (define depth (syntax-e #'ellipsis-depth))
+ (define/with-syntax bound-ddd (nest-ellipses #'bound depth))
+ (define/with-syntax tmp-id
+ (format-id #'here "~a/~a" #'binder₀ (drop-subscripts #'bound)))
+ (define/with-syntax tmp-str
+ (datum->syntax #'tmp-id
+ (symbol->string
+ (syntax-e
+ (format-id #'here "~~a/~a" (drop-subscripts #'bound))))))
+ (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
+ (define/with-syntax binder-ddd (nest-ellipses #'binder₀ depth))
+
+ ;; Draw arrows in DrRacket.
+ (with-arrows
+ (define subscripts (subscript-equal? #'bound #'binder₀))
+ (define bound-id-str (identifier->string #'bound))
+ (for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))])
+ (define binder-id-str (identifier->string binder))
+ (record-sub-range-binders! (vector #'bound
+ (- (string-length bound-id-str)
+ (string-length subscripts))
+ (string-length subscripts)
+ binder
+ (- (string-length binder-id-str)
+ (string-length subscripts))
+ (string-length subscripts))))
+ #;(define binder0-id-str (identifier->string #'binder0))
+ #;(record-sub-range-binders! (vector #'bound
+ (- (string-length bound-id-str)
+ (string-length subscripts))
+ (string-length subscripts)
+ #'binder0
+ (- (string-length binder0-id-str)
+ (string-length subscripts))
+ (string-length subscripts)))
+ (define/with-syntax temp-derived (generate-temporary #'bound))
+ (define/with-syntax temp-valvar (generate-temporary #'bound))
+ (define/with-syntax temp-cached (generate-temporary #'bound))
+ (define/with-syntax temp-generated (generate-temporary #'bound))
+ (define/with-syntax temp-id-table (generate-temporary #'bound))
+ ;; HERE: cache the define-temp-ids in the free-id-table, and make sure
+ ;; that we retrieve the cached ones, so that two subtemplate within the same
+ ;; syntax-case or syntax-parse clause use the same derived ids.
+ ;;
+ ;; We mark specially those bindings bound by (derive …) so that they are
+ ;; not seen as original bindings in nested subtemplates (e.g. with an
+ ;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
+ ;; (syntax-parse #'(a b c)
+ ;; [(xᵢ …)
+ ;; (quasisubtemplate (yᵢ …
+ ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
+ ;; zᵢ …))])
+ ;; the test above is not exactly right (zᵢ will still have the correct
+ ;; binding), but it gives the general idea.
+ #`(begin
+ (define-values (temp-generated)
+ (generate-nested-ids 'ellipsis-depth
+ (quote-syntax bound)
+ (quote-syntax binder₀)
+ (λ (v) (format tmp-str v))
+ (list (attribute* binder₀)
+ (attribute* binderᵢ)
+ …)
+ (list (quote-syntax binder₀)
+ (quote-syntax binderᵢ)
+ …)
+ whole-form-id))
+ (define-values (temp-id-table)
+ (multi-hash-ref! derived-valvar-cache
+ (list unique-at-runtime-idᵢ
+ …)
+ (make-free-id-table)))
+ (define-values (temp-cached)
+ (free-id-table-ref! temp-id-table
+ (quote-syntax bound)
+ temp-generated))
+ ;; TODO: we should check that if the hash-table access worked,
+ ;; any new pvars are compatible with the old ones on which the cache is
+ ;; based (in the sense of "no new non-#f positions")
+
+ ;; Check that all derived pvars for this subscript from all binders
+ ;; have the same shape, i.e. we wouldn't want some elements to be missing
+ ;; (as in ~optional) at some position from one derived pvar, but not from
+ ;; others. This check implies that the original binder used did not
+ ;; introduce new elements compared to the binders used for other derived
+ ;; pvars, e.g:
+ ;; (syntax-parse #'([1 2 3] #f)
+ ;; [({~and {~or (xᵢ ...) #f}} ...)
+ ;; (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
+ ;; (syntax-case #'([a b c] [d e]) ()
+ ;; ;; introduces elements [d e] which were unknown when yᵢ was
+ ;; ;; generated:
+ ;; [((wᵢ ...) ...)
+ ;; ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
+ ;; ;; inconsistent with the shape of yᵢ.
+ ;; (subtemplate ({?? (zᵢ ...) _} ...))])])
+ ;; The check must also compare temp-generated, even if it was not
+ ;; assigned to #'bound, so that it also cathes the error if we replace
+ ;; zᵢ with yᵢ in the example above.
+ (unless ((ellipsis-count/c ellipsis-depth #:same-shape #t)
+ (cons temp-generated
+ (free-id-table-map temp-id-table (λ (k v) v))))
+ ;; TODO: For now this will just blow up, a better error message would
+ ;; be nice. Especially saying which one failed.
+ (raise-syntax-error
+ 'sublist
+ (format (string-append
+ "some derived variables do not have the same ellipsis"
+ " shape\n"
+ " depth: ~a\n"
+ " attributes...:\n"
+ " ~a\n"
+ " attribute ~a if it were generated here...:\n"
+ " ~a")
+ 'ellipsis-depth
+ (string-join (free-id-table-map
+ temp-id-table
+ (λ (k v)
+ (format "~a => ~a"
+ (syntax-e k)
+ (syntax->datum
+ (datum->syntax #f v)))))
+ "\n ")
+ 'bound
+ (syntax->datum
+ (datum->syntax #f temp-generated)))
+ (quote-syntax whole-form-id)
+ (quote-syntax bound)
+ (free-id-table-map temp-id-table (λ (k v) k))))
+
+ (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t))))
diff --git a/test/test-ddd-top.rkt b/test/test-ddd-top.rkt
new file mode 100644
index 0000000..756efca
--- /dev/null
+++ b/test/test-ddd-top.rkt
@@ -0,0 +1,84 @@
+#lang racket
+
+(require subtemplate/top-subscripts
+ subtemplate/ddd-forms
+ (except-in subtemplate/override ?? ?@)
+ stxparse-info/case
+ stxparse-info/parse
+ rackunit
+ syntax/macro-testing
+ phc-toolkit/untyped
+ (only-in racket/base [... …]))
+
+#;(check-equal? (syntax-parse #'(a b c)
+ [(xᵢ …)
+ yᵢ])
+ '(a/y b/y c/y))
+
+(check-equal? (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ (yᵢ …)])
+ '(a/y b/y c/y))
+
+(check-equal? (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ([list xᵢ yᵢ] …)])
+ '([a a/y] [b b/y] [c c/y]))
+
+(check-equal? (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ({?@ xᵢ yᵢ} …)])
+ '(a a/y b b/y c c/y))
+
+(check-match (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ (list #'yᵢ …)])
+ (list (? syntax?) (? syntax?) (? syntax?)))
+
+(check-equal? (map syntax->datum
+ (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ (list #'yᵢ …)]))
+ '(a/y b/y c/y))
+
+(check-match (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ([list xᵢ #'yᵢ] …)])
+ (list (list 'a (? syntax?))
+ (list 'b (? syntax?))
+ (list 'c (? syntax?))))
+
+(check-match (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ([list #'xᵢ #'yᵢ] …)])
+ (list (list (? syntax?) (? syntax?))
+ (list (? syntax?)(? syntax?))
+ (list (? syntax?)(? syntax?))))
+
+(check-match (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ({?@ #'xᵢ #'yᵢ} …)])
+ (list (? syntax?) (? syntax?)
+ (? syntax?) (? syntax?)
+ (? syntax?) (? syntax?)))
+
+(check-equal? (syntax->datum
+ (datum->syntax #f
+ (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ([list xᵢ #'yᵢ] …)])))
+ '([a a/y] [b b/y] [c c/y]))
+
+(check-equal? (syntax->datum
+ (datum->syntax #f
+ (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ([list #'xᵢ #'yᵢ] …)])))
+ '([a a/y] [b b/y] [c c/y]))
+
+(check-equal? (syntax->datum
+ (datum->syntax #f
+ (syntax-case #'(a b c) ()
+ [(xᵢ …)
+ ({?@ #'xᵢ #'yᵢ} …)])))
+ '(a a/y b b/y c c/y))
\ No newline at end of file
diff --git a/test/test-subtemplate-detect-stxinfo.rkt b/test/test-subtemplate-detect-stxinfo.rkt
index 2b7f28e..43bcb43 100644
--- a/test/test-subtemplate-detect-stxinfo.rkt
+++ b/test/test-subtemplate-detect-stxinfo.rkt
@@ -1,6 +1,6 @@
#lang racket
(module m-ok racket
- (require subtemplate
+ (require subtemplate/template-subscripts
stxparse-info/parse
stxparse-info/case
rackunit
@@ -11,7 +11,7 @@
(subtemplate ok)))))
(module m-no-parse racket
- (require subtemplate
+ (require subtemplate/template-subscripts
stxparse-info/case
rackunit
syntax/macro-testing)
@@ -21,7 +21,7 @@
(subtemplate ok)))))
(module m-wrong-parse racket
- (require subtemplate
+ (require subtemplate/template-subscripts
syntax/parse
stxparse-info/case
rackunit
@@ -33,7 +33,7 @@
(subtemplate ok)))))
(module m-wrong-case racket
- (require subtemplate
+ (require subtemplate/template-subscripts
stxparse-info/parse
rackunit
syntax/macro-testing)
@@ -43,7 +43,7 @@
(subtemplate ok)))))
(module m-no-parse-wrong-case racket
- (require subtemplate
+ (require subtemplate/template-subscripts
rackunit
syntax/macro-testing)
(check-exn #rx"subtemplate: syntax-parse seems undefined,"
@@ -52,7 +52,7 @@
(subtemplate ok)))))
(module m-wrong-parse-wrong-case racket
- (require subtemplate
+ (require subtemplate/template-subscripts
syntax/parse
rackunit
syntax/macro-testing)
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
index 0987790..d7001b9 100644
--- a/test/test-subtemplate.rkt
+++ b/test/test-subtemplate.rkt
@@ -1,5 +1,5 @@
#lang racket
-(require subtemplate
+(require subtemplate/template-subscripts
stxparse-info/parse
stxparse-info/parse/experimental/template
stxparse-info/case
diff --git a/top-subscripts.rkt b/top-subscripts.rkt
new file mode 100644
index 0000000..a930a39
--- /dev/null
+++ b/top-subscripts.rkt
@@ -0,0 +1,41 @@
+#lang racket/base
+(require (only-in "template-subscripts.rkt"
+ derive
+ ellipsis-count/c)
+ phc-toolkit/untyped
+ (for-syntax racket/base
+ racket/syntax
+ syntax/stx
+ (only-in racket/base [... …])
+ "subscripts.rkt"))
+
+(provide (rename-out [top #%top]))
+
+(define-syntax (top stx)
+ (define/with-syntax bound (stx-cdr stx))
+
+ (define binders+info (find-subscript-binders #'bound))
+
+ (if binders+info
+ (let ()
+ (define/with-syntax [_bound
+ (binder …)
+ unique-at-runtime-ids
+ ellipsis-depth]
+ binders+info)
+
+ (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate))
+
+ #'(let-values ()
+ (define-values (whole-form-id) (quote-syntax #,this-syntax))
+ (derive bound
+ (binder …)
+ unique-at-runtime-ids
+ ellipsis-depth
+ whole-form-id)
+ (let-values ()
+ ;; check that all the binders for a given bound are compatible.
+ ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …))
+ ;; actually call template or quasitemplate
+ bound)))
+ (datum->syntax stx `(,#'#%top . ,#'bound))))
\ No newline at end of file