; 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) (inc! 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 1.3 2004/07/08 21:53:33 oleg Exp $ ; -- 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 "srfi-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)