diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/loop-test.csc | 169 | ||||
| -rw-r--r-- | csc/loop.csc | 105 |
2 files changed, 230 insertions, 44 deletions
diff --git a/csc/loop-test.csc b/csc/loop-test.csc index df2c970..eb9345b 100644 --- a/csc/loop-test.csc +++ b/csc/loop-test.csc @@ -6,43 +6,43 @@ (csc loop)) -(test for-collect +(test loop-for-collect (assert-equal '(1 2 3 4 5) (loop for x in '(1 2 3 4 5) collect x))) -(test for-collect-add +(test loop-for-collect-add (assert-equal '(2 3 4 5 6) (loop for x in '(1 2 3 4 5) collect (+ 1 x)))) -(test for-arithmetic +(test loop-for-arithmetic (assert-equal '(1 2 3 4 5) (loop for x from 1 to 5 collect x))) -(test for-arithmetic-step +(test loop-for-arithmetic-step (assert-equal '(1 3 5 7 9) (loop for x from 1 to 10 by 2 collect x))) -(test finally-noop +(test loop-finally-noop (assert-equal '(1 2 3) (loop for x from 1 to 3 - finally #t + finally (if #f #f) collect x))) -(test collect-into +(test loop-collect-into (assert-equal '((1 2 3) (1 2 3) (1 2 3)) (loop for x from 1 to 3 @@ -50,7 +50,7 @@ collect l))) -(test finally-set +(test loop-finally-set (assert-equal '(1 2 3) (let ((res #f)) @@ -69,13 +69,13 @@ res))) -(test return +(test loop-return (assert-equal '(1 2 3) (loop do (return '(1 2 3))))) -(test finally-return +(test loop-finally-return (assert-equal '(1 2 3) (loop for x from 1 to 3 @@ -83,7 +83,7 @@ finally (return l)))) -(test for-as-equals-then +(test loop-for-as-equals-then (assert-equal '((1 2 3) (2 3) (3)) (loop for i from 1 to 3 @@ -91,7 +91,15 @@ collect tail))) -(test return-multiple-values +(test loop-for-as-equals + (assert-equal + '((1) (2) (3)) + (loop for i from 1 to 3 + for j = (list i) + collect j))) + + +(test loop-return-multiple-values (let-values (((x1 x2) (loop do (return (values 1 2))))) (assert-equal 1 @@ -106,3 +114,140 @@ '(1 2 3) (loop do (define x (loop do (return '(1 2 3)))) (return x)))) + + +(test loop-with-return + (assert-equal + 5 + (loop with x = 5 + return x))) + + +(test loop-for-x-on-l + (assert-equal + '((1 2 3) (2 3) (3)) + (loop for x on '(1 2 3) + collect x))) + + +(test loop-for-across + (assert-equal + '(1 2 3) + (loop for x across #(1 2 3) + collect x))) + + +(test loop-for-downfrom + (assert-equal + '(3 2 1) + (loop for x to 1 downfrom 3 + collect x))) + + +(test loop-for-to + (assert-equal + '(0 1 2 3) + (loop for x to 3 + collect x))) + + +(test loop-for-downto + (assert-equal + '(3 2 1) + (loop for x downto 1 from 3 + collect x))) + + +(test loop-for-below + (assert-equal + '(0 1 2) + (loop for x below 3 + collect x))) + + +(test loop-for-above + (assert-equal + '(3 2 1) + (loop for x above 0 from 3 + collect x))) + + +(test loop-for-by + (assert-equal + '(0 2 4) + (loop for x by 2 to 4 + collect x))) + + +(test loop-append + (assert-equal + '(1 2 3 4) + (loop for x in '((1 2) (3 4)) + append x))) + + +(test loop-count + (assert-equal + 50 + (loop for x from 1 to 100 + count (even? x)))) + + +(test loop-sum + (assert-equal + 15 + (loop for x from 1 to 5 + sum x))) + + +(test loop-maximize + (assert-equal + 10 + (loop for x in '(3 10 1 4) + maximize x))) + + +(test loop-minimize + (assert-equal + 1 + (loop for x in '(3 10 1 4) + minimize x))) + + +(test loop-if + (assert-equal + 5 + (loop for x from 0 + if (>= x 5) return x))) + + +(test loop-when + (assert-equal + 5 + (loop for x from 0 + when (>= x 5) return x))) + + +(test loop-else + (assert-equal + '((0 2 4) . (1 3 5)) + (loop for x to 5 + if (even? x) collect x into evens + else collect x into odds + finally (return (cons evens odds))))) + + +(test loop-if-compound + (assert-equal + '((0 2 4) . (1 3 5)) + (loop for x to 5 + if (even? x) collect x into list1 + and collect (+ 1 x) into list2 + finally (return (cons list1 list2))))) + + +(test loop-if-end + (assert-equal + 5 + (loop for x from 0 + if (>= x 5) return x end))) diff --git a/csc/loop.csc b/csc/loop.csc index 9c776ca..7f59f9e 100644 --- a/csc/loop.csc +++ b/csc/loop.csc @@ -1,5 +1,5 @@ (define-library (csc loop) - (export loop return loop-aux) + (export loop return) (import (scheme base)) (begin @@ -72,9 +72,9 @@ (let* ((x l) (next x)) (loop-aux "variable-clause-collector" - ((body ... (unless (pair? x) + ((body ... (set! x next) + (unless (pair? x) (raise (make-loop-termination))) - (set! x next) (set! next (cdr x))) fin) clause* ...))) @@ -89,6 +89,12 @@ (set! x subseq))) fin) clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init clause* ...) + (let ((x #f)) + (loop-aux "variable-clause-collector" + ((body ... (set! x init)) + fin) + clause* ...))) ((loop-aux "variable-clause-collector" ((body ...) fin) for x across v clause* ...) (let ((temp v) (i 0) @@ -101,47 +107,55 @@ fin) clause* ...))) ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start to last by inc clause* ...) - (let ((x start) - (last* last) - (inc* inc)) + (let* ((last* last) + (inc* inc) + (x start) + (next x)) (loop-aux "variable-clause-collector" - ((body ... (unless (<= x last*) + ((body ... (set! x next) + (unless (<= x last*) (raise (make-loop-termination))) - (set! x (+ x inc*))) + (set! next (+ x inc*))) fin) clause* ...))) ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start downto last by inc clause* ...) - (let ((x start) - (last* last) - (inc* inc)) + (let* ((last* last) + (inc* inc) + (x start) + (next x)) (loop-aux "variable-clause-collector" - ((body ... (unless (>= x last*) + ((body ... (set! x next) + (unless (>= x last*) (raise (make-loop-termination))) - (set! x (+ x inc*))) + (set! next (+ x inc*))) fin) clause* ...))) ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start below last by inc clause* ...) - (let ((x start) - (last* last) - (inc* inc)) + (let* ((last* last) + (inc* inc) + (x start) + (next x)) (loop-aux "variable-clause-collector" - ((body ... (unless (< x last*) + ((body ... (set! x next) + (unless (< x last*) (raise (make-loop-termination))) - (set! x (+ x inc*))) + (set! next (+ x inc*))) fin) clause* ...))) ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start above last by inc clause* ...) - (let ((x start) - (last* last) - (inc* inc)) + (let* ((last* last) + (inc* inc) + (x start) + (next x)) (loop-aux "variable-clause-collector" - ((body ... (unless (> x last*) + ((body ... (set! x next) + (unless (> x last*) (raise (make-loop-termination))) - (set! x (+ x inc))) + (set! next (+ x inc))) fin) clause* ...))) ((loop-aux "variable-clause-collector" args for x clause* ...) - (loop-aux "for-reordering" args for x #f #f #f 1 clause* ...)) + (loop-aux "for-reordering" args for x #f #f #f #f clause* ...)) ((loop-aux "variable-clause-collector" args clause* ...) (loop-aux "main-clause-collector" args clause* ...)) ((loop-aux "and-collector" args (and-vars ...) and x = expr and clause* ...) @@ -152,28 +166,53 @@ ((loop-aux "for-reordering" args for x #f to-clause by-clause stepping from start clause* ...) (let ((start* start)) (loop-aux "for-reordering" args for x start* to-clause by-clause stepping clause* ...))) - ((loop-aux "for-reordering" args for x #f to-clause by-clause stepping downfrom start clause* ...) + ((loop-aux "for-reordering" args for x #f to-clause by-clause 1 downfrom start clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x #f to-clause by-clause _ downfrom start clause* ...) (let ((start* start)) (loop-aux "for-reordering" args for x start* to-clause by-clause -1 clause* ...))) ((loop-aux "for-reordering" args for x from-clause #f by-clause stepping to last clause* ...) (let ((last* last)) (loop-aux "for-reordering" args for x from-clause (to last*) by-clause stepping clause* ...))) - ((loop-aux "for-reordering" args for x from-clause #f by-clause stepping downto last clause* ...) + ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 downto last clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x from-clause #f by-clause _ downto last clause* ...) (let ((last* last)) (loop-aux "for-reordering" args for x from-clause (downto last*) by-clause -1 clause* ...))) - ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 below last clause* ...) + ((loop-aux "for-reordering" args for x from-clause #f by-clause -1 below last clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x from-clause #f by-clause _ below last clause* ...) (let ((last* last)) (loop-aux "for-reordering" args for x from-clause (below last*) by-clause 1 clause* ...))) + ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 above last clause* ...) + (syntax-error "inconsistent stepping")) ((loop-aux "for-reordering" args for x from-clause #f by-clause _ above last clause* ...) (let ((last* last)) (loop-aux "for-reordering" args for x from-clause (above last*) by-clause -1 clause* ...))) ((loop-aux "for-reordering" args for x from-clause to-clause #f stepping by inc clause* ...) (let ((inc* inc)) (loop-aux "for-reordering" args for x from-clause to-clause inc* stepping clause* ...))) + ((loop-aux "for-reordering" args for x #f #f #f _ clause* ...) + (syntax-error "need at least one for subclause")) + ((loop-aux "for-reordering" args for x from-clause to-clause inc #f clause* ...) + (loop-aux "for-reordering" args for x from-clause to-clause inc 1 clause* ...)) ((loop-aux "for-reordering" args for x #f to-clause inc 1 clause* ...) (loop-aux "for-reordering" args for x 0 to-clause inc 1 clause* ...)) ((loop-aux "for-reordering" args for x from-clause to-clause #f stepping clause* ...) (loop-aux "for-reordering" args for x from-clause to-clause 1 stepping clause* ...)) + ((loop-aux "for-reordering" ((body ...) fin) for x start #f inc stepping clause* ...) + (let* ((inc* inc) + (x start) + (next x)) + (loop-aux "variable-clause-collector" + ((body ... (set! x next) + (set! next (+ x inc*))) + fin) + clause* ...))) + ; The word `to' is ambiguous as to which stepping, so replace to with downto if stepping is -1. + ((loop-aux "for-reordering" args for x start (to last) inc -1 clause* ...) + (loop-aux "for-reordering" args for x start (downto last) inc -1 clause* ...)) + ; Put the reordered form back into variable-clause-collector. ((loop-aux "for-reordering" args for x start (to-clause ...) inc stepping clause* ...) (loop-aux "variable-clause-collector" args for x from start to-clause ... by (* stepping inc) clause* ...)) ((loop-aux "main-clause-collector" args do clause* ...) @@ -189,6 +228,8 @@ ((loop-aux "main-clause-collector" args sum clause* ...) (loop-aux "accumulation" ("accumulation-main-continuation" args) () sum clause* ...)) ((loop-aux "main-clause-collector" args maximize clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () maximize clause* ...)) + ((loop-aux "main-clause-collector" args minimize clause* ...) (loop-aux "accumulation" ("accumulation-main-continuation" args) () minimize clause* ...)) ((loop-aux "main-clause-collector" args if clause* ...) (loop-aux "conditional" ("conditional-main-continuation" args) () if clause* ...)) @@ -241,11 +282,11 @@ (let ((l '()) (last #f)) (loop-aux continuation ... - (compound ... (let ((p (list-copy x))) - (if last - (set-cdr! last p) - (set! l p)) - (set! last p))) + (compound ... (loop for elem in x + for p = (list elem) + if last do (set-cdr! last p) + else do (set! l p) + do (set! last p))) clause* ...))) ((loop-aux "accumulation" continuation compound append x clause* ...) (loop-aux "accumulation" continuation compound append x into l finally (return l) clause* ...)) |