1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243

;; Ported from http://pobox.com/~oleg/ftp/Scheme/vland.scm
;; License terms:
;;
;; http://pobox.com/~oleg/ftp/
;;
;; "Unless specified otherwise, all the code and the documentation on this site
;; is in public domain."
;; ChangeLog
;;
;; 20070613 yamaken Copied from "vland.scm,v 2.0 2002/06/28" and adapted
;; to SigScheme
; A special form andlet*
; Validation code
;
; ANDLET* (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 SRFI2 <http://srfi.schemers.org/srfi2/>
;
; 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 ANDLET* special form lets constituent expressions get hold
; of the results of already evaluated expressions, without redoing
; their work.
;
; Syntax:
; ANDLET* (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
; BOUNDVARIABLE
; These CLAWS are evaluated in the strict lefttoright order. For each
; CLAW, the EXPRESSION part is evaluated first
; (or BOUNDVARIABLE is looked up).
;
; If the result is #f, ANDLET* 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 ANDLET* is a sort of crossbreed between LET* and AND.
;
; Denotation semantics:
;
; Eval[ (ANDLET* (CLAW1 ...) BODY), Env] =
; EvalClaw[ CLAW1, Env ] andalso
; Eval[ (ANDLET* ( ...) BODY), ExtClawEnv[ CLAW1, Env]]
;
; Eval[ (ANDLET* (CLAW) ), Env] = EvalClaw[ CLAW, Env ]
; Eval[ (ANDLET* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ]
; Eval[ (ANDLET* () ), Env] = #t
;
; EvalClaw[ BOUNDVARIABLE, Env ] = Eval[ BOUNDVARIABLE, Env ]
; EvalClaw[ (EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]
; EvalClaw[ (VARIABLE EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]
;
; ExtClawEnv[ BOUNDVARIABLE, Env ] = Env
; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ]
; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] =
; ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ],
; VARIABLE boundto Eval[ EXPRESSION, Env ]]
;
; If ANDLET* is implemented as a macro, it converts a ANDLET* expression
; into a "tree" of AND and LET expressions. For example,
;
; (ANDLET* ((mylist (computelist)) ((not (null? mylist))))
; (dosomething mylist))
; is transformed into
; (and (let ((mylist (computelist)))
; (and mylist (not (null? mylist)) (begin (dosomething mylist)))))
;
; Sample applications:
;
; The following piece of code (from my treap package)
; (let ((newroot (node:dispatchonkey root key ...)))
; (if newroot (set! root newroot)))
; could be elegantly rewritten as
; (andlet* ((newroot (node:dispatchonkey root key ...)))
; (set! root newroot))
;
; A very common application of andlet* is looking up a value
; associated with a given key in an assoc list, returning #f in case of a
; lookup failure:
;
; ; Standard implementation
; (define (lookup key alist)
; (let ((foundassoc (assq key alist)))
; (and foundassoc (cdr foundassoc))))
;
; ; A more elegant solution
; (define (lookup 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 (lookup key alist)
; (andlet* ((x (assq key alist))) (cdr x)))
;
; Generalized cond:
;
; (or
; (andlet* (bindingscond1) body1)
; (andlet* (bindingscond2) body2)
; (begin elseclause))
;
; Unlike => (cond's send), ANDLET* applies beyond cond. ANDLET* can
; also be used to generalize cond, as => is limited to sending of
; a single value; ANDLET* allows as many bindings as necessary
; (which are performed in sequence)
;
; (or
; (andlet* ((c (readchar)) ((not (eofobject? c))))
; (stringset! somestr i c) (++! i))
; (begin (doprocesseof)))
;
; Another concept ANDLET* is reminiscent of is programming with guards:
; an ANDLET* 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. ANDLET* 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 andlet* 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 SRFI12. For Gambit, do the following:
; (include "myenv.scm")
; (include "srf12.scm")
; prior to evaluation of this file.
; For example: gsi e '(include "myenv.scm")(include "srfi12.scm")' vland.scm
; For Bigloo, the following command line can be used:
; echo '(module test (include "myenvbigloo.scm") (include "srfi12.scm")
; (include "vland.scm"))'  bigloo i 
(requireextension (unittest))
(requireextension (srfi 2))
(if (not (provided? "srfi2"))
(testskip "SRFI2 is not enabled"))
(define tn testname)
(define expect
(lambda (form expectedresult)
(assertequal? (tn)
expectedresult
(eval form (interactionenvironment)))))
(define mustbeasyntaxerror
(lambda (form)
(asserterror (tn)
(lambda ()
(eval form (interactionenvironment))))))
; Test cases
; No claws
(tn "andlet* no claws")
(expect '(andlet* () 1) 1)
(expect '(andlet* () 1 2) 2)
(expect '(andlet* () ) #t)
(mustbeasyntaxerror '(andlet* #f #t) )
(mustbeasyntaxerror '(andlet* #f) )
; One claw, no body
(tn "andlet* one claw, no body")
(expect '(let ((x #f)) (andlet* (x))) #f)
(expect '(let ((x 1)) (andlet* (x))) 1)
(expect '(let ((x 1)) (andlet* ( (x) ))) 1)
(expect '(let ((x 1)) (andlet* ( ((+ x 1)) ))) 2)
(expect '(andlet* ((x #f)) ) #f)
(expect '(andlet* ((x 1)) ) 1)
(mustbeasyntaxerror '(andlet* ( #f (x 1))) )
; two claws, no body
(tn "andlet* two claws, no body")
(expect '(andlet* ( (#f) (x 1)) ) #f)
(mustbeasyntaxerror '(andlet* (2 (x 1))) )
(expect '(andlet* ( (2) (x 1)) ) 1)
(expect '(andlet* ( (x 1) (2)) ) 2)
(expect '(andlet* ( (x 1) x) ) 1)
(expect '(andlet* ( (x 1) (x)) ) 1)
; two claws, body
(tn "andlet* two claws, body")
(expect '(let ((x #f)) (andlet* (x) x)) #f)
(expect '(let ((x "")) (andlet* (x) x)) "")
(expect '(let ((x "")) (andlet* (x) )) "")
(expect '(let ((x 1)) (andlet* (x) (+ x 1))) 2)
(expect '(let ((x #f)) (andlet* (x) (+ x 1))) #f)
(expect '(let ((x 1)) (andlet* (((positive? x))) (+ x 1))) 2)
(expect '(let ((x 1)) (andlet* (((positive? x))) )) #t)
(expect '(let ((x 0)) (andlet* (((positive? x))) (+ x 1))) #f)
(expect '(let ((x 1)) (andlet* (((positive? x)) (x (+ x 1))) (+ x 1))) 3)
(expect
'(let ((x 1)) (andlet* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))
4
)
(expect '(let ((x 1)) (andlet* (x ((positive? x))) (+ x 1))) 2)
(expect '(let ((x 1)) (andlet* ( ((begin x)) ((positive? x))) (+ x 1))) 2)
(expect '(let ((x 0)) (andlet* (x ((positive? x))) (+ x 1))) #f)
(expect '(let ((x #f)) (andlet* (x ((positive? x))) (+ x 1))) #f)
(expect '(let ((x #f)) (andlet* ( ((begin x)) ((positive? x))) (+ x 1))) #f)
(expect '(let ((x 1)) (andlet* (x (y ( x 1)) ((positive? y))) (/ x y))) #f)
(expect '(let ((x 0)) (andlet* (x (y ( x 1)) ((positive? y))) (/ x y))) #f)
(expect '(let ((x #f)) (andlet* (x (y ( x 1)) ((positive? y))) (/ x y))) #f)
(expect '(let ((x 3)) (andlet* (x (y ( x 1)) ((positive? y))) (/ x y))) (/ 3 2))
(totalreport)
