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