diff options
Diffstat (limited to 'csc/loop.csc')
| -rw-r--r-- | csc/loop.csc | 194 |
1 files changed, 194 insertions, 0 deletions
diff --git a/csc/loop.csc b/csc/loop.csc new file mode 100644 index 0000000..c7331fe --- /dev/null +++ b/csc/loop.csc @@ -0,0 +1,194 @@ +(define-library (csc loop) + (export loop return) + (import (scheme base)) + (begin + + + (define-syntax initial-values + (syntax-rules (= + by + collect + do + for + from + in + into + then + to) + ((initial-values loop-name (acc* ...) ((for _ in l temp-name) clause clause* ...) body) + (initial-values loop-name (acc* ... (temp-name l)) (clause clause* ...) body)) + ((initial-values loop-name (acc* ...) ((for x from start to _ by _) clause clause* ...) body) + (initial-values loop-name (acc* ... (x start)) (clause clause* ...) body)) + ((initial-values loop-name (acc* ...) ((for x = init then consequent) clause clause* ...) body) + (initial-values loop-name (acc* ... (x init)) (clause clause* ...) body)) + ((initial-values loop-name (acc* ...) ((collect _ into l last) clause clause* ...) body) + (initial-values loop-name (acc* ... (l '()) (last #f)) (clause clause* ...) body)) + ((initial-values loop-name (acc* ...) ((collect _ l last)) body) + (let loop-name (acc* ... (l '()) (last #f)) + body)) + ((initial-values loop-name (acc* ...) ((do _)) body) + (let loop-name (acc* ...) + body)))) + + + (define-syntax subsequent-values + (syntax-rules (= + by + collect + do + for + from + in + into + then + to) + ((subsequent-values loop-name (acc* ...) (for _ in _ l) clause clause* ...) + (subsequent-values loop-name (acc* ... (cdr l)) clause clause* ...)) + ((subsequent-values loop-name (acc* ...) (for x from _ to _ by inc) clause clause* ...) + (subsequent-values loop-name (acc* ... (+ x inc)) clause clause* ...)) + ((subsequent-values loop-name (acc* ...) (for x = _ then consequent) clause clause* ...) + (subsequent-values loop-name (acc* ... consequent) clause clause* ...)) + ((subsequent-values loop-name (acc* ...) (collect expr into l last) clause clause* ...) + (if last + (begin + (set-cdr! last (list expr)) + (subsequent-values loop-name (acc* ... l (cdr last)) clause clause* ...)) + (begin + (set! l (list expr)) + (subsequent-values loop-name (acc* ... l l) clause clause* ...)))) + ((subsequent-values loop-name (acc* ...) (collect expr l last)) + (if last + (begin + (set-cdr! last (list expr)) + (loop-name acc* ... l (cdr last))) + (begin + (set! l (list expr)) + (loop-name acc* ... l l)))) + ((subsequent-values loop-name (acc* ...) (do expr)) + (begin + expr + (loop-name acc* ...))))) + + + (define-syntax condition + (syntax-rules (= + by + collect + for + from + in + into + then + to) + ((condition) + #t) + ((condition (for _ in _ l) clause* ...) + (and (pair? l) (condition clause* ...))) + ((condition (for x from _ to limit by _) clause* ...) + (and (<= x limit) (condition clause* ...))) + ((condition (for _ = _ then _) clause* ...) + (condition clause* ...)) + ((condition (collect _ into _ _) clause* ...) + (condition clause* ...)))) + + + (define-syntax result + (syntax-rules (collect) + ((result (collect _ l _)) + l) + ((result (do _)) + (if #f #f)))) + + + (define-syntax bindings + (syntax-rules (= + by + collect + for + from + in + into + then + to) + ((bindings () body) + body) + ((bindings ((for x in _ l) clause* ...) body) + (let ((x (car l))) + (bindings (clause* ...) + body))) + ((bindings ((for _ from _ to _ by _) clause* ...) body) + (bindings (clause* ...) body)) + ((bindings ((for _ = _ then _) clause* ...) body) + (bindings (clause* ...) body)) + ((bindings ((collect _ into _ _) clause* ...) body) + (bindings (clause* ...) body)))) + + + (define (*current-loop-continuation* . args) + (error "Can't use return outside of a loop")) + + + (define-syntax loop-clauses + (syntax-rules () + ((loop-clauses (clause* ...) fin body) + (call/cc + (lambda (k) + (define prev-loop-continuation *current-loop-continuation*) + (dynamic-wind + (lambda () + (set! *current-loop-continuation* k)) + (lambda () + (initial-values loop-name () (clause* ... body) + (if (condition clause* ...) + (bindings (clause* ...) + (subsequent-values loop-name () clause* ... body)) + (begin + fin + (result body))))) + (lambda () + (set! *current-loop-continuation* prev-loop-continuation)))))))) + + + (define-syntax clause-collector + (syntax-rules (= + by + collect + do + finally + for + from + in + into + then + to) + ((clause-collector (acc ...) fin for x in l clause clause* ...) + (clause-collector (acc ... (for x in l temp-name)) fin clause clause* ...)) + ((clause-collector (acc ...) fin for x from start to limit by step clause clause* ...) + (clause-collector (acc ... (for x from start to limit by step)) fin clause clause* ...)) + ((clause-collector (acc ...) fin for x from start to limit clause clause* ...) + (clause-collector (acc ... (for x from start to limit by 1)) fin clause clause* ...)) + ((clause-collector (acc ...) fin for x = init then subsequent clause clause* ...) + (clause-collector (acc ... (for x = init then subsequent)) fin clause clause* ...)) + ((clause-collector (acc ...) fin collect x into l clause clause* ...) + (clause-collector (acc ... (collect x into l temp-name)) fin clause clause* ...)) + ((clause-collector (acc ...) #f finally expr) + (loop-clauses (acc ...) expr (do (if #f #f)))) + ((clause-collector (acc ...) #f finally expr clause clause* ...) + (clause-collector (acc ...) expr clause clause* ...)) + ((clause-collector (acc ...) fin collect expr) + (loop-clauses (acc ...) fin (collect expr temp1 temp2))) + ((clause-collector (acc ...) fin do body body* ...) + (loop-clauses (acc ...) fin (do (let () body body* ...)))))) + + + ; loop is a general purpose looping construct cribbed from CL. + (define-syntax loop + (syntax-rules () + ((loop clause clause* ...) + (clause-collector () #f clause clause* ...)))) + + + (define-syntax return + (syntax-rules () + ((return expr) + (call-with-values (lambda () expr) *current-loop-continuation*)))))) |