Index: foof-loop.setup =================================================================== --- foof-loop.setup (revision 16994) +++ foof-loop.setup (working copy) @@ -1,5 +1,6 @@ -(install-extension 'foof-loop - '("foof-loop.scm") - '((version 8.0) ;Major is foof-loop; minor is Chicken. - (documentation "foof-loop.html") - (syntax))) +(install-extension + 'foof-loop + '("foof-loop.scm") + '((version 8.0) ;Major is foof-loop; minor is Chicken. + (documentation "foof-loop.html") + (syntax))) Index: foof-loop.scm =================================================================== --- foof-loop.scm (revision 16994) +++ foof-loop.scm (working copy) @@ -47,209 +47,216 @@ ;;; of the macro which introduced the pattern variable. ;;; An asterisk marks a syntactic continuation's environment. -(define-syntax with-extended-parameter-operators - (syntax-rules () - ((with-extended-parameter-operators - ((?labelled-argument-macro-name - (?positional-form-name (?parameter . ?default) - ...)) - ...) +(module + foof-loop + (loop lazy-loop listing listing-reverse listing! listing-into! +appending appending-reverse summing multiplying maximizing minimizing +in-list in-lists in-vector in-vector-reverse in-string +in-string-reverse in-port in-file up-from down-from %cars&cdrs) + (import scheme) + (define-syntax with-extended-parameter-operators + (syntax-rules () + ((with-extended-parameter-operators + ((?labelled-argument-macro-name + (?positional-form-name (?parameter . ?default) + ...)) + ...) ?body0 ?body1 ...) - (letrec-syntax - ((?labelled-argument-macro-name - (syntax-rules () - ((?labelled-argument-macro-name . ??arguments) - (letrec-syntax - ((apply-positional - (syntax-rules () - ((apply-positional ???positionals) - (reverse-apply ?positional-form-name ???positionals)))) - - ;; Process all of the leading positional arguments. - ;; Once we reach a named argument, pass control on - ;; to PROCESS-NAMED. - ;; - ;; ???PARAMETERS is the list of remaining parameter - ;; specifiers (i.e. (parameter . default)) to - ;; process, in order. - ;; - ;; ???POSITIONALS is the current reversed list of - ;; positional argument expressions accumulated. - ;; - ;; ???ARGUMENTS is the list of remaining argument - ;; expressions in the input. - (process-positionals - (syntax-rules (=>) + (letrec-syntax + ((?labelled-argument-macro-name + (syntax-rules () + ((?labelled-argument-macro-name . ??arguments) + (letrec-syntax + ((apply-positional + (syntax-rules () + ((apply-positional ???positionals) + (reverse-apply ?positional-form-name ???positionals)))) + + ;; Process all of the leading positional arguments. + ;; Once we reach a named argument, pass control on + ;; to PROCESS-NAMED. + ;; + ;; ???PARAMETERS is the list of remaining parameter + ;; specifiers (i.e. (parameter . default)) to + ;; process, in order. + ;; + ;; ???POSITIONALS is the current reversed list of + ;; positional argument expressions accumulated. + ;; + ;; ???ARGUMENTS is the list of remaining argument + ;; expressions in the input. + (process-positionals + (syntax-rules (=>) - ;; No more parameters -- ignore the remaining - ;; arguments (signal a syntax error?), and just - ;; do positional application. There were no - ;; named arguments. - ((process-positionals () ???positionals . ???arguments) - (apply-positional ???positionals)) + ;; No more parameters -- ignore the remaining + ;; arguments (signal a syntax error?), and just + ;; do positional application. There were no + ;; named arguments. + ((process-positionals () ???positionals . ???arguments) + (apply-positional ???positionals)) - ;; No more positional arguments; fill in default - ;; values for the remaining parameters. - ((process-positionals ???parameters ???positionals) - (process-defaults ???parameters ???positionals)) + ;; No more positional arguments; fill in default + ;; values for the remaining parameters. + ((process-positionals ???parameters ???positionals) + (process-defaults ???parameters ???positionals)) - ;; Named argument -- move on to - ;; PROCESS-NAMED. - ((process-positionals ???parameters - ???positionals - (=> ???parameter ???argument) - . ???arguments) - (process-named ???parameters - ???positionals - (=> ???parameter ???argument) - . ???arguments)) + ;; Named argument -- move on to + ;; PROCESS-NAMED. + ((process-positionals ???parameters + ???positionals + (=> ???parameter ???argument) + . ???arguments) + (process-named ???parameters + ???positionals + (=> ???parameter ???argument) + . ???arguments)) - ;; Positional argument -- accumulate and - ;; proceed. - ((process-positionals (???parameter . ???parameters) - ???positionals - ???positional - . ???arguments) - (process-positionals ???parameters - (???positional . ???positionals) - . ???arguments)))) + ;; Positional argument -- accumulate and + ;; proceed. + ((process-positionals (???parameter . ???parameters) + ???positionals + ???positional + . ???arguments) + (process-positionals ???parameters + (???positional . ???positionals) + . ???arguments)))) - ;; If we ran out of positional arguments, for each - ;; remaining parameter specifier, fill in its - ;; default expression. - (process-defaults - (syntax-rules () + ;; If we ran out of positional arguments, for each + ;; remaining parameter specifier, fill in its + ;; default expression. + (process-defaults + (syntax-rules () - ((process-defaults () ???positionals) - (apply-positional ???positionals)) + ((process-defaults () ???positionals) + (apply-positional ???positionals)) - ((process-defaults ((???parameter . ???default) - . ???parameters/defaults) - ???positionals) - (process-defaults ???parameters/defaults - (???default . ???positionals))))) - - ;; Find the named argument corresponding with each - ;; parameter specifier, in order. - ;; - ;; ???PARAMETERS is the list of remaining parameter - ;; specifiers to process, in order. - ;; - ;; ???POSITIONALS is the currently accumulated list - ;; of positional argument expressions, in reverse - ;; order. - ;; - ;; ???ARGUMENTS is the list of remaining arguments - ;; to process. No more positional arguments are - ;; allowed at this point in the game, and we never - ;; take anything off of this list. - (process-named - (syntax-rules () + ((process-defaults ((???parameter . ???default) + . ???parameters/defaults) + ???positionals) + (process-defaults ???parameters/defaults + (???default . ???positionals))))) + + ;; Find the named argument corresponding with each + ;; parameter specifier, in order. + ;; + ;; ???PARAMETERS is the list of remaining parameter + ;; specifiers to process, in order. + ;; + ;; ???POSITIONALS is the currently accumulated list + ;; of positional argument expressions, in reverse + ;; order. + ;; + ;; ???ARGUMENTS is the list of remaining arguments + ;; to process. No more positional arguments are + ;; allowed at this point in the game, and we never + ;; take anything off of this list. + (process-named + (syntax-rules () - ;; No more pararmeters -- apply. - ((process-named () ???positionals . ???arguments) - (apply-positional ???positionals)) + ;; No more pararmeters -- apply. + ((process-named () ???positionals . ???arguments) + (apply-positional ???positionals)) - ;; No more arguments -- fill in defaults. - ((process-named ???parameters ???postionals) - (process-defaults ???parameters ???positionals)) + ;; No more arguments -- fill in defaults. + ((process-named ???parameters ???postionals) + (process-defaults ???parameters ???positionals)) - ;; Match up this parameter with its argument - ;; expression; then go on with the remaining - ;; parameters, and all of the arguments. - ((process-named ((???parameter . ???default) - . ???parameters) - ???positionals - . ???arguments) - (match-parameter-by-name - ???arguments - ???parameter - ???default - (process-named-continuation ???positionals - ???parameters - . ???arguments))))) + ;; Match up this parameter with its argument + ;; expression; then go on with the remaining + ;; parameters, and all of the arguments. + ((process-named ((???parameter . ???default) + . ???parameters) + ???positionals + . ???arguments) + (match-parameter-by-name + ???arguments + ???parameter + ???default + (process-named-continuation ???positionals + ???parameters + . ???arguments))))) - ;; Continuation for the named parameter matcher. - ;; When we get a value, add it to the saved list of - ;; positionals, and proceed with the saved list of - ;; remaining parameter specifiers, and the saved - ;; list of argument expressions. - (process-named-continuation - (syntax-rules () - ((process-named-continuation ???value - ???positionals* - ???parameters* - . ???arguments*) - (process-named ???parameters* - (???value . ???positionals*) - . ???arguments*)))) - - ;; Find the named argument corresponding with a - ;; parameter specifier. If none exists, use the - ;; default given. - (match-parameter-by-name - (syntax-rules (=> ?parameter ...) + ;; Continuation for the named parameter matcher. + ;; When we get a value, add it to the saved list of + ;; positionals, and proceed with the saved list of + ;; remaining parameter specifiers, and the saved + ;; list of argument expressions. + (process-named-continuation + (syntax-rules () + ((process-named-continuation ???value + ???positionals* + ???parameters* + . ???arguments*) + (process-named ???parameters* + (???value . ???positionals*) + . ???arguments*)))) + + ;; Find the named argument corresponding with a + ;; parameter specifier. If none exists, use the + ;; default given. + (match-parameter-by-name + (syntax-rules (=> ?parameter ...) - ;; For each of the possible named parameters, if - ;; it matches this one, use it -- add the - ;; corresponding argument expression to the list - ;; of positionals. - ((match-parameter-by-name - ((=> ?parameter ???value) . ???arguments) - ?parameter - ???default - (???continuation . ???environment)) - (???continuation ???value . ???environment)) - ... ;*** + ;; For each of the possible named parameters, if + ;; it matches this one, use it -- add the + ;; corresponding argument expression to the list + ;; of positionals. + ((match-parameter-by-name + ((=> ?parameter ???value) . ???arguments) + ?parameter + ???default + (???continuation . ???environment)) + (???continuation ???value . ???environment)) + ... ;*** - ;; Argument does not match -- skip it. - ((match-parameter-by-name (???argument . ???arguments) - ???parameter - ???default - ???continuation) - (match-parameter-by-name ???arguments - ???parameter - ???default - ???continuation)) + ;; Argument does not match -- skip it. + ((match-parameter-by-name (???argument . ???arguments) + ???parameter + ???default + ???continuation) + (match-parameter-by-name ???arguments + ???parameter + ???default + ???continuation)) - ;; No more arguments -- use the default. - ((match-parameter-by-name - () - ???parameter - ???default - (???continuation . ???environment)) - (???continuation ???default . ???environment)))) + ;; No more arguments -- use the default. + ((match-parameter-by-name + () + ???parameter + ???default + (???continuation . ???environment)) + (???continuation ???default . ???environment)))) - ;; Apply ???OPERATOR to the reversal of the arguments. - (reverse-apply - (syntax-rules () + ;; Apply ???OPERATOR to the reversal of the arguments. + (reverse-apply + (syntax-rules () - ((reverse-apply ???operator ???reversed-arguments) - (reverse-apply ???operator ???reversed-arguments ())) + ((reverse-apply ???operator ???reversed-arguments) + (reverse-apply ???operator ???reversed-arguments ())) - ((reverse-apply ???operator - (???argument . ???more) - ???arguments) - (reverse-apply ???operator - ???more - (???argument . ???arguments))) + ((reverse-apply ???operator + (???argument . ???more) + ???arguments) + (reverse-apply ???operator + ???more + (???argument . ???arguments))) - ((reverse-apply ???operator () ???arguments) - (???operator . ???arguments))))) + ((reverse-apply ???operator () ???arguments) + (???operator . ???arguments))))) - ;; Start the whole process. - (process-positionals ((?parameter . ?default) ...) - () - . ??arguments))))) - ...) + ;; Start the whole process. + (process-positionals ((?parameter . ?default) ...) + () + . ??arguments))))) + ...) - ?body0 - ?body1 - ...)))) - + ?body0 + ?body1 + ...)))) + ;;; -*- Mode: Scheme -*- ;;;; Multiple-Value Binding Macros @@ -257,149 +264,149 @@ ;;; This code is written by Taylor R. Campbell and placed in the Public ;;; Domain. All warranties are disclaimed. -(define (receive-values consumer producer) - (call-with-values producer consumer)) + (define (receive-values consumer producer) + (call-with-values producer consumer)) -(define-syntax receive - (syntax-rules () - ((receive (variable) producer body0 body1+ ...) - (let ((variable producer)) body0 body1+ ...)) + (define-syntax receive + (syntax-rules () + ((receive (variable) producer body0 body1+ ...) + (let ((variable producer)) body0 body1+ ...)) - ((receive bvl producer body0 body1+ ...) - (call-with-values (lambda () producer) - (lambda bvl body0 body1+ ...))))) + ((receive bvl producer body0 body1+ ...) + (call-with-values (lambda () producer) + (lambda bvl body0 body1+ ...))))) -(define-syntax let*-values - (syntax-rules () - ((let*-values () body0 body1+ ...) - (let () body0 body1+ ...)) + (define-syntax let*-values + (syntax-rules () + ((let*-values () body0 body1+ ...) + (let () body0 body1+ ...)) - ((let*-values ((bvl producer)) body0 body1+ ...) - (receive bvl producer body0 body1+ ...)) + ((let*-values ((bvl producer)) body0 body1+ ...) + (receive bvl producer body0 body1+ ...)) - ((let*-values ((bvl0 producer0) - (bvl1+ producer1+) + ((let*-values ((bvl0 producer0) + (bvl1+ producer1+) + ...) + body0 + body1+ ...) - body0 - body1+ - ...) - (receive bvl0 producer0 - (let*-values ((bvl1+ producer1+) ...) - body0 - body1+ - ...))))) - -(define-syntax let-values - (syntax-rules () - ((let-values () body0 body1+ ...) - (let () body0 body1+ ...)) + (receive bvl0 producer0 + (let*-values ((bvl1+ producer1+) ...) + body0 + body1+ + ...))))) + + (define-syntax let-values + (syntax-rules () + ((let-values () body0 body1+ ...) + (let () body0 body1+ ...)) - ((let-values ((bvl producer)) body0 body1+ ...) - (receive bvl producer body0 body1+ ...)) + ((let-values ((bvl producer)) body0 body1+ ...) + (receive bvl producer body0 body1+ ...)) - ((let-values ((bvl producer) ...) body0 body1+ ...) - (let-values/process-clauses ((bvl producer) ...) - (let-values/make-output body0 body1+ ...))))) + ((let-values ((bvl producer) ...) body0 body1+ ...) + (let-values/process-clauses ((bvl producer) ...) + (let-values/make-output body0 body1+ ...))))) -(define-syntax let-values/process-clauses - (syntax-rules () - ((let-values/process-clauses clauses continuation) - (let-values/process-clauses () () clauses continuation)) + (define-syntax let-values/process-clauses + (syntax-rules () + ((let-values/process-clauses clauses continuation) + (let-values/process-clauses () () clauses continuation)) - ((let-values/process-clauses let-bindings - bvls&producers - () - (continuation . environment)) - (continuation let-bindings bvls&producers . environment)) + ((let-values/process-clauses let-bindings + bvls&producers + () + (continuation . environment)) + (continuation let-bindings bvls&producers . environment)) - ((let-values/process-clauses let-bindings - bvls&producers - (((variable) producer) . clauses) - continuation) - (let-values/process-clauses ((variable producer) . let-bindings) - bvls&producers - clauses - continuation)) + ((let-values/process-clauses let-bindings + bvls&producers + (((variable) producer) . clauses) + continuation) + (let-values/process-clauses ((variable producer) . let-bindings) + bvls&producers + clauses + continuation)) - ((let-values/process-clauses let-bindings - bvls&producers - ((bvl producer) . clauses) - continuation) - (let-values/generate-temporaries - bvl - (let-values/continuation producer + ((let-values/process-clauses let-bindings + bvls&producers + ((bvl producer) . clauses) + continuation) + (let-values/generate-temporaries + bvl + (let-values/continuation producer + let-bindings + bvls&producers + clauses + continuation))))) + + (define-syntax let-values/continuation + (syntax-rules () + ((let-values/continuation bvl + (let-binding ...) + producer let-bindings bvls&producers clauses - continuation))))) + continuation) + (let-values/process-clauses (let-binding ... . let-bindings) + ((bvl producer) . bvls&producers) + clauses + continuation)))) + + (define-syntax let-values/generate-temporaries + (syntax-rules () + ((let-values/generate-temporaries bvl continuation) + (let-values/generate-temporaries () () bvl continuation)) -(define-syntax let-values/continuation - (syntax-rules () - ((let-values/continuation bvl - (let-binding ...) - producer - let-bindings - bvls&producers - clauses - continuation) - (let-values/process-clauses (let-binding ... . let-bindings) - ((bvl producer) . bvls&producers) - clauses - continuation)))) - -(define-syntax let-values/generate-temporaries - (syntax-rules () - ((let-values/generate-temporaries bvl continuation) - (let-values/generate-temporaries () () bvl continuation)) + ((let-values/generate-temporaries (bvl-out ...) + let-bindings + (variable . bvl-in) + continuation) + (let-values/generate-temporaries (bvl-out ... temporary) + ((variable temporary) . let-bindings) + bvl-in + continuation)) - ((let-values/generate-temporaries (bvl-out ...) - let-bindings - (variable . bvl-in) - continuation) - (let-values/generate-temporaries (bvl-out ... temporary) - ((variable temporary) . let-bindings) - bvl-in - continuation)) + ((let-values/generate-temporaries bvl + let-bindings + () + (continuation . environment)) + (continuation bvl let-bindings . environment)) - ((let-values/generate-temporaries bvl - let-bindings - () - (continuation . environment)) - (continuation bvl let-bindings . environment)) + ((let-values/generate-temporaries (bvl ...) + let-bindings + rest-variable + (continuation . environment)) + (continuation (bvl ... . temporary) + ((rest-variable temporary) . let-bindings) + . environment)))) - ((let-values/generate-temporaries (bvl ...) - let-bindings - rest-variable - (continuation . environment)) - (continuation (bvl ... . temporary) - ((rest-variable temporary) . let-bindings) - . environment)))) + (define-syntax let-values/make-output + (syntax-rules () + ((let-values/make-output let-bindings () . body) + (let let-bindings . body)) -(define-syntax let-values/make-output - (syntax-rules () - ((let-values/make-output let-bindings () . body) - (let let-bindings . body)) - - ((let-values/make-output let-bindings - ((bvl producer) . bvls&producers) - . body) - (receive bvl producer - (let-values/make-output let-bindings bvls&producers . body))))) - + ((let-values/make-output let-bindings + ((bvl producer) . bvls&producers) + . body) + (receive bvl producer + (let-values/make-output let-bindings bvls&producers . body))))) + ;;; [Here starts the actual foof-loop.scm.] -(define-syntax loop - (syntax-rules () - ((loop ((loop-clause0 loop-clause1 ...) ...) - body - ...) - (loop anonymous-loop ((loop-clause0 loop-clause1 ...) ...) - body - ... - (anonymous-loop))) + (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 ...))))) + ((loop name ((loop-clause0 loop-clause1 ...) ...) body ...) + (%loop start name ((loop-clause0 loop-clause1 ...) ...) (body ...))))) ;;; We must be very careful about where to add laziness annotations. ;;; In particular, we don't want to wrap only the loop's body, because @@ -408,16 +415,16 @@ ;;; whole thing in a LAZY, and then wrap every call to the loop as ;;; well. -(define-syntax lazy-loop - (syntax-rules (=>) - ((lazy-loop name (iterator ...) => result body0 body1 ...) - (lazy (loop eager-loop (iterator ...) - => result - (let-syntax ((name - (syntax-rules () - ((name . arguments) - (lazy (eager-loop . arguments)))))) - body0 body1 ...)))))) + (define-syntax lazy-loop + (syntax-rules (=>) + ((lazy-loop name (iterator ...) => result body0 body1 ...) + (lazy (loop eager-loop (iterator ...) + => result + (let-syntax ((name + (syntax-rules () + ((name . arguments) + (lazy (eager-loop . arguments)))))) + body0 body1 ...)))))) ;;; Use this definition of SYNTACTIC-ERROR if your favourite Scheme ;;; doesn't have one already. Note that this is distinct from a @@ -425,274 +432,274 @@ ;;; [Kludge for Chicken.] -(define-syntax syntactic-error - (syntax-rules (SYNTAX-ERROR) - ((syntactic-error SYNTAX-ERROR) - 'SYNTAX-ERROR))) + (define-syntax syntactic-error + (syntax-rules (SYNTAX-ERROR) + ((syntactic-error SYNTAX-ERROR) + 'SYNTAX-ERROR))) ;;; 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)))))) - + (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) + (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)) + ((%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)) + ;; 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 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 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 ((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 (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 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)) - + ((%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 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 + ((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 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 (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 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)) + ((%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. + ;; 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) . 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 ((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)) - + ((%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 () (=> result-form . body)) + (%loop finish name state result-form body)) - ((%loop go name state () body) - (%loop finish name state (if #f #f) 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 + ((%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 ...))) - + (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))) + ;; 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)))) + ;; 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))))) + ;; 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)))))))) - + ((%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: @@ -710,297 +717,297 @@ ;;; ;;; (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)) + (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)))) + ((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)) + (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)))) - + ((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! + (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-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)) + (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)))) - + ((%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)) + (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)))) + ((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)) + (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)))) + ((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) + ;; (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)) - + (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)) + (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)))) + ((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)) + (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:") + ((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 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 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)) -(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 () - ((%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))) + ;; 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)) + 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 - () + ;; 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)) + 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)))) + ;; 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)) + (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 (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 => 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 (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)))) - + ((%%ACCUMULATING arguments parameters outer-bindings final-bindings + error-context next . rest) + (loop-clause-error error-context)))) + ;;;; List Iteration ;;; (FOR [] (IN-LIST [])) @@ -1009,73 +1016,73 @@ ;;; 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)) + (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 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 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 (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:"))))) - + ((in-list variables arguments next . rest) + (loop-clause-error (in-list variables arguments + "Malformed IN-LIST clause in LOOP:"))))) + ;;;;; Parallel List Iteration -(define-syntax in-lists - (syntax-rules () - ((in-lists (elements-variable pairs-variable) - (lists-expression tail-expression) - next . rest) - (next (((lists) lists-expression)) ;Outer bindings - ((pairs-variable lists cdrs)) ;Loop variables - (((lose? cars cdrs) ;Entry bindings - (%cars&cdrs pairs-variable tail-expression '()))) - (lose?) ;Termination conditions - (((elements-variable) cars)) ;Body bindings - () ;Final bindings - . rest)) + (define-syntax in-lists + (syntax-rules () + ((in-lists (elements-variable pairs-variable) + (lists-expression tail-expression) + next . rest) + (next (((lists) lists-expression)) ;Outer bindings + ((pairs-variable lists cdrs)) ;Loop variables + (((lose? cars cdrs) ;Entry bindings + (%cars&cdrs pairs-variable tail-expression '()))) + (lose?) ;Termination conditions + (((elements-variable) cars)) ;Body bindings + () ;Final bindings + . rest)) - ((in-lists (elements-variable pairs-variable) (lists) next . rest) - (in-lists (elements-variable pairs-variable) (lists '()) next . rest)) + ((in-lists (elements-variable pairs-variable) (lists) next . rest) + (in-lists (elements-variable pairs-variable) (lists '()) next . rest)) - ((in-lists (elements-variable) (lists tail) next . rest) - (in-lists (elements-variable pairs) (lists tail) next . rest)) + ((in-lists (elements-variable) (lists tail) next . rest) + (in-lists (elements-variable pairs) (lists tail) next . rest)) - ((in-lists (elements-variable) (lists) next . rest) - (in-lists (elements-variable pairs) (lists '()) next . 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:"))))) + ((in-lists variables arguments next . rest) + (loop-clause-error (in-lists variables arguments + "Malformed IN-LISTS clause in LOOP:"))))) -(define (%cars&cdrs lists cars-tail cdrs-tail) - (loop proceed ((for list (in-list lists)) - (for cars (listing (initial cars-tail) (car list))) - (for cdrs (listing (initial cdrs-tail) (cdr list)))) - => (values #f cars cdrs) - (if (pair? list) - (proceed) - (values #t #f #f)))) - + (define (%cars&cdrs lists cars-tail cdrs-tail) + (loop proceed ((for list (in-list lists)) + (for cars (listing (initial cars-tail) (car list))) + (for cdrs (listing (initial cdrs-tail) (cdr list)))) + => (values #f cars cdrs) + (if (pair? list) + (proceed) + (values #t #f #f)))) + ;;;; Vector and String Iteration ;;; (FOR [] (IN-VECTOR [ []])) @@ -1086,111 +1093,111 @@ ;;; 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 + (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 + (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 ...) - "Malformed IN-VECTOR-REVERSE clause in LOOP:") - next . rest)))) + (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 + (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 + (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 ...) - "Malformed IN-STRING-REVERSE clause in LOOP:") - next . rest)))) - + (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)) + (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)) + ((%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 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 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)) + ;; 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)))) - + ((%in-vector iteration-parameters modified-variables modified-arguments + error-context next . rest) + (loop-clause-error error-context)))) + ;;;; Input ;;; (FOR (IN-PORT [ []])) @@ -1198,164 +1205,165 @@ ;;; 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)) + (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 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)) + ;; 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:"))))) + ((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)) + (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 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)) + ;; 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:"))))) - + ((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)) + (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)) + ((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)) + ;; 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 (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:"))))) - + ((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)) + (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)) + ((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)) + ;; 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 (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:"))))) + ((down-from variables arguments next . rest) + (loop-clause-error (down-from variables arguments + "Malformed DOWN-FROM clause in LOOP:"))))) + ) Index: tests/run.scm =================================================================== --- tests/run.scm (revision 0) +++ tests/run.scm (revision 0) @@ -0,0 +1,495 @@ +(use foof-loop + test + streams + (srfi 1 13)) + +(define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name + (receive x expect x) + (receive x expr x))))) + +(define-syntax debug + (syntax-rules () + ((_ x ...) + (print `((x ,x) ...))))) + +(let ((count-matching-items + (lambda (list predicate) + (loop ((for item (in-list list)) + (with count 0 + (if (predicate item) + (+ count 1) + count))) + => count)))) + (test "count-matching-items" + 3 + (count-matching-items '(1 2 3 a b c) number?))) + +(let ((find-matching-item + (lambda (list if-absent predicate) + (loop continue ((for item (in-list list))) + => (if-absent) + (if (predicate item) + item + (continue)))))) + (test "find-matching-item" + #f + (find-matching-item '(a b c) (lambda () #f) number?))) + +(let ((map + (lambda (procedure list) + (loop recur ((for element (in-list list))) + => '() + (cons (procedure element) (recur)))))) + + (test "map" + '(1 4 27 256 3125) + (map (lambda (n) (expt n n)) '(1 2 3 4 5)))) + +(let ((write-list-newline + (lambda (list) + (loop ((for element (in-list list))) + (write element) + (newline))))) + (test "write-list-newline" + "1\n2\n3\n" + (with-output-to-string (lambda () (write-list-newline '(1 2 3)))))) + +(let ((partition + (lambda (predicate list) + (loop continue ((for element (in-list list)) + (with satisfied '()) + (with unsatisfied '())) + => (values (reverse satisfied) + (reverse unsatisfied)) + (if (predicate element) + (continue (=> satisfied (cons element satisfied))) + (continue (=> unsatisfied (cons element unsatisfied)))))))) + +(test-values "partition" + (values '(one four five) '(2 3 6)) + (partition symbol? '(one 2 3 four five 6)))) + +(let ((reverse! + (lambda (list) + (loop ((for element pair (in-list list)) + (with tail '() pair)) + => tail + (set-cdr! pair tail))))) + (test "reverse!" + '((e (f)) d (b c) a) + (reverse! '(a (b c) d (e (f)))))) + +(let ((reverse-map! + (lambda (procedure list) + (loop ((for element pair (in-list list)) + (with tail '() pair)) + => tail + (set-car! pair (procedure element)) + (set-cdr! pair tail))))) + (test "reverse-map!" + '(3125 256 27 4 1) + (reverse-map! (lambda (n) (expt n n)) '(1 2 3 4 5)))) + +(let ((flatten-begins + (lambda (list) + (loop continue ((for element pair (in-list list)) + (with subforms '())) + => (reverse subforms) + (if (and (pair? element) + (eq? 'begin (car element))) + (continue (=> pair (append (cdr element) (cdr pair)))) + (continue (=> subforms (cons element subforms)))))))) + (test "flatten-begins" + '(begin (1 2 3) (a b c) (i ii iii)) + (flatten-begins '(begin (1 2 3) + (begin (a b c) + (begin (i ii iii))))))) + + +;;; locally defective srfi-27; not tested +#; +(let ((shuffle-vector! + (lambda (vector) + (loop ((for element i (in-vector vector))) + (let ((j (random-integer (+ i 1)))) + (vector-set! vector i (vector-ref vector j)) + (vector-set! vector j element))))) + (vector (vector 1 2 3))) + (test "shuffle-vector!" + #f + (shuffle-vector! vector))) + +(let ((list-tabulate + (lambda (length procedure) + (loop ((for index (up-from 0 (to length))) + (with list '() (cons (procedure index) list))) + => (reverse list))))) + (test "list-tabulate" + '(0 1 2 3) + (list-tabulate 4 values))) + +(let ((even-integers + (lambda (N) + (loop ((for integer (up-from 0 (to N) (by 2))) + (with evens '() (cons integer evens))) + => (reverse evens))))) + (test "even-integers to N" + '(0 2 4 6 8) + (even-integers 10))) + +(let ((unsafe-length + (lambda (list) + (loop ((for element (in-list list)) + (for length (up-from 0))) + => length)))) + (test "unsafe-length" + 3 + (unsafe-length '(1 2 3)))) + +(let ((map + (lambda (procedure list) + (loop ((for element (in-list list)) + (for result (listing (procedure element)))) + => result)))) + (test "map-with-listing" + '(1 4 27 256 3125) + (map (lambda (n) (expt n n)) '(1 2 3 4 5)))) + +(let ((filter + (lambda (predicate list) + (loop ((for element (in-list list)) + (for result + (listing element + (if (predicate element))))) + => result)))) + (test "filter" + '(0 8 8 -4) + (filter even? '(0 7 8 8 43 -4)))) + +(let ((filter-map + (lambda (procedure list) + (loop ((for element (in-list list)) + (for result + (listing (procedure list) => (lambda (x) x)))) + => result)))) + (test "filter-map" + '(1 9 49) + (filter-map (lambda (x) + (and (number? x) + (* x x))) + '(a 1 b 3 c 7)))) + +(test "listing-into!" + '(initial 0 4 16 36 64) + (let ((x (cons 'initial '()))) + (loop ((for i (up-from 0 (to 10))) + (for result (listing-into! x (* i i) (if (even? i)))))) + x)) + +(let ((read-non-empty-lines + (lambda (input-port) + (loop ((for line (in-port input-port read-line)) + (until (string-null? line)) + (for lines (listing line))) + => lines)))) + (test "read-non-empty-lines" + '("1" "2" "3") + (with-input-from-file "read.txt" + (lambda () (read-non-empty-lines (current-input-port)))))) + +(test "loop name" + "(0 () i (i j k p q r))\n(1 (0) k (k p q r))\n(2 (1 0) q (q r))\n" + (with-output-to-string + (lambda () + (loop continue ((with a 0) + (with b '() + (cons a b)) + (for c d (in-list '(i j k p q r)))) + (write (list a b c d)) + (newline) + (continue (+ a 1) + (=> d (cddr d))))))) + +(test "alternate `with' like named-let" + "0123456789" + (with-output-to-string + (lambda () + (loop next ((x 0)) + (if (< x 10) + (begin (write x) (next (+ x 1)))))))) + +(test "alternate `with' like `do'" + "0123456789" + (with-output-to-string + (lambda () + (loop ((x 0 (+ x 1)) + (until (>= x 10))) + (write x))))) + +;;; appears to require srfi-40 (not srfi-41, "streams") +#; +(let ((stream-filter + (lambda (predicate stream) + (lazy-loop filter ((for element (in-stream stream))) + => stream-nil + (if (predicate element) + (stream-cons element (filter)) + (filter)))))) + (stream-filter odd? (stream-from 0 2))) + +(test "pairs of lists" + "(a a)\n(b b)\n(c c)\n" + (with-output-to-string + (lambda () + (loop ((for a (in-list '(a b c))) + (for b (in-list '(p q r)))) + (write (list a b)) + (newline))))) + +(test "list plus iterator" + 12 + (loop ((for x (in-list '(1 2 3))) + (with y 0 (+ y (* x 2)))) + => y)) + +(let ((pair-fold + (lambda (kons knil list) + (loop ((for elt pair (in-list list)) + (with knil knil (kons pair knil))) + => knil)))) + (test "pair-fold" + '(3 2 1) + (pair-fold (lambda (pair tail) + (set-cdr! pair tail) + pair) + '() + (list 1 2 3)))) + +(test "transpose-matrix" + '((c f) (b e) (a d)) + (loop ((for columns (in-lists '((a b c) (d e f)))) + (with rows '() (cons columns rows))) + => rows)) + +(let ((every? + (lambda (predicate list . lists) + (loop proceed ((for elts (in-lists (cons list lists)))) + (and (apply predicate elts) + (proceed)))))) + (test "every?" + #f + (every? odd? '(1 2 3)))) + +(let ((any + (lambda (predicate list . lists) + (loop proceed ((for elts (in-lists (cons list lists)))) + (or (apply predicate elts) + (proceed)))))) + (test-assert "any-integer?" + (any integer? '(a 3 b 2.7))) + (test-assert "any-<" + (any < '(3 1 4 1 5) + '(2 7 1 8 2)))) + +(let ((fold + (lambda (kons knil list . lists) + (loop ((with knil knil (apply kons arguments)) + (for arguments + (in-lists (cons list lists) + (cons knil '())))) + => knil)))) + (test "fold" + 3 + (fold + 0 '(0 1 2)))) + +(test "pairs of vectors" + "(foo 0 #\\f 5)\n(bar 1 #\\e 4)\n(baz 2 #\\d 3)\n" + (with-output-to-string + (lambda () + (loop ((for a i (in-vector '#(foo bar baz))) + (for b j (in-string-reverse "abcdefghi" 6 3))) + => (list i j) + (write (list a i b j)) + (newline))))) + +(let ((vector-index + (lambda (vector predicate) + (loop proceed ((for elt index (in-vector vector))) + (if (predicate elt) + index + (proceed)))))) + (test "vector-index" + 2 + (vector-index '#(3 1 4 1 5 9) even?))) + +(let ((string-copy! + (lambda (target tstart source sstart send) + (loop ((for char (in-string source sstart send)) + (with index tstart (+ index 1))) + (string-set! target index char))))) + (test "string-copy!" + "eta subst" + (string-copy "Beta substitution" 1 10))) + +(test "sample squared-plus-ones from vector" + "(a 0)\n(b 1)\n(d 3)\n(h 7)\n(p 15)\n" + (with-output-to-string + (lambda () + (loop proceed + ((for v i + (in-vector + '#(a b c d e f g h i j k l m n o p q r s t u v w x y z)))) + (write (list v i)) + (newline) + (proceed (=> i (+ 1 (* i 2)))))))) + +(let ((read-line + (lambda (input-port) + (let ((initial (peek-char input-port))) + (if (eof-object? initial) + initial + (loop ((for char (in-port input-port)) + (until (char=? char #\newline)) + (with chars '() (cons char chars))) + => (list->string (reverse chars)))))))) + (test "read-line" + "1" + (with-input-from-file "read.txt" + (lambda () (read-line (current-input-port)))))) + +(let ((read-all + (lambda (input-port) + (loop ((for datum (in-port input-port read)) + (with data '() (cons datum data))) + => (reverse data))))) + (test "read-all" + '(1 2 3 4 5) + (with-input-from-file "read.txt" + (lambda () (read-all (current-input-port)))))) + +(let ((read-lines-from-file + (lambda (pathname) + (loop ((for line (in-file pathname read-line)) + (with lines '() (cons line lines))) + => (reverse lines))))) + (test "read-lines-from-file" + '("1" "2" "3" "" "4" "5") + (read-lines-from-file "read.txt"))) + +(let ((iota + (lambda (count start step) + (loop ((for n (up-from 0 (to count))) + (for result (listing (+ start (* n step))))) + => result)))) + (test "iota" + '(0 1 2 3 4) + (iota 5 0 1))) + +(let ((sieve + (lambda (n) + (let ((table (make-bit-string (- n 2) #t))) + (define (prime? k) (bit-string-ref table (- k 2))) + (define (not-prime! k) (bit-string-clear! table (- k 2))) + (define (purge-multiples i) + (loop ((for j (up-from (* i i) + (to n) + (by i)))) + (not-prime! j))) + (loop proceed ((for i (up-from 2 (to n))) + (with primes '())) + => (reverse primes) + (if (prime? i) + (begin (purge-multiples i) + (proceed (=> primes (cons i primes)))) + (proceed))))))) + (test "sieve" + #f + (sieve 5))) + +(let ((vector-quick-sort! + (lambda (elt< vector start end) + (loop sort ((start start) (end end)) + (if (< 1 (- end start)) + (let ((pivot (select-pivot vector start end))) + (loop continue ((i start) (j end)) + (let ((i (loop scan ((for i (up-from i))) + (if (elt< (vector-ref vector i) pivot) + (scan) + i))) + (j (loop scan ((for j (down-from j))) + (if (elt< pivot (vector-ref vector j)) + (scan) + j)))) + (if (< i j) + (begin (vector-exchange! vector i j) + (continue (+ i 1) j)) + (begin (sort (=> end i)) + (sort (=> start (+ j 1))))))))))))) + (test "vector-quick-sort!" + '#(1 2 3) + (vector-quick-sort! < (vector 3 2 1) 0 2))) + +(let ((list-tabulate + (lambda (length procedure) + (loop ((for i (up-from 0 (to length))) + (for list (listing (procedure i)))) + => list)))) + (test "list-tabulate with appending" + '(0 1 2 3) + (list-tabulate 4 values))) + +(let ((take + (lambda (list count) + (loop ((for i (up-from 0 (to count))) + (for elt (in-list list)) + (for prefix (listing elt))) + => prefix)))) + (test "take" + '(a b) + (take '(a b c d e) 2))) + +(let ((append-reverse + (lambda (list tail) + (loop ((for elt (in-list list)) + (for result (listing-reverse (initial tail) list))) + => result)))) + (test "append-reverse" + '((x) y) + (append-reverse '(x) '(y)))) + +(let ((unzip5 + (lambda (list) + (loop ((for component (in-list list)) + (for result1 (listing (first component))) + (for result2 (listing (second component))) + (for result3 (listing (third component))) + (for result4 (listing (fourth component))) + (for result5 (listing (fifth component)))) + => (values result1 result2 result3 result4 result5))))) + (test-values "unzip5" + (values '(1 2 3 4 5) + '(one two three four five)) + (unzip5 '((1 one) (2 two) (3 three) (4 four) (5 five))))) + +(let ((concatenate + (lambda (lists) + (loop ((for list (in-list lists)) + (for result (appending list))) + => list)))) + (test "concatenate" + '(1 2 3 4) + (concatenate '((1 2) (3 4))))) + +(let ((count + (lambda (predicate list) + (loop ((for elt (in-list list)) + (for count (summing 1 (if (predicate elt))))) + => count)))) + (test "count" + 3 + (count even? '(3 1 4 1 5 9 2 5 6)))) Index: tests/read.txt =================================================================== --- tests/read.txt (revision 0) +++ tests/read.txt (revision 0) @@ -0,0 +1,6 @@ +1 +2 +3 + +4 +5 Index: foof-loop.meta =================================================================== --- foof-loop.meta (revision 16994) +++ foof-loop.meta (working copy) @@ -1,9 +1,8 @@ -((author "Taylor R Campbell") +((author "Taylor R Campbell (test suite ported from foof-loop.txt by Peter Danenberg)") (synopsis "Extensible looping macros (originally based on Alex Shinn's)") (egg "foof-loop.egg") - (files "foof-loop.scm" "foof-loop.html" "foof-loop.setup") + (files "foof-loop.scm" "foof-loop.html" "foof-loop.setup" "tests/run.scm" "tests/read.txt") + (test-depends test streams) (license "Public Domain") (doc-from-wiki) - (category lang-exts) - (needs syntactic-closures) ; just to have one available - ) + (category lang-exts)) Index: TODO =================================================================== --- TODO (revision 0) +++ TODO (revision 0) @@ -0,0 +1,12 @@ +# -*- mode: org; -*- +* TODO test stream-filter + appears to need srfi-40 not srfi-41 +* TODO test shuffle-vector! + my local srfi-27 is defective +* TODO sieve + srfi-33 hasn't been ported yet +* TODO vector-quick-sort! doesn't define select-pivot +* DONE in-lists is defective + CLOSED: [2010-01-13 Wed 07:12] + - CLOSING NOTE [2010-01-13 Wed 07:12] \\ + had to export %cars&cdrs