diff options
Diffstat (limited to 'csc/loop.csc')
| -rw-r--r-- | csc/loop.csc | 105 |
1 files changed, 73 insertions, 32 deletions
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* ...)) |