suzanne.soy/subtemplate
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Tests for ≠ ids, also fixed that bug for ??

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-05 19:02:34 +01:00
parent 0f577ba470
commit 7cd95285b9
3 changed files with 42 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
private/ddd.rkt
View File

@ -94,10 +94,10 @@
(define (map#f* f attr-ids l*) (define (map#f* f attr-ids l*)
(for ([l (in-list l*)] (for ([l (in-list l*)]
[attr-id (in-list attr-ids)]) [attr-id (in-list attr-ids)])
(when (eq? l #f) (when (eq? l #f)
(raise-syntax-error (syntax-e attr-id) (raise-syntax-error (syntax-e attr-id)
"attribute contains an omitted element" "attribute contains an omitted element"
attr-id))) attr-id)))
(unless (apply =* (map length l*)) (unless (apply =* (map length l*))
(raise-syntax-error 'ddd (raise-syntax-error 'ddd
"incompatible ellipis counts for template")) "incompatible ellipis counts for template"))
@ -106,14 +106,14 @@
(define-for-syntax (current-pvars-shadowers) (define-for-syntax (current-pvars-shadowers)
(remove-duplicates (remove-duplicates
(map syntax-local-get-shadower (map syntax-local-get-shadower
(map syntax-local-introduce (map syntax-local-introduce
(filter (conjoin identifier? (filter (conjoin identifier?
(λ~> (syntax-local-value _ (thunk #f)) (λ~> (syntax-local-value _ (thunk #f))
syntax-pattern-variable?) syntax-pattern-variable?)
attribute-real-valvar) attribute-real-valvar)
(reverse (current-pvars))))) (reverse (current-pvars)))))
bound-identifier=?)) bound-identifier=?))
(define-for-syntax (extract-present-variables expanded-form stx) (define-for-syntax (extract-present-variables expanded-form stx)
;; present-variables vector ;; present-variables vector
@ -165,13 +165,18 @@
(define/with-syntax (pvar …) (current-pvars-shadowers)) (define/with-syntax (pvar …) (current-pvars-shadowers))
(define/with-syntax expanded-condition (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 'expression
'())) '()))
(define-values (present-variables lifted-variables) (define-values (present-variables lifted-variables)
(extract-present-variables #'expanded-condition stx)) (extract-present-variables #'expanded-condition stx))
(define/with-syntax ([lifted-key . lifted-macro+args] …)
lifted-variables)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TODO: lifted stuff!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TODO: lifted stuff!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
(define/with-syntax (test-present-attribute …) (define/with-syntax (test-present-attribute …)
@ -182,9 +187,16 @@
#:when (eq? 'attr (car (attribute-info pv '(pvar attr))))) #:when (eq? 'attr (car (attribute-info pv '(pvar attr)))))
#`(attribute* #,pv))) #`(attribute* #,pv)))
#`(if (and test-present-attribute …) #`(let ([lifted-list (list (cons 'lifted-key
#,(if (eq? mode 'if) #'a #'condition) lifted-macro+args)
b))])) …)])
(if (and test-present-attribute …
(andmap cdr lifted-list))
#,(if (eq? mode 'if)
#'a
#'(expanded-condition
(make-hash lifted-list)))
b)))]))
(parse stx)) (parse stx))
(define-syntax ?if (?* 'if)) (define-syntax ?if (?* 'if))
@ -260,7 +272,7 @@
(define-values (present-variables lifted-variables) (define-values (present-variables lifted-variables)
(extract-present-variables #'expanded-f stx)) (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) (unless (or (ormap identity present-variables)
(not (null? lifted-variables))) (not (null? lifted-variables)))
@ -303,7 +315,7 @@
(list (quote-syntax iterated-pvar) … (list (quote-syntax iterated-pvar) …
(quote-syntax lifted-key) …) ;; TODO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! not the real variable (quote-syntax lifted-key) …) ;; TODO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! not the real variable
(list (attribute* iterated-pvar) … (list (attribute* iterated-pvar) …
(lifted-macro+args … 1 #;depth?????????????????????????????????????????????????) …))) lifted-macro+args …)))
(define-syntax/case (shadow pvar new-value) () (define-syntax/case (shadow pvar new-value) ()
(match (attribute-info #'pvar '(pvar attr)) (match (attribute-info #'pvar '(pvar attr))
@ -318,9 +330,9 @@
#,(max 0 (sub1 depth)) #,(max 0 (sub1 depth))
#t) #t)
#;#`(define-raw-syntax-mapping pvar #;#`(define-raw-syntax-mapping pvar
tmp-valvar tmp-valvar
new-value new-value
#,(sub1 depth))])) #,(sub1 depth))]))
(define-for-syntax (extract-ids/tree e) (define-for-syntax (extract-ids/tree e)
(cond (cond

2
private/template-subscripts.rkt
View File

@ -216,7 +216,7 @@
(define-syntax (lifted-var-macro stx) (define-syntax (lifted-var-macro stx)
(syntax-case stx () (syntax-case stx ()
[(_ bound depth) [(_ bound)
#`(car (subtemplate/attribute* bound))])) #`(car (subtemplate/attribute* bound))]))
(define-syntax subtemplate/attribute* (define-syntax subtemplate/attribute*

8
test/test-ddd-top.rkt
View File

@ -102,6 +102,14 @@
(list (list #'yᵢ …) …)])) (list (list #'yᵢ …) …)]))
'([a/y b/y c/y] [d/y e/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) () (check-match (syntax-case #'(a b c) ()
[(xᵢ …) [(xᵢ …)
([list xᵢ #'yᵢ] …)]) ([list xᵢ #'yᵢ] …)])