www

commit a46326c300ce26a381e875dc58b1dbccc9e5ef8f
parent a08c491baac1a398a91aa6e877e01e4626c58bb3
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Tue, 31 Jan 2017 06:08:37 +0100

Improved #%app support for ddd

Diffstat:
M
ddd-forms.rkt
 | 
12
++++++------
M
ddd.rkt
 | 
20
+++++++++++++++-----
M
test/test-ddd-forms.rkt
 | 
66
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----

3 files changed, 83 insertions(+), 15 deletions(-)
diff --git a/ddd-forms.rkt b/ddd-forms.rkt
@@ -27,7 +27,7 @@
         -v
         (-nest* before
                 after
-                (datum->syntax before `(,@(syntax->list before) ,-v . ,after))
+                #`(#,@(syntax->list before) #,-v . #,after)
                 (stx-cdr -ooo*)
                 (add1 depth))))
   
@@ -48,7 +48,7 @@
   (define-syntax-class ooo
     (pattern {~and ooo {~literal …}}))
 
-  (define-splicing-syntax-class ooo*
+  (define-splicing-syntax-class ooo+
     #:attributes (ooo*)
     (pattern {~seq {~and ooo {~literal …}} …+}
              #:with ooo* #'(ooo …)))
@@ -68,15 +68,15 @@
   
   (define-splicing-syntax-class stmt
     #:literals (define define/with-syntax)
-    (pattern {~seq (define name:id e:expr) :ooo*}
+    (pattern {~seq (define name:id e:expr) :ooo+}
              #:with expanded
              #`(-define name
                         #,(nest* (ddd %) e ooo*)))
-    (pattern {~seq (define/with-syntax pat e:expr) :ooo*}
+    (pattern {~seq (define/with-syntax pat e:expr) :ooo+}
              #:with expanded
              #`(-define/with-syntax #,(nest* (% …) pat ooo*)
                                     #,(nest* (ddd %) e ooo*)))
-    (pattern {~seq e:not-macro-expr :ooo*}
+    (pattern {~seq e :ooo+}
              ;#:with expanded #`(apply values #,(ddd* e ooo*))
              #:with expanded (ddd* e ooo*))
     (pattern other
@@ -90,7 +90,7 @@
 
 (begin-for-syntax
   (define-splicing-syntax-class arg
-    (pattern {~seq e:expr ooo*:ooo*}
+    (pattern {~seq e:expr ooo*:ooo+}
              #:with expanded (ddd* e ooo*))
     (pattern other
              #:with expanded #'(#%app list other))))
diff --git a/ddd.rkt b/ddd.rkt
@@ -81,6 +81,16 @@
       (quote-syntax #,(x-pvar-present-marker #'present-variables))
       body))
 
+(define (map#f* f l*)
+  (cond [(andmap (λ (l) (eq? l #f)) l*)
+         '(#f)]
+        [(andmap (or/c null? #f) l*)
+         '()]
+        [else (let ([cars (map (λ (l) (if l (car l) #f)) l*)]
+                    [cdrs (map (λ (l) (if l (cdr l) #f)) l*)])
+                (cons (apply f cars)
+                      (map#f* f cdrs)))]))
+
 (define-syntax/case (ddd body) ()
   (define/with-syntax (pvar …)
     (remove-duplicates
@@ -96,7 +106,7 @@
   (define-temp-ids "~aᵢ" (pvar …))
   (define/with-syntax f
     #`(#%plain-lambda (pvarᵢ …)
-                      (shadow pvar pvarᵢ) …
+                      (shadow pvar pvarᵢ) … ;; TODO: find a way to make the variable marked as "missing" if it is #f ? So that it triggers an error if used outside of ??
                       (let-values ()
                         (detect-present-pvars (pvar …)
                                               body))))
@@ -150,10 +160,10 @@
                     [(list #f pv pvᵢ #f _) #'#f])
            present?+pvars)))
   
-  #'(map (λ (iterated-pvarᵢ …)
-           (expanded-f filling-pvar …))
-         (attribute* iterated-pvar)
-         …))
+  #'(map#f* (λ (iterated-pvarᵢ …)
+              (expanded-f filling-pvar …))
+            (list (attribute* iterated-pvar)
+                  …)))
 
 (define-syntax/case (shadow pvar new-value) ()
   (match (attribute-info #'pvar '(pvar attr))
diff --git a/test/test-ddd-forms.rkt b/test/test-ddd-forms.rkt
@@ -174,7 +174,6 @@
                  x … …])
               '(1 2 3 4 5 6))
 
-#|
 ;; TODO: expr … inside begin and let
 (check-equal? (syntax-case #'((1 2 3) (4 5)) ()
                   [((x …) …)
@@ -182,7 +181,65 @@
                      (list (length (syntax->list #'(x …)))
                            (+ (syntax-e #'x) 3) …)
                      …)])
-                '([3 (4 5 6)]
-                  [2 (7 8)]))
-|#
+                '([3 4 5 6]
+                  [2 7 8]))
 
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                [([x …] …)
+                 x … …])
+              '(1 2 3 4 5 6))
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                [([x …] …)
+                 (x …) …])
+              '((1 2 3) (4 5 6)))
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                [([x …] …)
+                 ((list x) …) …])
+              '(((1) (2) (3)) ((4) (5) (6))))
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                [([x …] …)
+                 ((+ x 10) …) …])
+              '((11 12 13) (14 15 16)))
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                [([x …] …)
+                 (begin ((+ x 10) …) …)])
+              '((11 12 13) (14 15 16)))
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                [([x …] …)
+                 (define/with-syntax y (+ x 10)) … …
+                 y … …])
+              '(11 12 13 14 15 16))
+
+;; Implicit apply with (+ y … …)
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                  [([x …] …)
+                   (define/with-syntax y (+ x 10)) … …
+                   (+ y … …)])
+                81)
+
+;; Implicit apply with (+ (* x 2) … …)
+(check-equal? (syntax-parse #'([1 2 3] [4 5 6])
+                  [([x …] …)
+                   (+ (* x 2) … …)])
+                42)
+
+;; TODO: (define ) … … should register the variable with current-pvars.
+#;(syntax-parse #'([1 2 3] [4 5 6])
+    [([x …] …)
+     (define y (+ x 10)) … …
+     y … …])
+
+
+
+#lang racket
+
+(require subtemplate/ddd-forms
+         stxparse-info/case
+         stxparse-info/parse
+         rackunit
+         syntax/macro-testing
+         phc-toolkit/untyped)
+
+(syntax-parse #'([1 2 3] #:kw [4 5 6])
+    [({~and {~or [x …] #:kw}} …)
+     ((x …) …)])
+\ No newline at end of file