1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees
4
5; The reference implementation is written in some weird Scheme variant.
6; This is an attempt to produce the same result using SYNTAX-RULES.
7
8; I found the both the specification and the implementation unhelpful.
9; For example, one would think that (AND-LET* ()) -> #T by analogy with
10; (AND) -> #T.  The specification doesn't say.
11;
12; The following behaves correctly on the test cases at the end of the
13; reference implementation,  except that it doesn't catch the three syntax
14; errors.  There is no way for SYNTAX-RULES to distinguish between a
15; constant and a variable, and no easy way to check if a variable is
16; being used twice in the same AND-LET* (and why is that an error? LET*
17; allows it).
18
19(define-syntax and-let*
20  (syntax-rules ()
21
22    ; No body - behave like AND.
23    ((and-let* ())
24     #t)
25    ((and-let* ((var exp)))
26     exp)
27    ((and-let* ((exp)))
28     exp)
29    ((and-let* (var))
30     var)
31
32    ; Have body - behave like LET* but check for #F values.
33
34    ; No clauses so just use the body.
35    ((and-let* () . body)
36     (begin . body))
37
38    ; (VAR VAL) clause - bind the variable and check for #F.
39    ((and-let* ((var val) more ...) . body)
40     (let ((var val))
41       (if var
42	   (and-let* (more ...) . body)
43	   #f)))
44
45    ; Error check to catch illegal (A B ...) clauses.
46    ((and-let* ((exp junk . more-junk) more ...) . body)
47     (syntax-violation 'and-let*
48		       "syntax error"
49		       '(and-let* ((exp junk . more-junk) more ...) . body)))
50
51    ; (EXP) and VAR - just check the value for #F.
52    ; There is no way for us to check that VAR is an identifier and not a
53    ; constant
54    ((and-let* ((exp) more ...) . body)
55     (if exp
56	 (and-let* (more ...) . body)
57	 #f))
58    ((and-let* (var more ...) . body)
59     (if var
60	 (and-let* (more ...) . body)
61	 #f))))
62
63;(define-syntax expect
64;  (syntax-rules ()
65;    ((expect a b)
66;     (if (not (equal? a b))
67;         (assertion-violation 'expect "test failed" 'a b)))))
68;
69;(expect  (and-let* () 1) 1)
70;(expect  (and-let* () 1 2) 2)
71;(expect  (and-let* () ) #t)
72;
73;(expect (let ((x #f)) (and-let* (x))) #f)
74;(expect (let ((x 1)) (and-let* (x))) 1)
75;(expect (and-let* ((x #f)) ) #f)
76;(expect (and-let* ((x 1)) ) 1)
77;;(must-be-a-syntax-error (and-let* ( #f (x 1))) )
78;(expect (and-let* ( (#f) (x 1)) ) #f)
79;;(must-be-a-syntax-error (and-let* (2 (x 1))) )
80;(expect (and-let* ( (2) (x 1)) ) 1)
81;(expect (and-let* ( (x 1) (2)) ) 2)
82;(expect (let ((x #f)) (and-let* (x) x)) #f)
83;(expect (let ((x "")) (and-let* (x) x)) "")
84;(expect (let ((x "")) (and-let* (x)  )) "")
85;(expect (let ((x 1)) (and-let* (x) (+ x 1))) 2)
86;(expect (let ((x #f)) (and-let* (x) (+ x 1))) #f)
87;(expect (let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2)
88;(expect (let ((x 1)) (and-let* (((positive? x))) )) #t)
89;(expect (let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f)
90;(expect (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1)))  3)
91;;(must-be-a-syntax-error
92;;  (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))
93;;)
94;
95;(expect (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2)
96;(expect (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2)
97;(expect (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f)
98;(expect (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f)
99;(expect (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f)
100;
101;(expect  (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
102;(expect  (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
103;(expect  (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
104;(expect  (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2)
105
106