Author: yamakenz Date: Tue Jun 12 14:27:05 2007 New Revision: 4580 Added: vendor/misc/ vendor/misc/README vendor/misc/vland.scm
Log: * vendor/misc - New directory * vendor/README - New file * vendor/vland.scm - New file imported from http://pobox.com/~oleg/ftp/Scheme/vland.scm Added: vendor/misc/README ============================================================================== --- (empty file) +++ vendor/misc/README Tue Jun 12 14:27:05 2007 @@ -0,0 +1,11 @@ +This directory containts miscellaneous imported sources. + +------------------------------------------------------------------------------ +File: vland.scm +URL: http://pobox.com/~oleg/ftp/Scheme/vland.scm +License type: Public domain +License terms: + http://pobox.com/~oleg/ftp/ + Unless specified otherwise, all the code and the documentation on this site + is in public domain. +------------------------------------------------------------------------------ Added: vendor/misc/vland.scm ============================================================================== --- (empty file) +++ vendor/misc/vland.scm Tue Jun 12 14:27:05 2007 @@ -0,0 +1,271 @@ +; A special form and-let* +; Validation code +; +; AND-LET* (formerly known as LAND*) is an AND with local bindings, a +; guarded LET* special form. It evaluates a sequence of forms one +; after another till the first one that yields #f; the non-#f result +; of a form can be bound to a fresh variable and used in the +; subsequent forms. +; +; It is defined in SRFI-2 <http://srfi.schemers.org/srfi-2/> +; +; Motivation: +; When an ordinary AND is formed of _proper_ boolean expressions: +; (AND E1 E2 ...) +; +; the expression E2, if it gets to be evaluated, knows that E1 has +; returned non-#f. Moreover, E2 knows exactly what the result of E1 +; was - #t - so E2 can use this knowledge to its advantage. If E1 +; however is an _extended_ boolean expression, E2 can no longer tell +; which particular non-#f value was returned by E1. Chances are it +; took a lot of work to evaluate E1, and the produced result (a +; number, a vector, a string, etc) may be of value to E2. Alas, the +; AND form merely checks that the result is not an #f, and throws it +; away. If E2 needs it, it has to recompute the value again. This +; proposed AND-LET* special form lets constituent expressions get hold +; of the results of already evaluated expressions, without re-doing +; their work. +; +; Syntax: +; AND-LET* (CLAWS) BODY +; +; where CLAWS is a list of expressions or bindings: +; CLAWS ::= '() | (cons CLAW CLAWS) +; Every element of the CLAWS list, a CLAW, must be one of the following: +; (VARIABLE EXPRESSION) +; or +; (EXPRESSION) +; or +; BOUND-VARIABLE +; These CLAWS are evaluated in the strict left-to-right order. For each +; CLAW, the EXPRESSION part is evaluated first +; (or BOUND-VARIABLE is looked up). +; +; If the result is #f, AND-LET* immediately returns #f, +; thus disregarding the rest of the CLAWS and the BODY. If the +; EXPRESSION evaluates to not-#f, and the CLAW is of the form +; (VARIABLE EXPRESSION) +; the EXPRESSION's value is bound to a freshly made VARIABLE. The VARIABLE is +; available for _the rest_ of the CLAWS, and the BODY. +; +; Thus AND-LET* is a sort of cross-breed between LET* and AND. +; +; Denotation semantics: +; +; Eval[ (AND-LET* (CLAW1 ...) BODY), Env] = +; EvalClaw[ CLAW1, Env ] andalso +; Eval[ (AND-LET* ( ...) BODY), ExtClawEnv[ CLAW1, Env]] +; +; Eval[ (AND-LET* (CLAW) ), Env] = EvalClaw[ CLAW, Env ] +; Eval[ (AND-LET* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ] +; Eval[ (AND-LET* () ), Env] = #t +; +; EvalClaw[ BOUND-VARIABLE, Env ] = Eval[ BOUND-VARIABLE, Env ] +; EvalClaw[ (EXPRESSION), Env ] = Eval[ EXPRESSION, Env ] +; EvalClaw[ (VARIABLE EXPRESSION), Env ] = Eval[ EXPRESSION, Env ] +; +; ExtClawEnv[ BOUND-VARIABLE, Env ] = Env +; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ] +; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] = +; ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ], +; VARIABLE boundto Eval[ EXPRESSION, Env ]] +; +; If AND-LET* is implemented as a macro, it converts a AND-LET* expression +; into a "tree" of AND and LET expressions. For example, +; +; (AND-LET* ((my-list (compute-list)) ((not (null? my-list)))) +; (do-something my-list)) +; is transformed into +; (and (let ((my-list (compute-list))) +; (and my-list (not (null? my-list)) (begin (do-something my-list))))) +; + +; Sample applications: +; +; The following piece of code (from my treap package) +; (let ((new-root (node:dispatch-on-key root key ...))) +; (if new-root (set! root new-root))) +; could be elegantly re-written as +; (and-let* ((new-root (node:dispatch-on-key root key ...))) +; (set! root new-root)) +; +; A very common application of and-let* is looking up a value +; associated with a given key in an assoc list, returning #f in case of a +; look-up failure: +; +; ; Standard implementation +; (define (look-up key alist) +; (let ((found-assoc (assq key alist))) +; (and found-assoc (cdr found-assoc)))) +; +; ; A more elegant solution +; (define (look-up key alist) +; (cdr (or (assq key alist) '(#f . #f)))) +; +; ; An implementation which is just as graceful as the latter +; ; and just as efficient as the former: +; (define (look-up key alist) +; (and-let* ((x (assq key alist))) (cdr x))) +; +; Generalized cond: +; +; (or +; (and-let* (bindings-cond1) body1) +; (and-let* (bindings-cond2) body2) +; (begin else-clause)) +; +; Unlike => (cond's send), AND-LET* applies beyond cond. AND-LET* can +; also be used to generalize cond, as => is limited to sending of +; a single value; AND-LET* allows as many bindings as necessary +; (which are performed in sequence) +; +; (or +; (and-let* ((c (read-char)) ((not (eof-object? c)))) +; (string-set! some-str i c) (++! i)) +; (begin (do-process-eof))) +; +; Another concept AND-LET* is reminiscent of is programming with guards: +; an AND-LET* form can be considered a sequence of _guarded_ expressions. +; In a regular program, forms may produce results, bind them to variables +; and let other forms use these results. AND-LET* differs in that it checks +; to make sure that every produced result "makes sense" (that is, not an #f). +; The first "failure" triggers the guard and aborts the rest of the +; sequence (which presumably would not make any sense to execute anyway). +; +; $Id: vland.scm,v 2.0 2002/06/28 19:50:32 oleg Exp oleg $ + +; -- make sure the implementation of and-let* is included. It is usually +; the part of my prelude. +; We also assume the the myenv prelude is included at this point, +; as well as SRFI-12. For Gambit, do the following: +; (include "myenv.scm") +; (include "srf-12.scm") +; prior to evaluation of this file. +; For example: gsi -e '(include "myenv.scm")(include "srfi-12.scm")' vland.scm +; For Bigloo, the following command line can be used: +; echo '(module test (include "myenv-bigloo.scm") (include "srfi-12.scm") +; (include "vland.scm"))' | bigloo -i -- + + +(cout nl "Validating AND-LET*..." nl nl) + +(cond-expand + (gambit + (define interaction-environment (lambda () #f))) + (else #f)) + +;---- Unit test harness + + ; make sure that the 'FORM' gave upon evaluation the + ; EXPECTED-RESULT +(define (expect form expected-result) + (display "evaluating ") + (write form) + (let ((real-result (eval form (interaction-environment)))) + (if (equal? real-result expected-result) + (cout "... gave the expected result: " real-result nl) + (error "... returned: " real-result + " which differs from the expected result: " expected-result) + ))) + + ; Check to see that 'form' has indeed a wrong syntax +(define (must-be-a-syntax-error form) + (display "evaluating ") + (write form) + (if + (not + (handle-exceptions + exc + (begin (cout "caught an expected exception: " exc nl) + #t) + (eval form (interaction-environment)) + #f)) + (error "The above form should have generated a syntax error."))) + +;--- Test cases + +; No claws +(expect '(and-let* () 1) 1) +(expect '(and-let* () 1 2) 2) +(expect '(and-let* () ) #t) + +(must-be-a-syntax-error '(and-let* #f #t) ) +(must-be-a-syntax-error '(and-let* #f) ) + +; One claw, no body +(expect '(let ((x #f)) (and-let* (x))) #f) +(expect '(let ((x 1)) (and-let* (x))) 1) +(expect '(let ((x 1)) (and-let* ( (x) ))) 1) +(expect '(let ((x 1)) (and-let* ( ((+ x 1)) ))) 2) +(expect '(and-let* ((x #f)) ) #f) +(expect '(and-let* ((x 1)) ) 1) +(must-be-a-syntax-error '(and-let* ( #f (x 1))) ) + +; two claws, no body +(expect '(and-let* ( (#f) (x 1)) ) #f) +(must-be-a-syntax-error '(and-let* (2 (x 1))) ) +(expect '(and-let* ( (2) (x 1)) ) 1) +(expect '(and-let* ( (x 1) (2)) ) 2) +(expect '(and-let* ( (x 1) x) ) 1) +(expect '(and-let* ( (x 1) (x)) ) 1) + +; two claws, body +(expect '(let ((x #f)) (and-let* (x) x)) #f) +(expect '(let ((x "")) (and-let* (x) x)) "") +(expect '(let ((x "")) (and-let* (x) )) "") +(expect '(let ((x 1)) (and-let* (x) (+ x 1))) 2) +(expect '(let ((x #f)) (and-let* (x) (+ x 1))) #f) +(expect '(let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2) +(expect '(let ((x 1)) (and-let* (((positive? x))) )) #t) +(expect '(let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f) +(expect '(let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) 3) +(expect + '(let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))) + 4 +) + +(expect '(let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2) +(expect '(let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2) +(expect '(let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f) +(expect '(let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f) +(expect '(let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f) + +(expect '(let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) +(expect '(let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) +(expect '(let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) +(expect '(let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) (/ 3 2)) + + +(cond-expand + (gambit + (cout nl "Printing out the re-written and-let* expression" nl) + (let + ((a-definition + '(define (bbb) + (and-let* ((my-list (compute-list)) a-condition + ((not (null? my-list))) + (my-list-tail (cdr my-list))) + (do-something my-list-tail))))) + (cout "The result of compiling of" nl + (lambda () (pp a-definition)) nl "is the following" nl) + (eval a-definition) + (pp bbb) + )) + (bigloo + (cout nl "Printing out the re-written and-let* expression" nl) + (let + ((a-definition + '(define (bbb) + (and-let* ((my-list (compute-list)) a-condition + ((not (null? my-list))) + (my-list-tail (cdr my-list))) + (do-something my-list-tail))))) + (cout "The result of compiling of" nl + (lambda () (pp a-definition)) nl "is the following:" nl + (lambda () (pp (expand a-definition))) + nl) + )) + (else + #f)) + +(cout nl "All tests passed" nl)
