diff --git a/private/ddd.rkt b/private/ddd.rkt index abd8217..a439478 100644 --- a/private/ddd.rkt +++ b/private/ddd.rkt @@ -22,7 +22,6 @@ (define-for-syntax x-pvar-scope (make-syntax-introducer)) (define-for-syntax x-pvar-present-marker (make-syntax-introducer)) -(define-for-syntax x-lifted-pvar-marker (make-syntax-introducer)) (begin-for-syntax (define/contract (attribute-real-valvar attr) @@ -135,11 +134,13 @@ (define lifted-variables (map (λ (id) (define prop (syntax-property id 'lifted-pvar)) - (unless ((cons/c symbol? syntax?) prop) + (unless ((cons/c symbol? stx-list?) prop) + (displayln id) + (displayln prop) (raise-syntax-error 'ddd (string-append - "internal error: 'lifted-pvar property was" - " missing or not a (cons/c symbol? syntax?).") + "internal error: 'lifted-pvar property was " + "missing or not a (cons/c symbol? stx-list?)") stx)) prop) (filter (λ (id) (all-scopes-in? x-lifted-pvar-marker id)) @@ -262,9 +263,10 @@ (define-values (present-variables lifted-variables) (extract-present-variables #'expanded-f stx)) - (displayln lifted-variables) + (define/with-syntax ([lifted-key lifted-macro+args …] …) lifted-variables) - (unless (ormap identity present-variables) + (unless (or (ormap identity present-variables) + (not (null? lifted-variables))) (raise-syntax-error 'ddd "no pattern variables were found in the body" stx)) @@ -286,7 +288,8 @@ (define/with-syntax ((_ iterated-pvar iterated-pvarᵢ _ _) …) (filter car present?+pvars)) - (when (stx-null? #'(iterated-pvar …)) + (when (and (stx-null? #'(iterated-pvar …)) + (null? lifted-variables)) (no-pvar-to-iterate-error present?+pvars)) ;; If the pvar is iterated, use the iterated pvarᵢ @@ -297,12 +300,13 @@ [(list #f pv pvᵢ #f _) #'#f]) present?+pvars))) - #'(map#f* (λ (iterated-pvarᵢ …) - (expanded-f filling-pvar … #false)) ;; TODO: the lifted pvars here ………………………………………… - (list (quote-syntax iterated-pvar) - …) - (list (attribute* iterated-pvar) - …))) + #'(map#f* (λ (iterated-pvarᵢ … lifted-key …) + (expanded-f filling-pvar … + (make-hash (list (cons 'lifted-key lifted-key) …)))) + (list (quote-syntax iterated-pvar) … + (quote-syntax lifted-key) …) ;; TODO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! not the real variable + (list (attribute* iterated-pvar) … + (lifted-macro+args … 1 #;depth?????????????????????????????????????????????????) …))) (define-syntax/case (shadow pvar new-value) () (match (attribute-info #'pvar '(pvar attr)) diff --git a/private/lifted-variables-communication.rkt b/private/lifted-variables-communication.rkt index 73f1c20..9fdd3b9 100644 --- a/private/lifted-variables-communication.rkt +++ b/private/lifted-variables-communication.rkt @@ -1,7 +1,9 @@ #lang racket/base (provide lift-late-pvars-param - (for-syntax lift-late-pvars-target)) + (for-syntax lift-late-pvars-target + lifted-pvar + x-lifted-pvar-marker)) (require racket/stxparam (for-syntax racket/base @@ -11,16 +13,18 @@ (define-syntax-parameter lift-late-pvars-param #f) (define-for-syntax (lift-late-pvars-target) - (syntax-parameter-value #'must-lift-late-pvars?-param)) + (syntax-parameter-value #'lift-late-pvars-param)) + +(define-for-syntax x-lifted-pvar-marker (make-syntax-introducer)) ;; Returns two values, the syntax to insert, and a symbol to use at run-time ;; to access the value of that lifted pvar. (begin-for-syntax - (define/contract (lifted-pvar name expr-stx) - (-> symbol? syntax? (values symbol? syntax?)) + (define/contract (lifted-pvar name macro+args-stx) + (-> symbol? syntax? (cons/c symbol? syntax?)) (define lifted-symbol (gensym (format "lifted-~a" name))) (define lifted-hint-id (generate-temporary lifted-symbol)) - (values (syntax-property lifted-hint-id - 'late-pvar - (cons lifted-symbol expr-stx)) - lifted-symbol))) \ No newline at end of file + (cons lifted-symbol + (syntax-property (x-lifted-pvar-marker lifted-hint-id) + 'lifted-pvar + (cons lifted-symbol macro+args-stx))))) \ No newline at end of file diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt index ff2538a..a3b7141 100644 --- a/private/template-subscripts.rkt +++ b/private/template-subscripts.rkt @@ -82,7 +82,7 @@ (true? (and (list? l*) (if (and same-shape (> depth 0)) - (or (andmap false? l*) ;; all #f + (or (andmap false? l*) ;; all #f (andmap identity l*)) ;; all non-#f #t) (let ([l* (filter identity l*)]) @@ -114,10 +114,7 @@ (sub1 depth))) l*))))) -(define-for-syntax (sub*template self-form tmpl-form) - (sub*template-impl self-form tmpl-form)) - -(define-for-syntax (sub*template-impl self-form tmpl-form) +(define-for-syntax (sub*template self-form tmpl-form get-attribute*) (syntax-parser [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}} {~optkw #:props (prop:id ...)} @@ -181,21 +178,53 @@ (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 lift-target (lift-late-pvars-target)) + (if lift-target + (let () + (define/with-syntax ([token . to-insert] …) + (stx-map lifted-pvar + (stx-map syntax-e #'(bound …)) ;; name + #`([lifted-var-macro bound] …))) + #`(let-values () + (quote-syntax (to-insert …)) + (copy-raw-syntax-attribute bound + (hash-ref #,lift-target 'token) + ellipsis-depth + #t) + … + #,(if get-attribute* + #'(list (attribute* bound ) …) + result))) + #`(let-values () + (define-values (whole-form-id) (quote-syntax #,this-syntax)) + (derive bound + (binder …) + unique-at-runtime-ids + ellipsis-depth + whole-form-id) + … + #,(if get-attribute* + #'(list (attribute* bound ) …) + #`(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 (lifted-var-macro stx) + (syntax-case stx () + [(_ bound depth) + #`(car (subtemplate/attribute* bound))])) + +(define-syntax subtemplate/attribute* + (sub*template 'subtemplate #'template #t)) (define-syntax subtemplate - (sub*template 'subtemplate #'template)) + (sub*template 'subtemplate #'template #f)) (define-syntax quasisubtemplate - (sub*template 'quasisubtemplate #'quasitemplate)) + (sub*template 'quasisubtemplate #'quasitemplate #f)) (define/contract (multi-hash-ref! h keys) ;; This assumes that the hash does not get mutated during the execution of @@ -341,7 +370,10 @@ (quote-syntax whole-form-id) (quote-syntax bound)) - (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t)))) + (copy-raw-syntax-attribute bound + temp-cached + ellipsis-depth + #t)))) (define (check-derived-ellipsis-shape ellipsis-depth temp-generated diff --git a/test/assumption-local-expand-reuse-let-bound-id.rkt b/test/assumption-local-expand-reuse-let-bound-id.rkt new file mode 100644 index 0000000..3be3e44 --- /dev/null +++ b/test/assumption-local-expand-reuse-let-bound-id.rkt @@ -0,0 +1,36 @@ +#lang racket +(require (for-syntax racket/syntax)) +;; x is first bound with a let inside the local-expanded code. +;; The identifier is extracted (presumably with that let's scope, +;; and re-uesd as a definition outside of the let. +;; Check that this is okay (no "ambiguous identifier" or "identifier +;; used out of context" error. +(define-syntax (test stx) + (syntax-case stx () + [(_ e) + (let () + (define/with-syntax whole + (local-expand #'(let-values ([(e) 2]) e) 'expression '())) + (define/with-syntax (_ _ xx) #'whole) + #'(let-values () + (define xx 3) + (list xx + whole)))])) + +(let ([x 1]) + (test x)) + +(define-syntax (test2 stx) + (syntax-case stx () + [(_ e) + (let () + (define/with-syntax whole + (local-expand #'(let-values ([(e) 2]) e) 'expression '())) + (define/with-syntax (_ _ xx) #'whole) + #'(let-values ([(xx) xx]) + (list xx + whole)))])) + +;; This does produce an error. The xxx must not be used as an expression. +#;(let ([x 1]) + (test2 x)) \ No newline at end of file diff --git a/test/test-ddd-top.rkt b/test/test-ddd-top.rkt index d46f29d..fccb2b3 100644 --- a/test/test-ddd-top.rkt +++ b/test/test-ddd-top.rkt @@ -2,6 +2,7 @@ (require subtemplate/private/top-subscripts subtemplate/private/ddd-forms + (only-in subtemplate/private/ddd ddd) (except-in subtemplate/private/override ?? ?@) stxparse-info/case stxparse-info/parse @@ -41,6 +42,66 @@ (list #'yᵢ …)])) '(a/y b/y c/y)) +(check-match (syntax-case #'([a b c] [d e]) () + [((xᵢ …) …) + (list (list #'yᵢ …) …)]) + (list (list (? syntax?) (? syntax?) (? syntax?)) + (list (? syntax?) (? syntax?)))) + +(check-equal? (map (curry map syntax->datum) + (syntax-case #'([a b c] [d e]) () + [((xᵢ …) …) + (list (list #'yᵢ …) …)])) + '([a/y b/y c/y] [d/y e/y])) + +(check-match (syntax-case #'([(a1 a2) (b1) (c1 c2 c3)] + [(d1 d2 d3 d4) (e1 e2 e3 e4 e5)]) () + [(((xᵢ …) …) …) + (list (list (list #'yᵢ …) …) …)]) + (list (list (list (? syntax?) (? syntax?)) + (list (? syntax?)) + (list (? syntax?) (? syntax?) (? syntax?))) + (list (list (? syntax?) (? syntax?) (? syntax?) (? syntax?)) + (list (? syntax?) (? syntax?) (? syntax?) + (? syntax?) (? syntax?))))) + +(check-equal? (map (curry map (curry map syntax->datum)) + (syntax-case #'([(a1 a2) (b1) (c1 c2 c3)] + [(d1 d2 d3 d4) (e1 e2 e3 e4 e5)]) () + [(((xᵢ …) …) …) + (list (list (list #'yᵢ …) …) …)])) + '([(a1/y a2/y) (b1/y) (c1/y c2/y c3/y)] + [(d1/y d2/y d3/y d4/y) (e1/y e2/y e3/y e4/y e5/y)])) + +;; CHeck that the same ids are produced. +(check-true (let ([ids (flatten + (syntax-case #'(id) () + [(_aᵢ …) + (list + (ddd #'bᵢ) + (list #'bᵢ …) + (syntax->list #'(bᵢ …)))]))]) + (andmap (curry apply free-identifier=?) + (cartesian-product ids ids)))) + +(check-true (let ([ids (flatten + (syntax-case #'((id)) () + [((aᵢ …) …) + (list + (ddd (ddd #'bᵢ)) + (list (list #'bᵢ …) …) + (stx-map syntax->list #'((bᵢ …) …)) + (syntax->list #'(bᵢ … …)) + (map syntax->list (list #'(bᵢ …) …)))]))]) + (andmap (curry apply free-identifier=?) + (cartesian-product ids ids)))) + +(check-equal? (map (curry map syntax->datum) + (syntax-case #'([a b c] [d e]) () + [((xᵢ …) …) + (list (list #'yᵢ …) …)])) + '([a/y b/y c/y] [d/y e/y])) + (check-match (syntax-case #'(a b c) () [(xᵢ …) ([list xᵢ #'yᵢ] …)]) @@ -81,4 +142,4 @@ (syntax-case #'(a b c) () [(xᵢ …) ({?@ #'xᵢ #'yᵢ} …)]))) - '(a a/y b b/y c c/y)) \ No newline at end of file + '(a a/y b b/y c c/y))