;;; -*- Mode: Scheme -*- ;;;; Extensible Looping Macros, version 7 ;;; This code is written by Taylor R. Campbell and placed in the Public ;;; Domain. All warranties are disclaimed. ;;; This is a variation on Alex Shinn's looping macros described in ;;; message-id <1157562097.001179.11470@i42g2000cwa.googlegroups.com>. ;;; It has diverged substantially from the original macros, and is now ;;; documented at . ;;; ;;; This file depends on syn-param.scm, also by Taylor R. Campbell, and ;;; SRFI 11 (LET-VALUES). Ideally, the implementation of LET-VALUES ;;; should gracefully handle single-value clauses to elide superfluous ;;; uses of CALL-WITH-VALUES. (define-syntax loop (syntax-rules () ((LOOP ((loop-clause0 loop-clause1 ...) ...) body ...) (LOOP ANONYMOUS-LOOP ((loop-clause0 loop-clause1 ...) ...) body ... (ANONYMOUS-LOOP))) ((LOOP name ((loop-clause0 loop-clause1 ...) ...) body ...) (%LOOP START name ((loop-clause0 loop-clause1 ...) ...) (body ...))))) ;;; Use this definition of SYNTACTIC-ERROR if your favourite Scheme ;;; doesn't have one already. Note that this is distinct from a ;;; SYNTAX-ERROR procedure, since it must signal a compile-time error. (define-syntax syntactic-error (syntax-rules ())) ;;; Utility for reporting syntax errors in LOOP clauses. (define-syntax loop-clause-error (syntax-rules () ((LOOP-CLAUSE-ERROR (macro (variable ...) arguments message)) (SYNTACTIC-ERROR message (FOR variable ... (macro . arguments)))))) ;;;; The Guts of LOOP (define-syntax %loop (syntax-rules (=> FOR WITH LET LET-VALUES WHILE UNTIL START GO PARSE-FOR CONTINUE FINISH SIMPLIFY-BODY) ((%LOOP START name loop-clauses body) (%LOOP GO name (() () () () () () () ()) loop-clauses body)) ;; Simple case of a single variable, for clarity. ((%LOOP GO name state ((FOR variable (looper argument ...)) . loop-clauses) body) (looper (variable) (argument ...) %LOOP CONTINUE name state loop-clauses body)) ;; FOR handler with tail patterns. Unfortunately, tail patterns are non- ;; standard... ;; ;; ((%LOOP GO name state ;; ((FOR variable0 variable1 ... (looper argument ...)) ;; . loop-clauses) ;; body) ;; (looper (variable0 variable1 ...) ;; (argument ...) ;; %LOOP CONTINUE name state loop-clauses body)) ;;;;; FOR Clauses: Dealing with Iterators ((%LOOP GO name state ((FOR variable0 variable1 variable2 ...) . loop-clauses) body) (%LOOP PARSE-FOR (variable0 variable1 variable2 ...) () (FOR variable0 variable1 variable2 ...) ;Copy for error message. name state loop-clauses body)) ((%LOOP PARSE-FOR ((looper argument ...)) variables original-clause name state loop-clauses body) (looper variables (argument ...) %LOOP CONTINUE name state loop-clauses body)) ((%LOOP PARSE-FOR (next-variable more0 more1 ...) (variable ...) original-clause name state loop-clauses body) (%LOOP PARSE-FOR (more0 more1 ...) (variable ... next-variable) original-clause name state loop-clauses body)) ((%LOOP PARSE-FOR (non-list) variables original-clause name state loop-clauses body) (SYNTACTIC-ERROR "Malformed FOR clause in LOOP:" original-clause)) ((%LOOP ((outer-bvl outer-producer) ...) ((loop-variable loop-initializer loop-stepper) ...) ((entry-bvl entry-producer) ...) (termination-condition ...) ((body-bvl body-producer) ...) ((final-bvl final-producer) ...) CONTINUE name ((loop-variables ...) user-bindings user-termination-conditions outer-bindings entry-bindings termination-conditions body-bindings final-bindings) loop-clauses body) (%LOOP GO name (;; Preserve the order of loop variables, so that the user ;; can put hers first and still use positional arguments. (loop-variables ... (loop-variable loop-initializer loop-stepper) ...) user-bindings user-termination-conditions ((outer-bvl outer-producer) ... . outer-bindings) ((entry-bvl entry-producer) ... . entry-bindings) (termination-condition ... . termination-conditions) ((body-bvl body-producer) ... . body-bindings) ((final-bvl final-producer) ... . final-bindings)) loop-clauses body)) ;;;;; User-Directed Clauses ((%LOOP GO name state ((WITH variable initializer) . loop-clauses) body) (%LOOP GO name state ((WITH variable initializer variable) . loop-clauses) body)) ((%LOOP GO name ((loop-variable ...) . more-state) ((WITH variable initializer stepper) . loop-clauses) body) (%LOOP GO name ;; Preserve ordering of the user's loop variables. ((loop-variable ... (variable initializer stepper)) . more-state) loop-clauses body)) ((%LOOP GO name state ((LET variable expression) . loop-clauses) body) (%LOOP GO name state ((LET-VALUES (variable) expression) . loop-clauses) body)) ((%LOOP GO name (loop-variables (user-binding ...) . more-state) ((LET-VALUES user-bvl user-producer) . loop-clauses) body) (%LOOP GO name (loop-variables ;; Preserve order of the user's termination conditions. (user-binding ... (user-bvl user-producer)) . more-state) loop-clauses body)) ((%LOOP GO name state ((WHILE condition) . loop-clauses) body) (%LOOP GO name state ((UNTIL (NOT condition)) . loop-clauses) body)) ((%LOOP GO name (loop-variables user-bindings (user-termination-condition ...) . more-state) ((UNTIL user-termination-condition*) . loop-clauses) body) (%LOOP GO name (loop-variables user-bindings (user-termination-condition ... user-termination-condition*) . more-state) loop-clauses body)) ;; Compatibility forms. These clauses *must* come after all ;; others, because there is no keyword, so these would shadow any ;; clauses with keywords. ((%LOOP GO name state ((variable initializer) . loop-clauses) body) (%LOOP GO name state ((WITH variable initializer) . loop-clauses) body)) ((%LOOP GO name state ((variable initializer stepper) . loop-clauses) body) (%LOOP GO name state ((WITH variable initializer stepper) . loop-clauses) body)) ((%LOOP GO name state (clause . loop-clauses) body) (SYNTACTIC-ERROR "Malformed LOOP clause:" clause)) ;;;;; Finishing -- Generating Output ((%LOOP GO name state () (=> result-form . body)) (%LOOP FINISH name state result-form body)) ((%LOOP GO name state () body) (%LOOP FINISH name state (IF #F #F) body)) ((%LOOP FINISH name (((loop-variable loop-initializer loop-stepper) ...) user-bindings user-termination-conditions outer-bindings entry-bindings termination-conditions body-bindings final-bindings) result-form body) (LET-VALUES outer-bindings (DEFINE (LOOP-PROCEDURE loop-variable ...) (LET-VALUES entry-bindings (%LOOP SIMPLIFY-BODY termination-conditions (LET-VALUES final-bindings (WITH-EXTENDED-PARAMETER-OPERATORS ((name (LOOP-PROCEDURE (loop-variable . loop-stepper) ...))) result-form)) body-bindings user-bindings user-termination-conditions (WITH-EXTENDED-PARAMETER-OPERATORS ((name (LOOP-PROCEDURE (loop-variable . loop-stepper) ...))) . body)))) (LOOP-PROCEDURE loop-initializer ...))) ;;;;;; Simplifying the Body ;; No iterator- or user-introduced termination conditions at all. ;; No test or closure needed. ((%LOOP SIMPLIFY-BODY () final-form body-bindings user-bindings () body-form) (LET-VALUES body-bindings (LET-VALUES user-bindings body-form))) ;; Iterator-introduced termination conditions only. One test and ;; no closure needed. ((%LOOP SIMPLIFY-BODY (termination-condition ...) final-form body-bindings user-bindings () ;No user termination conditions body-form) (IF (OR termination-condition ...) final-form (LET-VALUES body-bindings (LET-VALUES user-bindings body-form)))) ;; The closure is needed here because the body bindings shouldn't ;; be visible in the final form. ((%LOOP SIMPLIFY-BODY () final-form body-bindings user-bindings (user-termination-condition ...) body-form) (LET ((FINISH (LAMBDA () final-form))) (LET-VALUES body-bindings (LET-VALUES user-bindings (IF (OR user-termination-condition ...) (FINISH) body-form))))) ((%LOOP SIMPLIFY-BODY (termination-condition ...) final-form body-bindings user-bindings (user-termination-condition ...) body-form) (LET ((FINISH (LAMBDA () final-form))) (IF (OR termination-condition ...) (FINISH) (LET-VALUES body-bindings (LET-VALUES user-bindings (IF (OR user-termination-condition ...) (FINISH) body-form)))))))) ;;;; Accumulators ;;; Accumulators have the following syntax: ;;; ;;; (FOR (ACCUMULATING )) ;;; (FOR (ACCUMULATING (IF ))) ;;; (FOR (ACCUMULATING => )) ;COND-style ;;; (FOR (ACCUMULATING ;SRFI-61-style ;;; => )) ;;; ;;; In addition, some of them support initial values, which are ;;; specified with an optional first argument of (INITIAL ). For example, to accumulate a list starting with some tail ;;; , write ;;; ;;; (FOR (LISTING (INITIAL ) )). (define-syntax listing (syntax-rules (INITIAL) ((LISTING variables ((INITIAL tail-expression) . arguments) next . rest) (%ACCUMULATING variables arguments (((TAIL) tail-expression)) ('() CONS (LAMBDA (RESULT) (APPEND-REVERSE RESULT TAIL))) (LISTING variables ((INITIAL tail-expression) . arguments) "Malformed LISTING clause in LOOP:") next . rest)) ((LISTING variables arguments next . rest) (%ACCUMULATING variables arguments () ('() CONS REVERSE) (LISTING variables arguments "Malformed LISTING clause in LOOP:") next . rest)))) (define-syntax listing-reverse (syntax-rules (INITIAL) ((LISTING-REVERSE variables ((INITIAL tail-expression) . arguments) next . rest) (%ACCUMULATING variables arguments (((TAIL) tail-expression)) (TAIL CONS) (LISTING-REVERSE variables ((INITIAL tail-expression) . arguments) "Malformed LISTING-REVERSE clause in LOOP:") next . rest)) ((LISTING-REVERSE variables arguments next . rest) (%ACCUMULATING variables arguments () ('() CONS) (LISTING-REVERSE variables arguments "Malformed LISTING-REVERSE clause in LOOP:") next . rest)))) ;;; This is non-reentrant but produces precisely one garbage cons cell. (define-syntax listing! (syntax-rules () ((LISTING! variables arguments next . rest) (%LISTING! variables arguments (CONS #F '()) (LISTING! variables arguments "Malformed LISTING! clause in LOOP:") next . rest)))) (define-syntax listing-into! (syntax-rules () ((LISTING-INTO! variables (first-expression . arguments) next . rest) (%LISTING! variables arguments first-expression (LISTING-INTO! variables (first-expression . arguments) "Malformed LISTING-INTO! clause in LOOP:") next . rest)))) (define-syntax %listing! (syntax-rules (INITIAL) ((%LISTING! variables ((INITIAL tail-expression) . arguments) first-expression error-context next . rest) (%ACCUMULATING variables arguments (((FIRST TAIL) (LET ((FIRST first-expression) (TAIL tail-expression)) (SET-CDR! FIRST TAIL) (VALUES FIRST TAIL)))) (FIRST (LAMBDA (DATUM PREVIOUS-CELL) (LET ((NEXT-CELL (CONS DATUM TAIL))) (SET-CDR! PREVIOUS-CELL NEXT-CELL) NEXT-CELL)) (LAMBDA (CELL) CELL (CDR FIRST))) error-context next . rest)) ((%LISTING! variables arguments first-expression error-context next . rest) (%LISTING! variables ((INITIAL '()) . arguments) first-expression error-context next . rest)))) ;;;;; List Appending Accumulators (define-syntax appending (syntax-rules (INITIAL) ((APPENDING variables ((INITIAL tail-expression) . arguments) next . rest) (%ACCUMULATING variables arguments (((TAIL) tail-expression)) ('() APPEND-REVERSE (LAMBDA (RESULT) (APPEND-REVERSE RESULT TAIL))) (APPENDING variables ((INITIAL tail-expression) . arguments) "Malformed APPENDING clause in LOOP:") next . rest)) ((APPENDING variables arguments next . rest) (%ACCUMULATING variables arguments () ('() APPEND-REVERSE REVERSE) (APPENDING variables arguments "Malformed APPENDING clause in LOOP:") next . rest)))) (define-syntax appending-reverse (syntax-rules (INITIAL) ((APPENDING-REVERSE variables ((INITIAL tail-expression) . arguments) next . rest) (%ACCUMULATING variables arguments (((TAIL) tail-expression)) (TAIL APPEND-REVERSE) (APPENDING-REVERSE variables ((INITIAL tail-expression) . arguments) "Malformed APPENDING-REVERSE clause in LOOP:") next . rest)) ((APPENDING-REVERSE variables arguments next . rest) (%ACCUMULATING variables arguments () ('() APPEND-REVERSE) (APPENDING-REVERSE variables arguments "Malformed APPENDING-REVERSE clause in LOOP:") next . rest)))) ;; (define (append-reverse list tail) ;; (loop ((FOR elt (IN-LIST list)) ;; (FOR result (LISTING-REVERSE (INITIAL tail) elt))) ;; => result)) (define (append-reverse list tail) (if (pair? list) (append-reverse (cdr list) (cons (car list) tail)) tail)) ;;;;; Numerical Accumulators (define-syntax summing (syntax-rules (INITIAL) ((SUMMING variables ((INITIAL initial-expression) . arguments) next . rest) (%ACCUMULATING variables arguments () (initial-expression +) (SUMMING variables ((INITIAL initial-expression) . arguments) "Malformed SUMMING clause in LOOP:") next . rest)) ((SUMMING variables arguments next . rest) (%ACCUMULATING variables arguments () (0 +) (SUMMING variables arguments "Malformed SUMMING clause in LOOP:") next . rest)))) (define-syntax multiplying (syntax-rules (INITIAL) ((MULTIPLYING variables ((INITIAL initial-expression) . arguments) next . rest) (%ACCUMULATING variables arguments () (initial-expression *) (MULTIPLYING variables ((INITIAL initial-expression) . arguments) "Malformed MULTIPLYING clause in LOOP:") next . rest)) ((MULTIPLYING variables arguments next . rest) (%ACCUMULATING variables arguments () (1 *) (MULTIPLYING variables arguments "Malformed MULTIPLYING clause in LOOP:") next . rest)))) (define-syntax maximizing (syntax-rules () ((MAXIMIZING variables arguments next . rest) (%EXTREMIZING variables arguments MAX (MAXIMIZING variables arguments "Malformed MAXIMIZING clause in LOOP:") next . rest)))) (define-syntax minimizing (syntax-rules () ((MINIMIZING variables arguments next . rest) (%EXTREMIZING variables arguments MIN (MINIMIZING variables arguments "Malformed MINIMIZING clause in LOOP:") next . rest)))) (define-syntax %extremizing (syntax-rules (INITIAL) ((%EXTREMIZING variables ((INITIAL initial-expression) . arguments) chooser error-context next . rest) (%ACCUMULATING variables arguments (((INITIAL-VALUE) initial-expression)) (INITIAL-VALUE chooser) error-context next . rest)) ((%EXTREMIZING variables arguments chooser error-context next . rest) (%ACCUMULATING variables arguments () (#F (LAMBDA (DATUM EXTREME) (IF (AND DATUM EXTREME) (chooser DATUM EXTREME) (OR DATUM EXTREME)))) error-context next . rest)))) (define-syntax %accumulating (syntax-rules () ;; There is a finalization step, so the result variable cannot be ;; the accumulator variable, and we must apply the finalizer at the ;; end. ((%ACCUMULATING (result-variable) arguments outer-bindings (initializer combiner finalizer) error-context next . rest) (%%ACCUMULATING arguments (ACCUMULATOR initializer combiner) outer-bindings (((result-variable) (finalizer ACCUMULATOR))) error-context next . rest)) ;; There is no finalizer step, so the accumulation is incremental, ;; and can be exploited; therefore, the result variable and the ;; accumulator variable are one and the same. ((%ACCUMULATING (accumulator-variable) arguments outer-bindings (initializer combiner) error-context next . rest) (%%ACCUMULATING arguments (accumulator-variable initializer combiner) outer-bindings () error-context next . rest)) ;; The user supplied more than one variable. Lose lose. ((%ACCUMULATING variables arguments outer-bindings parameters error-context next . rest) (LOOP-CLAUSE-ERROR error-context)))) (define-syntax %%%accumulating (syntax-rules () ((%%%ACCUMULATING outer-bindings loop-variable final-bindings next . rest) (next outer-bindings (loop-variable) () ;Entry bindings () ;Termination conditions () ;Body bindings final-bindings . rest)))) (define-syntax %%accumulating (syntax-rules (IF =>) ((%%ACCUMULATING (generator) ;No conditional (accumulator initializer combiner) outer-bindings final-bindings error-context next . rest) (%%%ACCUMULATING outer-bindings (accumulator initializer ;Loop variable (combiner generator accumulator)) final-bindings next . rest)) ((%%ACCUMULATING (generator (IF condition)) (accumulator initializer combiner) outer-bindings final-bindings error-context next . rest) (%%%ACCUMULATING outer-bindings (accumulator initializer ;Loop variable (IF condition (combiner generator accumulator) accumulator)) final-bindings next . rest)) ((%%ACCUMULATING (generator => mapper) (accumulator initializer combiner) outer-bindings final-bindings error-context next . rest) (%%%ACCUMULATING outer-bindings (accumulator initializer ;Loop variable (COND (generator => (LAMBDA (DATUM) (combiner (mapper DATUM) accumulator))) (ELSE accumulator))) final-bindings next . rest)) ((%%ACCUMULATING (generator tester => mapper) (accumulator initializer combiner) outer-bindings final-bindings error-context next . rest) (%%%ACCUMULATING outer-bindings (accumulator initializer ;Loop variable (RECEIVE ARGS generator (IF (APPLY tester ARGS) (combiner (APPLY mapper ARGS) accumulator) accumulator))) final-bindings next . rest)) ((%%ACCUMULATING arguments parameters outer-bindings final-bindings error-context next . rest) (LOOP-CLAUSE-ERROR error-context)))) ;;;; List Iteration ;;; (FOR [] (IN-LIST [])) ;;; Step across , letting be each successive pair in ;;; , stepping by ( ), or (CDR ) if no ;;; successor procedure is explicitly provided. Let be the car ;;; of in the body of the loop. (define-syntax in-list (syntax-rules () ((IN-LIST (element-variable pair-variable) (list-expression successor-expression) next . rest) (next (((LIST) list-expression) ;Outer bindings ((SUCCESSOR) successor-expression)) ((pair-variable LIST TAIL)) ;Loop variables () ;Entry bindings ((NOT (PAIR? pair-variable))) ;Termination conditions (((element-variable) (CAR pair-variable)) ;Body bindings ((TAIL) (SUCCESSOR pair-variable))) () ;Final bindings . rest)) ((IN-LIST (element-variable pair-variable) (list-expression) next . rest) (IN-LIST (element-variable pair-variable) (list-expression CDR) next . rest)) ((IN-LIST (element-variable) (list-expression successor) next . rest) (IN-LIST (element-variable PAIR) (list-expression successor) next . rest)) ((IN-LIST (element-variable) (list-expression) next . rest) (IN-LIST (element-variable PAIR) (list-expression CDR) next . rest)) ((IN-LIST variables arguments next . rest) (LOOP-CLAUSE-ERROR (IN-LIST variables arguments "Malformed IN-LIST clause in LOOP:"))))) (define-syntax in-lists (syntax-rules () ((IN-LISTS (elements-variable pairs-variable) (lists-expression) next . rest) (next (((LISTS) lists-expression)) ;Outer bindings ((pairs-variable LISTS CDRS)) ;Loop variables (((LOSE? CARS CDRS) ;Entry bindings (%CARS&CDRS pairs-variable))) (LOSE?) ;Termination conditions (((elements-variable) CARS)) ;Body bindings () ;Final bindings . rest)) ((IN-LISTS (elements-variable) (lists) next . rest) (IN-LISTS (elements-variable PAIRS) (lists) next . rest)) ((IN-LISTS variables arguments next . rest) (LOOP-CLAUSE-ERROR (IN-LISTS variables arguments "Malformed IN-LISTS clause in LOOP:"))))) (define (%cars&cdrs lists) (loop proceed ((for list (in-list lists)) (for cars (listing (car list))) (for cdrs (listing (cdr list)))) => (values #f cars cdrs) (if (pair? list) (proceed) (values #t #f #f)))) ;;;; Vector and String Iteration ;;; (FOR [] (IN-VECTOR [ []])) ;;; ;;; IN-VECTOR-REVERSE, IN-STRING, and IN-STRING-REVERSE all have the ;;; same syntax. ;;; ;;; The reverse iterators run from end to start; the bounds are still ;;; given in the same order as the forward iterators. (define-syntax in-vector (syntax-rules () ((IN-VECTOR variables (vector-expression start/end ...) next . rest) (%IN-VECTOR (FORWARD VECTOR-REF VECTOR 0 (VECTOR-LENGTH VECTOR)) variables (vector-expression start/end ...) (IN-VECTOR variables (vector-expression start/end ...) "Malformed IN-VECTOR clause in LOOP:") next . rest)))) (define-syntax in-vector-reverse (syntax-rules () ((IN-VECTOR-REVERSE variables (vector-expression start/end ...) next . rest) (%IN-VECTOR (BACKWARD VECTOR-REF VECTOR (VECTOR-LENGTH VECTOR) 0) variables (vector-expression start/end ...) (IN-VECTOR-REVERSE variables (vector-expression start/end ...) "Malformed IN-VECTOR-REVERSE clause in LOOP:") next . rest)))) (define-syntax in-string (syntax-rules () ((IN-STRING variables (vector-expression start/end ...) next . rest) (%IN-VECTOR (FORWARD STRING-REF STRING 0 (STRING-LENGTH STRING)) variables (vector-expression start/end ...) (IN-STRING variables (vector-expression start/end ...) "Malformed IN-STRING clause in LOOP:") next . rest)))) (define-syntax in-string-reverse (syntax-rules () ((IN-STRING-REVERSE variables (string-expression start/end ...) next . rest) (%IN-VECTOR (BACKWARD STRING-REF STRING (STRING-LENGTH STRING) 0) variables (string-expression start/end ...) (IN-STRING-REVERSE variables (string-expression start/end ...) "Malformed IN-STRING-REVERSE clause in LOOP:") next . rest)))) ;;;;; Random-Access Sequence Generalization (define-syntax %in-vector (syntax-rules (FORWARD BACKWARD) ((%IN-VECTOR (FORWARD vector-ref vector-variable default-start default-end) (element-variable index-variable) (vector-expression start-expression end-expression) error-context next . rest) (next (((vector-variable START END);Outer bindings (LET ((vector-variable vector-expression)) (VALUES vector-variable start-expression end-expression)))) ((index-variable START ;Loop variables (+ index-variable 1))) () ;Entry bindings ((>= index-variable END)) ;Termination conditions (((element-variable) ;Body bindings (vector-ref vector-variable index-variable))) () ;Final bindings . rest)) ((%IN-VECTOR (BACKWARD vector-ref vector-variable default-start default-end) (element-variable index-variable) (vector-expression start-expression end-expression) error-context next . rest) (next (((vector-variable START END);Outer bindings (LET ((vector-variable vector-expression)) (VALUES vector-variable start-expression end-expression)))) ((index-variable START ;Loop variables index-variable)) () ;Entry bindings ((<= index-variable END)) ;Termination conditions (((index-variable) ;Body bindings (- index-variable 1)) ((element-variable) (vector-ref vector-variable (- index-variable 1)))) () ;Final bindings . rest)) ;; Supply an index variable if absent. ((%IN-VECTOR iteration-parameters (element-variable) arguments error-context next . rest) (%IN-VECTOR iteration-parameters (element-variable INDEX) arguments error-context next . rest)) ;; Supply the default start index if necessary. ((%IN-VECTOR (direction vector-ref variable default-start default-end) variables (vector-expression) error-context next . rest) (%IN-VECTOR (direction vector-ref variable default-start default-end) variables (vector-expression default-start) error-context next . rest)) ;; Supply the default end index if necessary. ((%IN-VECTOR (direction vector-ref variable default-start default-end) variables (vector-expression start-expression) error-context next . rest) (%IN-VECTOR (direction vector-ref variable default-start default-end) variables (vector-expression start-expression default-end) error-context next . rest)) ((%IN-VECTOR iteration-parameters modified-variables modified-arguments error-context next . rest) (LOOP-CLAUSE-ERROR error-context)))) ;;;; Input ;;; (FOR (IN-PORT [ []])) ;;; ;;; IN-FILE has the same syntax, but with a pathname in the place of ;;; the input port. (define-syntax in-port (syntax-rules () ((IN-PORT (datum-variable) (port-expression reader-expression eof-predicate) next . rest) (next (((PORT) port-expression) ;Outer bindings ((READER) reader-expression) ((EOF?) eof-predicate)) () ;Loop variables (((datum-variable) (READER PORT))) ;Entry bindings ((EOF? datum-variable)) ;Termination conditions () ;Body bindings () ;Final bindings . rest)) ;; Supply a reader if absent. ((IN-PORT (datum-variable) (port-expression) next . rest) (IN-PORT (datum-variable) (port-expression READ-CHAR) next . rest)) ;; Supply an EOF predicate if absent. ((IN-PORT (datum-variable) (port-expression reader-expression) next . rest) (IN-PORT (datum-variable) (port-expression reader-expression EOF-OBJECT?) next . rest)) ((IN-PORT variables arguments next . rest) (LOOP-CLAUSE-ERROR (IN-PORT variables arguments "Malformed IN-PORT clause in LOOP:"))))) (define-syntax in-file (syntax-rules () ((IN-FILE (datum-variable) (pathname-expression reader-expression eof-predicate) next . rest) (next (((PORT) ;Outer bindings (OPEN-INPUT-FILE pathname-expression)) ((READER) reader-expression) ((EOF?) eof-predicate)) () ;Loop variables (((datum-variable) (READER PORT))) ;Entry bindings ((EOF? datum-variable)) ;Termination conditions () ;Body bindings ((() ;Final bindings (BEGIN (CLOSE-INPUT-PORT PORT) (VALUES)))) . rest)) ;; Supply a reader if absent. ((IN-FILE (datum-variable) (pathname-expression) next . rest) (IN-FILE (datum-variable) (pathname-expression READ-CHAR) next . rest)) ;; Supply an EOF predicate if absent. ((IN-FILE (datum-variable) (pathname-expression reader) next . rest) (IN-FILE (datum-variable) (pathname-expression reader EOF-OBJECT?) next . rest)) ((IN-FILE variables arguments next . rest) (LOOP-CLAUSE-ERROR (IN-FILE variables arguments "Malformed IN-FILE clause in LOOP:"))))) ;;;; Iterating Up through Numbers (define-syntax up-from (syntax-rules (TO BY) ((UP-FROM (variable) (start-expression (TO end-expression) (BY step-expression)) next . rest) (next (((START) start-expression) ;Outer bindings ((END) end-expression) ((STEP) step-expression)) ((variable START ;Loop variables (+ variable STEP))) () ;Entry bindings ((>= variable END)) ;Termination conditions () ;Body bindings () ;Final bindings . rest)) ((UP-FROM (variable) (start-expression (BY step-expression)) next . rest) (next (((START) start-expression) ;Outer bindings ((STEP) step-expression)) ((variable START ;Loop variables (+ variable STEP))) () ;Entry bindings () ;Termination conditions () ;Body bindings () ;Final bindings . rest)) ;; Add a default step of 1. ((UP-FROM (variable) (start-expression (TO end-expression)) next . rest) (UP-FROM (variable) (start-expression (TO end-expression) (BY 1)) next . rest)) ((UP-FROM (variable) (start-expression) next . rest) (UP-FROM (variable) (start-expression (BY 1)) next . rest)) ((UP-FROM variables arguments next . rest) (LOOP-CLAUSE-ERROR (UP-FROM variables arguments "Malformed UP-FROM clause in LOOP:"))))) ;;;; Iterating Down through Numbers (define-syntax down-from (syntax-rules (TO BY) ((DOWN-FROM (variable) (start-expression (TO end-expression) (BY step-expression)) next . rest) (next (((START) start-expression) ;Outer bindings ((END) end-expression) ((STEP) step-expression)) ((variable START variable)) ;Loop variables () ;Entry bindings ((<= variable END)) ;Termination conditions (((variable) ;Body bindings (- variable STEP))) () ;Final bindings . rest)) ((DOWN-FROM (variable) (start-expression (BY step-expression)) next . rest) (next (((START) start-expression) ;Outer bindings ((STEP) step-expression)) ((variable START variable)) ;Loop variables () ;Entry bindings () ;Termination conditions (((variable) ;Body bindings (- variable STEP))) () ;Final bindings . rest)) ;; Add a default step of 1. ((DOWN-FROM (variable) (start-expression (TO end-expression)) next . rest) (DOWN-FROM (variable) (start-expression (TO end-expression) (BY 1)) next . rest)) ((DOWN-FROM (variable) (start-expression) next . rest) (DOWN-FROM (variable) (start-expression (BY 1)) next . rest)) ((DOWN-FROM variables arguments next . rest) (LOOP-CLAUSE-ERROR (DOWN-FROM variables arguments "Malformed DOWN-FROM clause in LOOP:")))))