diff --git a/experimental/template.rkt b/experimental/template.rkt index b37242b..3cb8019 100644 --- a/experimental/template.rkt +++ b/experimental/template.rkt @@ -443,6 +443,9 @@ instead of integers and integer vectors. (template-metafunction? (lookup #'mf #f))) (let-values ([(mf) (lookup #'mf #f)] [(drivers guide props-guide) (parse-t #'template depth esc?)]) + (displayln drivers) + (displayln guide) + (displayln props-guide) (values (dset-add drivers mf) (vector 'metafun mf guide) (cons-guide '_ props-guide)))] diff --git a/template-unsyntax-ellipsis.rkt b/template-unsyntax-ellipsis.rkt new file mode 100644 index 0000000..90c398b --- /dev/null +++ b/template-unsyntax-ellipsis.rkt @@ -0,0 +1,94 @@ +#lang racket + +(require (for-syntax phc-toolkit/untyped + racket/contract + racket/private/sc) + syntax/parse/experimental/template + (prefix-in backport: backport-template-pr1514/experimental/template)) +(provide escape) + +(begin-for-syntax + (require racket/syntax) + (define/with-syntax ooo #'(... ...))) + +(define-syntax (mysyntax stx) + (syntax-case stx () + [(_ v) + #'(syntax (ooo v))])) + +(define-for-syntax (force-expand e) + (define e1 (local-expand e 'expression (list #'quote + #'syntax + #'template + #'backport:template))) + ;(displayln (list (syntax->datum e) (syntax->datum e1))) + (syntax-case e1 (syntax template backport:template + begin quote set! #%plain-lambda + ;; TODO: + case-lambda let-values + letrec-values if begin0 with-continuation-mark + letrec-syntaxes+values #%plain-app #%expression #%top + #%variable-reference) + [(begin _ ...) + (datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)] + [(set! _ ...) + (datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)] + [(#%plain-lambda args body ...) + (datum->syntax e1 (list (stx-car e1) + #'args + (stx-map force-expand #'(body ...))) + e1 e1)] + [(quote _) + e1] + [(syntax . rest) + (displayln (syntax->datum #'rest)) + #`(quote-syntax #,e1)] + [(template . rest) + (displayln (syntax->datum #'rest)) + #`(quote-syntax #,e1)] + [(backport:template . rest) + (displayln (syntax->datum #'rest)) + #`(quote-syntax #,e1)] + [(_ ...) + (datum->syntax e1 (map force-expand (syntax->list e1)) e1 e1)] + [_ + e1])) + + + +;make-syntax-mapping syntax-pattern-variable? +;syntax-mapping-depth syntax-mapping-valvar + +(define-syntax (escape stx) + (syntax-case stx () + [(_ body) + (force-expand #'body)])) + +;; Doesn't work. +#;(begin + (define-for-syntax exn-ellipses/c + (struct/c exn:fail:syntax + (regexp-match/c + #px"syntax: too few ellipses for pattern variable in template") + any/c + (list/c identifier?))) + (define-syntax (escape stx) + (syntax-case stx () + [(_ body) + (let () + (define used-pvars '()) + (define (push-pvar! pvar) + (set! used-pvars (cons pvar used-pvars))) + ;(let loop ([used-pvars '()]) + (with-handlers ([exn-ellipses/c + (λ (exn) + ;; Can't do syntax-local-value :-( + (displayln (syntax-local-value (car (exn:fail:syntax-exprs exn)))) + (push-pvar! (car (exn:fail:syntax-exprs exn))))]) + (local-expand #'body 'expression (list))) + ;(displayln (syntax-pattern-variable? (syntax-local-value (car used-pvars)))) + (with-handlers ([exn-ellipses/c + (λ (exn) + (push-pvar! (car (exn:fail:syntax-exprs exn))))]) + (displayln (local-expand #'body 'expression (list)))) + #'(void))]))) diff --git a/test-template-unsyntax-ellipsis.rkt b/test-template-unsyntax-ellipsis.rkt new file mode 100644 index 0000000..d8947f4 --- /dev/null +++ b/test-template-unsyntax-ellipsis.rkt @@ -0,0 +1,18 @@ +#lang racket +(require "template-unsyntax-ellipsis.rkt" + syntax/stx + syntax/parse/experimental/template) + +#;(syntax-case #'((1 2) (3 4)) () + [((x ...) ...) + (escape (stx-map (λ (xᵢ) (+ (syntax-e xᵢ) 1)) + (template (x ...))))]) + +(syntax-case #'((1 2) (3 4)) () + [((x ...) ...) + (escape (stx-map (λ (xᵢ) + (define-syntax (a stx) + (datum->syntax stx (string->symbol xᵢ))) + (a) + (+ (syntax-e xᵢ) 1)) + #'(x ...)))])