www

commit 7cd95285b950611057449793ce603ca69c9999c8
parent 0f577ba470f69adb2825a4902f2150280d35ac4c
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Sun,  5 Feb 2017 19:02:34 +0100

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

Diffstat:
M
private/ddd.rkt
 | 
54
+++++++++++++++++++++++++++++++++---------------------
M
private/template-subscripts.rkt
 | 
2
+-
M
test/test-ddd-top.rkt
 | 
8
++++++++

3 files changed, 42 insertions(+), 22 deletions(-)
diff --git 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
@@ -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
@@ -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ᵢ] …)])