diff --git a/qi-lib/flow/core/compiler/1000-qi0.rkt b/qi-lib/flow/core/compiler/1000-qi0.rkt index bd2fe944..04a3bbb8 100644 --- a/qi-lib/flow/core/compiler/1000-qi0.rkt +++ b/qi-lib/flow/core/compiler/1000-qi0.rkt @@ -395,25 +395,25 @@ the DSL. (define (deforestable-parser stx) (syntax-parse stx - [((~datum #%deforestable) ((~datum filter) proc:clause)) + [((~datum #%deforestable) (~datum filter) (proc:clause)) #'(lambda (v) (filter (qi0->racket proc) v))] - [((~datum #%deforestable) ((~datum filter-map) proc:clause)) + [((~datum #%deforestable) (~datum filter-map) (proc:clause)) #'(lambda (v) (filter-map (qi0->racket proc) v))] - [((~datum #%deforestable) ((~datum map) proc:clause)) + [((~datum #%deforestable) (~datum map) (proc:clause)) #'(lambda (v) (map (qi0->racket proc) v))] - [((~datum #%deforestable) ((~datum foldl) proc:clause init:expr)) + [((~datum #%deforestable) (~datum foldl) (proc:clause) (init:expr)) #'(lambda (v) (foldl (qi0->racket proc) init v))] - [((~datum #%deforestable) ((~datum foldr) proc:clause init:expr)) + [((~datum #%deforestable) (~datum foldr) (proc:clause) (init:expr)) #'(lambda (v) (foldr (qi0->racket proc) init v))] - [((~datum #%deforestable) ((~datum range) arg:expr ...)) + [((~datum #%deforestable) (~datum range) () (arg:expr ...)) #'(lambda () (range arg ...))] - [((~datum #%deforestable) ((~datum take) n:expr)) + [((~datum #%deforestable) (~datum take) () (n:expr)) #'(lambda (v) (take v n))] [((~datum #%deforestable) (~datum car)) @@ -424,7 +424,7 @@ the DSL. #'caddr] [((~datum #%deforestable) (~datum cadddr)) #'cadddr] - [((~datum #%deforestable) ((~datum list-ref) n:expr)) + [((~datum #%deforestable) (~datum list-ref) () (n:expr)) #'(lambda (v) (list-ref v n))] [((~datum #%deforestable) (~datum length)) diff --git a/qi-lib/flow/core/compiler/deforest/syntax.rkt b/qi-lib/flow/core/compiler/deforest/syntax.rkt index 31bd6ca2..6c4ce6d9 100644 --- a/qi-lib/flow/core/compiler/deforest/syntax.rkt +++ b/qi-lib/flow/core/compiler/deforest/syntax.rkt @@ -51,7 +51,7 @@ #:attributes (blanket? fine? arg pre-arg post-arg) #:literal-sets (fs-literals) #:datum-literals (range) - (pattern (#%deforestable (range the-arg ...)) + (pattern (#%deforestable range () (the-arg ...)) #:attr arg #'(the-arg ...) #:attr pre-arg #f #:attr post-arg #f @@ -80,25 +80,25 @@ #:attributes (f) #:literal-sets (fs-literals) #:datum-literals (filter) - (pattern (#%deforestable (filter (#%host-expression f))))) + (pattern (#%deforestable filter (f)))) (define-syntax-class fst-map #:attributes (f) #:literal-sets (fs-literals) #:datum-literals (map) - (pattern (#%deforestable (map (#%host-expression f))))) + (pattern (#%deforestable map (f)))) (define-syntax-class fst-filter-map #:attributes (f) #:literal-sets (fs-literals) #:datum-literals (filter-map) - (pattern (#%deforestable (filter-map (#%host-expression f))))) + (pattern (#%deforestable filter-map (f)))) (define-syntax-class fst-take #:attributes (n) #:literal-sets (fs-literals) #:datum-literals (take) - (pattern (#%deforestable (take (#%host-expression n))))) + (pattern (#%deforestable take () ((#%host-expression n))))) (define-syntax-class fst-syntax0 (pattern (~or _:fst-filter @@ -123,18 +123,18 @@ #:literal-sets (fs-literals) #:datum-literals (foldr) (pattern (#%deforestable - (foldr - (#%host-expression op) - (#%host-expression init))))) + foldr + (op) + ((#%host-expression init))))) (define-syntax-class fsc-foldl #:attributes (op init) #:literal-sets (fs-literals) #:datum-literals (foldl) (pattern (#%deforestable - (foldl - (#%host-expression op) - (#%host-expression init))))) + foldl + (op) + ((#%host-expression init))))) (define-syntax-class cad*r-datum #:attributes (countdown) @@ -147,12 +147,14 @@ #:attributes (pos name) #:literal-sets (fs-literals) #:datum-literals (list-ref) - (pattern (#%deforestable (list-ref idx)) - #:attr pos #'idx - #:attr name #'list-ref) + ;; TODO: need #%host-expression wrapping idx? + (pattern (#%deforestable list-ref (idx)) + #:attr pos #'idx + #:attr name #'list-ref) + ;; TODO: bring wrapping #%deforestable out here? (pattern cad*r:cad*r-datum - #:attr pos #'cad*r.countdown - #:attr name #'cad*r)) + #:attr pos #'cad*r.countdown + #:attr name #'cad*r)) (define-syntax-class fsc-length #:literal-sets (fs-literals) diff --git a/qi-lib/list.rkt b/qi-lib/list.rkt index d7c93228..93b4b575 100644 --- a/qi-lib/list.rkt +++ b/qi-lib/list.rkt @@ -12,30 +12,30 @@ "macro.rkt") (define-qi-syntax-rule (map f:expr) - (#%deforestable (map f))) + (#%deforestable map (f))) (define-qi-syntax-rule (filter f:expr) - (#%deforestable (filter f))) + (#%deforestable filter (f))) (define-qi-syntax-rule (filter-map f:expr) - (#%deforestable (filter-map f))) + (#%deforestable filter-map (f))) (define-qi-syntax-rule (foldl f:expr init:expr) - (#%deforestable (foldl f init))) + (#%deforestable foldl (f) (init))) (define-qi-syntax-rule (foldr f:expr init:expr) - (#%deforestable (foldr f init))) + (#%deforestable foldr (f) (init))) (define-qi-syntax-parser range - [(_ low:expr high:expr step:expr) #'(#%deforestable (range low high step))] - [(_ low:expr high:expr) #'(range low high 1)] - [(_ high:expr) #'(range 0 high 1)] + [(_ low:expr high:expr step:expr) #'(#%deforestable range () (low high step))] + [(_ low:expr high:expr) #'(#%deforestable range () (low high 1))] + [(_ high:expr) #'(#%deforestable range () (0 high 1))] [_:id (report-syntax-error this-syntax "(range arg ...)" "range expects at least one argument")]) (define-qi-syntax-rule (take n:expr) - (#%deforestable (take n))) + (#%deforestable take () (n))) (define-qi-syntax-parser car [_:id #'(#%deforestable car)]) @@ -50,7 +50,7 @@ [_:id #'(#%deforestable cadddr)]) (define-qi-syntax-rule (list-ref n:expr) - (#%deforestable (list-ref n))) + (#%deforestable list-ref () (n))) (define-qi-syntax-parser length [_:id #'(#%deforestable length)]) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 0b409643..c47eb242 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -286,14 +286,14 @@ "normal racket expressions")) (test-suite "#%deforestable" - (check-equal? ((☯ (#%deforestable (filter odd?))) (list 1 2 3)) (list 1 3)) - (check-equal? ((☯ (#%deforestable (map sqr))) (list 1 2 3)) (list 1 4 9)) - (check-equal? ((☯ (#%deforestable (foldl + 0))) (list 1 2 3)) 6) - (check-equal? ((☯ (#%deforestable (foldr + 0))) (list 1 2 3)) 6) - (check-equal? ((☯ (#%deforestable (range 3)))) (list 0 1 2)) - (check-equal? ((☯ (#%deforestable (range 0 3)))) (list 0 1 2)) - (check-equal? ((☯ (#%deforestable (range 0 5 2)))) (list 0 2 4)) - (check-equal? ((☯ (#%deforestable (take 2))) (list 1 2 3)) (list 1 2))) + (check-equal? ((☯ (#%deforestable filter (odd?))) (list 1 2 3)) (list 1 3)) + (check-equal? ((☯ (#%deforestable map (sqr))) (list 1 2 3)) (list 1 4 9)) + (check-equal? ((☯ (#%deforestable foldl (+) (0))) (list 1 2 3)) 6) + (check-equal? ((☯ (#%deforestable foldr (+) (0))) (list 1 2 3)) 6) + (check-equal? ((☯ (#%deforestable range () (3)))) (list 0 1 2)) + (check-equal? ((☯ (#%deforestable range () (0 3)))) (list 0 1 2)) + (check-equal? ((☯ (#%deforestable range () (0 5 2)))) (list 0 2 4)) + (check-equal? ((☯ (#%deforestable take () (2))) (list 1 2 3)) (list 1 2))) (test-suite "elementary boolean gates" (test-suite