diff --git a/private/ddd.rkt b/private/ddd.rkt index c71ddc9..c131126 100644 --- a/private/ddd.rkt +++ b/private/ddd.rkt @@ -94,10 +94,10 @@ (define (map#f* f attr-ids l*) (for ([l (in-list l*)] [attr-id (in-list attr-ids)]) - (when (eq? l #f) - (raise-syntax-error (syntax-e attr-id) - "attribute contains an omitted element" - attr-id))) + (when (eq? l #f) + (raise-syntax-error (syntax-e attr-id) + "attribute contains an omitted element" + attr-id))) (unless (apply =* (map length l*)) (raise-syntax-error 'ddd "incompatible ellipis counts for template")) @@ -106,14 +106,14 @@ (define-for-syntax (current-pvars-shadowers) (remove-duplicates - (map syntax-local-get-shadower - (map syntax-local-introduce - (filter (conjoin identifier? - (λ~> (syntax-local-value _ (thunk #f)) - syntax-pattern-variable?) - attribute-real-valvar) - (reverse (current-pvars))))) - bound-identifier=?)) + (map syntax-local-get-shadower + (map syntax-local-introduce + (filter (conjoin identifier? + (λ~> (syntax-local-value _ (thunk #f)) + syntax-pattern-variable?) + attribute-real-valvar) + (reverse (current-pvars))))) + bound-identifier=?)) (define-for-syntax (extract-present-variables expanded-form stx) ;; present-variables vector @@ -165,13 +165,18 @@ (define/with-syntax (pvar …) (current-pvars-shadowers)) (define/with-syntax expanded-condition - (local-expand #'(detect-present-pvars (pvar …) condition) + (local-expand #'(λ (lifted-variables-hash) + (syntax-parameterize ([lift-late-pvars-param + #'lifted-variables-hash]) + (detect-present-pvars (pvar …) condition))) 'expression '())) (define-values (present-variables lifted-variables) (extract-present-variables #'expanded-condition stx)) + (define/with-syntax ([lifted-key . lifted-macro+args] …) + lifted-variables) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TODO: lifted stuff!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! (define/with-syntax (test-present-attribute …) @@ -182,9 +187,16 @@ #:when (eq? 'attr (car (attribute-info pv '(pvar attr))))) #`(attribute* #,pv))) - #`(if (and test-present-attribute …) - #,(if (eq? mode 'if) #'a #'condition) - b))])) + #`(let ([lifted-list (list (cons 'lifted-key + lifted-macro+args) + …)]) + (if (and test-present-attribute … + (andmap cdr lifted-list)) + #,(if (eq? mode 'if) + #'a + #'(expanded-condition + (make-hash lifted-list))) + b)))])) (parse stx)) (define-syntax ?if (?* 'if)) @@ -260,7 +272,7 @@ (define-values (present-variables lifted-variables) (extract-present-variables #'expanded-f stx)) - (define/with-syntax ([lifted-key lifted-macro+args …] …) lifted-variables) + (define/with-syntax ([lifted-key . lifted-macro+args] …) lifted-variables) (unless (or (ormap identity present-variables) (not (null? lifted-variables))) @@ -303,7 +315,7 @@ (list (quote-syntax iterated-pvar) … (quote-syntax lifted-key) …) ;; TODO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! not the real variable (list (attribute* iterated-pvar) … - (lifted-macro+args … 1 #;depth?????????????????????????????????????????????????) …))) + lifted-macro+args …))) (define-syntax/case (shadow pvar new-value) () (match (attribute-info #'pvar '(pvar attr)) @@ -318,9 +330,9 @@ #,(max 0 (sub1 depth)) #t) #;#`(define-raw-syntax-mapping pvar - tmp-valvar - new-value - #,(sub1 depth))])) + tmp-valvar + new-value + #,(sub1 depth))])) (define-for-syntax (extract-ids/tree e) (cond diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt index a3b7141..5aa23a6 100644 --- a/private/template-subscripts.rkt +++ b/private/template-subscripts.rkt @@ -216,7 +216,7 @@ (define-syntax (lifted-var-macro stx) (syntax-case stx () - [(_ bound depth) + [(_ bound) #`(car (subtemplate/attribute* bound))])) (define-syntax subtemplate/attribute* diff --git a/test/test-ddd-top.rkt b/test/test-ddd-top.rkt index fccb2b3..772ab09 100644 --- a/test/test-ddd-top.rkt +++ b/test/test-ddd-top.rkt @@ -102,6 +102,14 @@ (list (list #'yᵢ …) …)])) '([a/y b/y c/y] [d/y e/y])) +(check-equal? ((λ (result) (syntax->datum (datum->syntax #f result))) + (syntax-parse #'[(([h] [i] 10) ([j] 12 13 [m])) + (([a] #:kw #:kw) ([d] [e] [f] [g]))] + [[(({~and {~or (yᵢ:id …) :nat}} …) …) + (({~and {~or (xᵢ:id …) #:kw}} …) …)] + (list (list (?? (list #'zᵢ …) 'missing) …) …)])) + '(([a/z] [i/z] missing) ([d/z] [e/z] [f/z] [g/z]))) + (check-match (syntax-case #'(a b c) () [(xᵢ …) ([list xᵢ #'yᵢ] …)])