Done most work concerning syntax/parse.

structure-options2.rkt

@@ -17,9 +17,10 @@
          structure-kw-all-mixin)
 
 (define-eh-alternative-mixin structure-kw-instance-or-builder
-  (pattern (~optional (~and instance-or-builder
+  (pattern
-                            (~or (~and instance #:instance)
+   (~optional (~and instance-or-builder
-                                 (~and builder #:builder)))
+                    (~or (~global-or instance #:instance)
+                         (~global-or builder #:builder)))
               #:name "either #:instance or #:builder")))
 
 (define-eh-alternative-mixin structure-kw-predicate
@@ -42,14 +43,18 @@
   (pattern
    (~optional/else
     (~or (~seq (~or-bug [field:id] field:id) …+
+               (~global-or builder)
                (~post-fail no-values-err #:when (attribute instance)))
          (~seq [field:id : type] …+
+               (~global-or builder)
                (~post-fail no-values-err #:when (attribute instance)))
          (~seq [field:id value:expr] …+
+               (~global-or instance)
                (~post-fail values-err #:when (attribute builder)))
          (~seq (~or-bug [field:id value:expr : type]
                         [field:id : type value:expr])
                …+
+               (~global-or instance)
                (~post-fail values-err #:when (attribute builder))))
     #:defaults ([(field 1) (list)]
                 [(value 1) (list)]
@@ -70,20 +75,22 @@
 (define-splicing-syntax-class structure-kws
   (pattern (~no-order (structure-kw-all-mixin))))
 
-(check-equal? (syntax->datum
+(check-equal? (syntax-parse #'(#:instance #:? p)
-               (syntax-parse #'(#:instance #:? p)
                 [(:structure-kws)
-                  #'(instance instance-or-builder
+                 (list* (attribute instance)
+                        (syntax->datum
+                         #'(instance-or-builder
                             predicate
                             [field ...]
-                              [value ...])]))
+                            [value ...])))])
-              '(#:instance #:instance p [] []))
+              '(#t #:instance p [] []))
 
-(check-equal? (syntax->datum
+(check-equal? (syntax-parse #'(#:builder)
-               (syntax-parse #'(#:builder)
                 [(k:structure-kws)
-                  #'(k.builder k.instance-or-builder [k.field ...])]))
+                 (list* (attribute k.builder)
-              '(#:builder #:builder []))
+                        (syntax->datum
+                         #'(k.instance-or-builder [k.field ...])))])
+              '(#t #:builder []))
 
 (test-exn
  "Check that () is rejected, as it has neither #:instance nor #:builder"
@@ -100,18 +107,57 @@ builder-style field declarations"
    (syntax-parse #'(#:instance [f1] [f2])
      [(:structure-kws) #'([field ...] instance)])))
 
-(check-equal? (syntax->datum
+(check-equal? (syntax-parse #'(#:builder #:? p [f1] [f2])
-               (syntax-parse #'(#:builder #:? p [f1] [f2])
+                [(:structure-kws) (list* (attribute builder)
-                 [(:structure-kws) #'([field ...] builder)]))
+                                         (syntax->datum #'([field ...])))])
-              '([f1 f2] #:builder))
+              '(#t [f1 f2]))
 
-(check-equal?  (syntax-parse #'([f1] [f2]); #:? p 
+(check-equal?  (syntax-parse #'([f1] [f2] #:? p)
                  [(:structure-kws) (cons (attribute builder)
                                          (syntax->datum #'([field ...])))])
-               '(#f [f1 f2]))
+               '(#t [f1 f2]))
 
 ;; This one is appropriately rejected
 (check-exn #px"unexpected term"
            (λ ()
              (syntax-parse #'(#:instance #:a)
                [(:structure-kws) 'err])))
+
+(define instance-or-builder?
+  (syntax-parser [(:structure-kws) (list (attr instance) (attr builder))]))
+
+(check-equal? '(#t #f) (instance-or-builder? #'(#:instance)))
+(check-equal? '(#f #t) (instance-or-builder? #'(#:builder)))
+(check-equal? '(#f #t) (instance-or-builder? #'(f1)))
+(check-equal? '(#f #t) (instance-or-builder? #'([f1])))
+(check-equal? '(#f #t) (instance-or-builder? #'([f1] f2)))
+(check-equal? '(#f #t) (instance-or-builder? #'([f1 : type])))
+(check-equal? '(#t #f) (instance-or-builder? #'([f1 value])))
+(check-equal? '(#t #f) (instance-or-builder? #'([f1 : type value])))
+(check-equal? '(#t #f) (instance-or-builder? #'([f1 value : type])))
+(check-equal? '(#f #t) (instance-or-builder? #'(f1 #:builder)))
+(check-equal? '(#f #t) (instance-or-builder? #'([f1] #:builder)))
+(check-equal? '(#f #t) (instance-or-builder? #'([f1] f2 #:builder)))
+(check-equal? '(#f #t) (instance-or-builder? #'([f1 : type] #:builder)))
+(check-equal? '(#t #f) (instance-or-builder? #'([f1 value] #:instance)))
+(check-equal? '(#t #f) (instance-or-builder? #'([f1 : type value] #:instance)))
+(check-equal? '(#t #f) (instance-or-builder? #'([f1 value : type] #:instance)))
+
+;; TODO: use (reified-syntax-class-attributes r) to make a simplified version
+;; of a macro, which just accepts all the attributes. Another macro can
+;; then forward all the attributes at once, with minimal meta-level 1 cost
+;; (obviously, constructing the wrappers etx. will have some metal-level 2 cost)
+;;
+;; Wrapper:
+;; (define-syntax (real-macro-name stx)
+;;   (syntax-parse stx
+;;     [(~reflect whole some-reified-splicing-syntax-class)
+;;      (simplified-macro-implementation (attribute attr0) ...)]))
+;; Implementation
+;; (define-for-syntax (simplified-macro-implementation val0 ...)
+;;   (syntax-parse #'dummy
+;;     [(~bind [(attr0 depth) val0] ...)
+;;      body]))
+;;
+;; For speed, we could just copy the whole implementation in real-macro-name's
+;; definition, instead of calling simplified-macro-implementation.

structure-options2b-test.rkt

@@ -11,5 +11,37 @@
                      syntax/stx
                      racket/format))
 
-(syntax-parse #'(1 #:kw 3)
+(check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
-  [{~no-order {~once {~global-counter #:kw }} }
+                [({~no-order {~once {~global-counter cnt 'occurrencea #:kw}}
+                             {~global-counter cnt 'occurrenceb :number}
+                             "ab"})
+                 (attribute cnt)])
+              5)
+
+(check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
+                [({~no-order {~once {~global-or kw-or-number #t #:kw}}
+                             {~global-or kw-or-number #t :number}
+                             "ab"})
+                 (attribute kw-or-number)])
+              #t)
+
+(check-equal? (syntax-parse #'(1 "ab" "ab" 3 4 5)
+                [({~no-order {~optional {~global-or kw #t #:kw}}
+                             {~global-or kw #f :number}
+                             "ab"})
+                 (attribute kw)])
+              #f)
+
+(check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
+                [({~no-order {~optional {~global-and kw-and-not-number #t #:kw}}
+                             {~global-and kw-and-not-number #f :number}
+                             "ab"})
+                 (attribute kw-and-not-number)])
+              #f)
+
+(check-equal? (syntax-parse #'("ab" #:kw "ab")
+                [({~no-order {~optional {~global-and kw-and-not-number #t #:kw}}
+                               {~global-and kw-and-not-number #f :number}
+                               "ab"})
+                 (attribute kw-and-not-number)])
+              #t)

structure-options2b.rkt

@@ -5,11 +5,13 @@
          generic-syntax-expanders
          phc-toolkit/untyped
          (for-syntax syntax/parse
+                     syntax/parse/experimental/template
                      racket/syntax
                      phc-toolkit/untyped
                      racket/list
                      generic-syntax-expanders
-                     racket/contract))
+                     racket/function
+                     racket/pretty))
 
 (provide ;define-splicing-syntax-class-with-eh-mixins
  ;define-syntax-class-with-eh-mixins
@@ -22,7 +24,10 @@
  ~optional/else
  ~global-or
  ~global-and
- ~global-counter)
+ ~global-counter
+ aggregate-global-or
+ aggregate-global-and
+ aggregate-global-counter)
 
 ;; ------------
 ;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
@@ -41,7 +46,7 @@
       (apply (parameter-name) args))))
 
 (define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!)
-(define-dynamic-accumulator-parameter eh-pre-declarations eh-pre-declare!)
+(define-dynamic-accumulator-parameter eh-post-group eh-post-group!)
 
 ;; ----
 
@@ -75,36 +80,42 @@
    (λ (stx)
      (syntax-case stx ()
        [(self pat ...)
+        ((λ (x) #;(pretty-write (syntax->datum x)) x)
          (let ()
            (define counter 0)
            (define (increment-counter)
              (begin0 counter
                      (set! counter (add1 counter))))
+           ;; post-acc gathers some a-patterns which will be added after the
+           ;; (~seq (~or ) ...)
            (define post-acc '())
            (define (add-to-post! v) (set! post-acc (cons v post-acc)))
-          ;; pre-acc gathers some bindings that have to be pre-declared
+           ;; post-groups-acc gathers some attributes that have to be grouped
-          (define pre-acc (make-hash))
+           (define post-groups-acc '())
-          (define/contract (add-to-pre! s v) (-> symbol? any/c identifier?)
+           (define (add-to-post-groups! . v)
-            (define not-found (gensym))
+             (set! post-groups-acc (cons v post-groups-acc)))
-            (define ref (hash-ref pre-acc s #f))
+           ;; expand EH alternatives:
-            (if ref
-                (car ref)
-                (let ([id (datum->syntax (syntax-local-introduce #'here) s)])
-                  (hash-set! pre-acc s (cons id v))
-                  id)))
-          ;(define-values (pre-acc add-to-pre) (make-mutable-accumulator))
            (define alts
              (parameterize ([eh-post-accumulate add-to-post!]
-                           [eh-pre-declarations add-to-pre!]
+                            [eh-post-group add-to-post-groups!]
                             [clause-counter increment-counter])
                (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
-          (define pre-acc-bindings (hash-map pre-acc
+           (define post-group-bindings
-                                             (λ (s bv) #`(define . #,bv))))
+             (for/list ([group (group-by car post-groups-acc free-identifier=?)])
+               ;; each item in `group` is a four-element list:
+               ;; (list result-id aggregate-function attribute)
+               (define/with-syntax name (first (car group))
+                 #;(syntax-local-introduce
+                    (datum->syntax #'here
+                                   (first (car group)))))
+               (define/with-syntax f (second (car group)))
+               #`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
+                                   group))]))
            #`(~delimit-cut
-             (~and (~do #,@pre-acc-bindings)
+              (~and (~seq (~or . #,alts) (... ...))
-                   (~seq (~or . #,alts) (... ...))
                     ~!
-                   #,@post-acc)))]))))
+                    (~bind #,@post-group-bindings)
+                    #,@post-acc))))]))))
 
 (define-syntax ~nop
   (pattern-expander
@@ -142,17 +153,40 @@
        [(self (mutex:id ...) pat ...)
         #'(???)]))))
 
-(define-syntax-rule (define-~global ~global-name init f)
+(define-syntax/parse (define-~global global-name (~optional default) f)
-  (define-eh-mixin-expander ~global-name
+  (define use-default-v? (syntax-e #'default-v?))
-    (λ/syntax-case (_ name v pat) ()
+  (template
-      (eh-pre-declare! '~bool-or (syntax-e #'name) init)
+   (define-eh-mixin-expander global-name
-      #`(~and (~do (define tmp name))
+     (syntax-parser
-              (~do (define name (#,f tmp v)))
+       [(_ (?? (~or [name v] (~and name (~bind [v default])))
-              pat))))
+               [name v])
+           . pat)
+        (define/with-syntax clause-value (get-new-clause!))
+        (eh-post-group! '~global-name
+                        #'name ;(syntax-e #'name)
+                        #'f
+                        #'clause-value)
+        ;; protect the values inside an immutable box, so that a #f can be
+        ;; distinguished from a failed match.
+        #'(~and (~bind [clause-value (box-immutable v)])
+                . pat)]))))
 
-(define-~global ~global-or #f (λ (acc v) (or acc v)))
+(define (aggregate-global-or . bs)
-(define-~global ~global-and #t (λ (acc v) (and acc v)))
+  (ormap unbox ;; remove the layer of protection
-(define-~global ~global-counter 0 add1)
+         (filter identity ;; remove failed bindings
+                 (flatten bs)))) ;; don't care about ellipsis nesting
+(define-~global ~global-or #'#t aggregate-global-or)
+
+(define (aggregate-global-and . bs)
+  (andmap unbox ;; remove the layer of protection
+          (filter identity ;; remove failed bindings
+                  (flatten bs)))) ;; don't care about ellipsis nesting
+(define-~global ~global-and aggregate-global-and)
+
+(define (aggregate-global-counter . bs)
+  (length (filter identity ;; remove failed bindings
+                  (flatten bs)))) ;; don't care about ellipsis nesting
+(define-~global ~global-counter #''occurrence aggregate-global-counter)
 
 (define-eh-mixin-expander ~optional/else
   (syntax-parser