Name: Anonymous 2009-12-08 13:45
I haven't been programming much Scheme recently, so I've been out of touch with my macro programming, So I decided to write this for you. Any critique welcome.
Notes:
This was written in PLT Scheme, but the macro itself should be portable.
Yes, I know I could have two macros instead of one, and that it would mean that I only had to export the interface I want.
21 success(es) 0 failure(s) 0 error(s) 21 test(s) run
0
(compare-times)
cpu time: 79 real time: 79 gc time: 0
cpu time: 396 real time: 398 gc time: 159
#t
Notes:
This was written in PLT Scheme, but the macro itself should be portable.
Yes, I know I could have two macros instead of one, and that it would mean that I only had to export the interface I want.
append* is concatenate from SRFI 1.#lang scheme
(define-syntax lc
(syntax-rules (<-)
((lc "helper" return-expr)
return-expr)
((lc "helper" (<- var val) return-expr)
(map (lambda (var)
return-expr)
val))
((lc "helper" (<- var val) (<- var2 val2) expr ...)
(append* (map (lambda (var)
(lc "helper" (<- var2 val2) expr ...))
val)))
((lc "helper" (<- var val) expr return-expr)
(filter-map (lambda (var) (and expr return-expr))
val))
((lc "helper" (<- var val) expr rest ... return-expr)
(append* (filter-map (lambda (var)
(and expr
(lc "helper" rest ... return-expr)))
val)))
((lc return-expr (<- var val) expr ...)
(lc "helper" (<- var val) expr ... return-expr))))
(require (planet schematics/schemeunit:3))
(define-test-suite list-comprehension-tests
(check-equal? (lc (+ x 1) (<- x (list 1 2 3 4 5)))
'(2 3 4 5 6))
(check-equal? (lc #f (<- x '(1 2 3 4)))
'(#f #f #f #f))
(check-equal? (lc #f (<- x '(1 2 3)) (<- y '(1 2 3)))
'(#f #f #f #f #f #f #f #f #f))
(check-equal? (lc #f (<- x '(0 1)) (<- y '(1 2)) (<- z '(3 4)))
'(#f #f #f #f #f #f #f #f))
(check-equal? (lc x (<- x '(1 2 3 4)))
'(1 2 3 4))
(check-equal? (let ((x 4))
(lc x (<- x '(1 2 3 4))))
'(1 2 3 4))
(check-equal? (let ((y 4))
(lc 4 (<- x '(1 2 3 4))))
'(4 4 4 4))
(check-equal? (lc (list x y) (<- x '(1 2 3 4)) (<- y '(2 3 4)))
'((1 2) (1 3) (1 4) (2 2) (2 3) (2 4) (3 2)
(3 3) (3 4) (4 2) (4 3) (4 4)))
(check-equal? (lc x (<- x '(1 2 3 4)) (even? x)) ;;;;;;;;;;;;;;;;;;;;;
'(2 4))
(check-equal? (lc x (<- x '(1 2 3 4)) #f)
'())
(check-equal? (lc x (<- x '(1 2 3 4)) #t)
'(1 2 3 4))
(check-equal? (lc x (<- x '(1 2 3)) (<- y '(1 2 3)) (even? x))
'(2 2 2))
(check-equal? (lc x (<- x '(1 2 3)) (odd? x) (<- y '(1 2)))
'(1 1 3 3))
(check-equal? (lc (cons x y)
(<- x '(1 2 3)) (odd? x) (<- y '(2 3 4 5 6)) (even? y))
'((1 . 2) (1 . 4) (1 . 6) (3 . 2) (3 . 4) (3 . 6)))
(check-equal? (lc (+ x 1) (<- x '(1 2 3)) (<- y '(1 2 3)) #f)
'())
(check-equal? (lc (cons x y) (<- x '(1 2)) (<- y '(1 2 3)) #t)
'((1 . 1) (1 . 2) (1 . 3) (2 . 1) (2 . 2) (2 . 3)))
(check-equal? (lc (+ x y z) (<- x '(1 2)) (<- y '(3 4)) (<- z '(5 6)))
'(9 10 10 11 10 11 11 12))
(check-equal? (lc (list x y z) (<- x '(1 2)) (<- y '( 3 4)) (<- z '(5 6)))
'((1 3 5) (1 3 6) (1 4 5) (1 4 6)
(2 3 5) (2 3 6) (2 4 5) (2 4 6)))
(check-equal? (lc '() (<- x '(1 2 3)))
'(() () ()))
(check-equal? (lc x (<- x '()))
'())
(check-equal? (lc y (<- x '(1 2)) (<- y '()))
'()))
(require (planet schematics/schemeunit:3/text-ui))
(run-tests list-comprehension-tests)
(require srfi/1)
(define (range start end)
(if (< end start)
#f
(unfold (lambda (x) (= x end))
(lambda (x) x)
(lambda (x) (+ x 1))
start)))
(define (compare-times)
(let* ((x (range 1 1000))
(y (range 1 1000)))
(equal? (time (lc x (<- x x) (even? x) (<- y y)))
(time (lc x (<- x x) (<- y y) (even? x))))))21 success(es) 0 failure(s) 0 error(s) 21 test(s) run
0
(compare-times)
cpu time: 79 real time: 79 gc time: 0
cpu time: 396 real time: 398 gc time: 159
#t