global.rkt (2255B)
1 #lang racket/base 2 3 (require racket/function 4 racket/list 5 syntax/parse 6 phc-toolkit/untyped 7 (for-syntax racket/base 8 syntax/parse 9 syntax/parse/experimental/template 10 racket/syntax 11 phc-toolkit/untyped) 12 "parameters.rkt" 13 "no-order.rkt") 14 15 (provide ~global-or 16 ~global-and 17 ~global-counter 18 aggregate-global-or 19 aggregate-global-and 20 aggregate-global-counter) 21 22 (define-for-syntax (make-~global f [default #f]) 23 (syntax-parser 24 [(_ (~or [name v] (~and name 25 (~fail #:unless default) 26 (~bind [v default]))) 27 pat ...) 28 #:with clause-value (get-new-clause!) 29 (eh-post-group! '~global-name 30 #'name 31 f 32 #'clause-value) 33 ;; protect the values inside an immutable box, so that a #f can be 34 ;; distinguished from a failed match. 35 #'(~and pat ... 36 (~bind [clause-value (box-immutable v)]))])) 37 38 (define (aggregate-global-or . bs) 39 (true? ;; force the result to be a boolean, the order of terms is unimportant 40 (ormap unbox ;; remove the layer of protection 41 (filter identity ;; remove failed bindings 42 (flatten bs))))) ;; don't care about ellipsis nesting 43 (define-eh-mixin-expander ~global-or 44 (make-~global #'aggregate-global-or #'#t)) 45 46 (define (aggregate-global-and . bs) 47 (let ([matches (filter identity ;; remove failed bindings 48 (flatten bs))]) 49 (if (null? matches) 50 'none ;; no matches occurred 51 (true? ;; coerce to boolean, so that the order of terms is unimportant 52 (andmap unbox ;; remove the layer of protection 53 matches))))) ;; don't care about ellipsis nesting 54 (define-eh-mixin-expander ~global-and 55 (make-~global #'aggregate-global-and)) 56 57 (define (aggregate-global-counter . bs) 58 (apply + (map unbox 59 (filter identity ;; remove failed bindings 60 (flatten bs))))) ;; don't care about ellipsis nesting 61 (define-eh-mixin-expander ~global-counter 62 (make-~global #'aggregate-global-counter #'+1)) 63