;;; William E. Byrd
;;; 7 September 2005
;;; Annotated code from Dan Friedman's B521 lecture on 'syntax-rules' macros.

;;; Please ignore this definition, which is needed to make the file load properly.
(define --- '---)


;;; Here is our test macro from last week's 'G' function notes.
;;; After reading these macro notes you should be able to understand
;;; exactly how the 'test' macro works.  For example,
;;; you should be able to explain why the 'let' expression is
;;; necessary, and why 'e1' and 'e2' are quoted in the call to 'error'.
;;; If you can't answer these questions, please come to office hours.
(define-syntax test
  (syntax-rules ()
    [(_ name e1 e2)
     (let ([v1 e1][v2 e2])
       (if (equal? v1 v2)
           (printf "Test ~s passed.\n" name)
           (error 'test "\nTest ~s failed.\n~s => ~s\n~s => ~s" name 'e1 v1 'e2 v2)))]))



;;; Before we get started, let's ask ourselves what a macro is used for.
;;; Basically, a macro just allows us to type fewer keystrokes.

;;; For example, I could type the expression

; <long form>
((lambda (t)
   (if t
       t
       ((lambda (t) (if t t (even? (- 7 2)))) (zero? (- 5 5)))))
 (< 3 4))

;;; but I prefer to type

; <shorthand notation>
(or (< 3 4) (zero? (- 5 5)) (even? (- 7 2)))

;;; When you type the expression

(or (< 3 4) (zero? (- 5 5)) (even? (- 7 2)))

;;; into the Chez command prompt, the first thing Chez does is expand
;;; the expression into the equivalent expression

((lambda (t)
   (if t
       t
       ((lambda (t) (if t t (even? (- 7 2)))) (zero? (- 5 5)))))
 (< 3 4))

;;; which doesn't contain any macro expressions.  Chez then compiles
;;; this expanded expression and executes the compiled code.


;;; Similarly, the 'test' macro is convenient because I'd rather write

(test "foo"
      (or (< 3 4) (zero? (- 5 5)) (even? (- 7 2)))
      ((lambda (t)
         (if t
             t
             ((lambda (t) (if t t (even? (- 7 2)))) (zero? (- 5 5)))))
       (< 3 4)))

;;; than have to write

((lambda (v1 v2)
   (if (equal? v1 v2)
       (printf "Test ~s passed.\n" "foo")
       (error 'test
         "\nTest ~s failed.\n~s => ~s\n~s => ~s"
         "foo"
         '(or (< 3 4) (zero? (- 5 5)) (even? (- 7 2)))
         v1
         '((lambda (t)
             (if t
                 t
                 ((lambda (t) (if t t (even? (- 7 2)))) (zero? (- 5 5)))))
           (< 3 4))
         v2)))
 ((lambda (t)
    (if t
        t
        ((lambda (t) (if t t (even? (- 7 2)))) (zero? (- 5 5)))))
  (< 3 4))
 ((lambda (t)
    (if t
        t
        ((lambda (t) (if t t (even? (- 7 2)))) (zero? (- 5 5)))))
  (< 3 4)))

;;; But if I wanted to, I could just type in the expanded code.



;;; Okay--let's get started.
;;; In Assignment 1 you probably made use of Scheme's 'and':

(test "and-test-1"
      (and (> 4 3) (zero? (- 7 3)))
      #f)

(test "and-test-2"
      (and (> 4 3) (zero? (- 7 7)))
      #t)

(test "and-test-3"
      (and (> 4 3))
      #t)

(test "and-test-4"
      (and)
      #t)


;;; So how does 'and' work?
;;; 'and' takes zero or more expressions, and returns #f
;;; if any of the expressions evaluate to #f.  If all of the
;;; expressions evaluate to true values, 'and' returns the value of
;;; the last expression.

(test "and-test-5"
      (and (+ 4 3))
      7)

(test "and-test-6"
      (and (+ 4 3) (* 3 4))
      12)

;;; Remember that every Scheme value other than #f is considered a 'true' value.

;;; Let's define our own version of 'and' as a *function* (not a macro).
;;; We'll call this function 'andf', so that we don't clobber the built-in 'and'.

(define andf
  (lambda (---)
    (cond
      [--- ---]
      [--- ---]      
      [else ---])))

;;; This is our standard boiler-plate code for a recursive definition.
;;; The triple dashes (---) denote parts of the definition that we need to fill in.

;;; Let's fill in the formal argument list.

(define andf
  (lambda (args)
    (cond
      [--- ---]
      [--- ---]      
      [else ---])))

;;; We already have a problem.  'and' takes any number of arguments,
;;; but our 'andf' can only take a single argument:

(andf (+ 3 4))

;;; How can we make 'andf' process multiple expressions?
;;; We could pass in a list of expressions, of course.

(andf (list (+ 3 4) (> 4 3) (even? 7)))

;;; But it would be nicer if 'andf' could take any number of arguments,
;;; just like 'and'.  All we need to do is change '(args)' to 'args':

(define andf
  (lambda args
    (cond
      [--- ---]
      [--- ---]      
      [else ---])))

;;; Now we can call 'and' with any number of arguments.

(andf (+ 3 4) (> 4 3) (even? 7))

;;; The formal parameter 'args' will be bound to a list containing
;;; all of the arguments passed into 'andf'.  For purposes of illustration,
;;; we can write

(define andf
  (lambda args
    args))

;;; 'andf' will return a list of the arguments passed in.

(test "lambda-args-test"
  (andf (+ 3 4) (> 4 3) (even? 7))
  '(7 #t #f))

;;; Now that we can pass any number of arguments to 'andf',
;;; we can fill in more of the boiler-plate code.
;;; In order to make it more convenient to process the arguments
;;; in the 'args' list, however, we will use a helper function, 'andf^'.

(define andf
  (lambda args
    (letrec ([andf^ (lambda (args)
                      (cond
                        [--- ---]
                        [--- ---]      
                        [else ---]))])
      (andf^ args))))

;;; Notice that 'andf' uses the conventional '(args)' notation
;;; to indicate that it takes exactly one argument.

;;; In the base case, we check to see if 'args' is bound to a list of zero arguments.
;;; If so, 'andf' should return #t.

(define andf
  (lambda args
    (letrec ([andf^ (lambda (args)
                      (cond
                        [(null? args) #t]
                        [--- ---]      
                        [else ---]))])
      (andf^ args))))

;;; If 'args' isn't the empty list, it must contain at least one value.
;;; If the first element of 'args' is a true value, we recur to ensure that
;;; the remaining elements of 'args' are also true.

(define andf
  (lambda args
    (letrec ([andf^ (lambda (args)
                      (cond
                        [(null? args) #t]
                        [(car args) (andf (cdr args))]      
                        [else ---]))])
      (andf^ args))))

;;; If the first element in 'args' is not true, however, 'andf' must return #f.

(define andf
  (lambda args
    (letrec ([andf^ (lambda (args)
                      (cond
                        [(null? args) #t]
                        [(car args) (andf^ (cdr args))]
                        [else #f]))])
      (andf^ args))))

(test "andf-test-1"
      (andf (> 4 3) (zero? (- 7 3)))
      (and (> 4 3) (zero? (- 7 3))))

(test "andf-test-2"
      (andf (> 4 3) (zero? (- 7 7)))
      (and (> 4 3) (zero? (- 7 7))))

(test "andf-test-3"
      (andf (> 4 3))
      (and (> 4 3)))

(test "andf-test-4"
      (andf)
      (and))

; (test "andf-test-5"
;       (andf (+ 4 3))
;      (and (+ 4 3)))

; (test "andf-test-6"
;      (andf (+ 4 3) (* 3 4))
;      (and (+ 4 3) (* 3 4)))


;;; Tests 5 and 6 are commented out, because they fail!
;;; When 'andf' is passed just one value, it should
;;; return that value.  Instead, 'andf' returns
;;; #t if the value is true.

(test "bad-andf-test"
      (andf (+ 4 3))
      #t)

; vs.

(test "good-and-test"
      (and (+ 4 3))
      7)

;;; Fortunately this problem is easy to fix;
;;; we just need to add a 'cond' clause to 'andf'
;;; for the case in which the 'args' list contains
;;; exactly one value.  In this case, we just return
;;; that value.

(define andf
  (lambda args
    (letrec ([andf^ (lambda (args)
                      (cond
                        [(null? args) #t]
                        [(null? (cdr args)) (car args)]
                        [(car args) (andf^ (cdr args))]
                        [else #f]))])
      (andf^ args))))

;;; Now all of our tests pass.

(test "andf-test-1"
      (andf (> 4 3) (zero? (- 7 3)))
      (and (> 4 3) (zero? (- 7 3))))

(test "andf-test-2"
      (andf (> 4 3) (zero? (- 7 7)))
      (and (> 4 3) (zero? (- 7 7))))

(test "andf-test-3"
      (andf (> 4 3))
      (and (> 4 3)))

(test "andf-test-4"
      (andf)
      (and))

(test "andf-test-5"
      (andf (+ 4 3))
      (and (+ 4 3)))

(test "andf-test-6"
      (andf (+ 4 3) (* 3 4))
      (and (+ 4 3) (* 3 4)))


;;; We should be very pleased with ourselves!
;;; We managed to write a function that behaves like
;;; Scheme's 'and', and without having to mess around
;;; with that 'define-syntax'/'syntax-rules' nonsense!

;;; But maybe we are celebrating prematurely.
;;; Let's try another test, just for fun.

(test "good-news"
      (and #f (display "You shouldn't be reading this!\n") (display "Blame and!\n"))
      #f)

(test "oh no!"
      (andf #f (display "You shouldn't be reading this!\n") (display "Blame andf!\n"))
      #f)

;;; Both tests pass, but if you look at the output run running the tests you will
;;; notice a disturbing message.

; Blame andf!
; You shouldn't be reading this!

;;; What is going on here?  Well,

(andf #f --- ---)

;;; should return #f, regardless of the expressions denoted by '---'.
;;; Furthermore, those '---' expressions should not be evaluated.

;;; Why didn't our previous 'andf' tests uncover this problem?
;;; Because the expressions we were passing to 'andf' did not contain
;;; side-effects, such as printing a string to the console.

;;; The rule for a procedure application in Scheme
;;; is that all subexpressions in the application are evaluated *before*
;;; the function is invoked.  For example, consider the application

((if (> 3 4) + -) (* 2 5) (expt 2 3))

;;; There are three subexpressions in this application:

(if (> 3 4) + -)

(* 2 5)

(expt 2 3)

;;; Chez evaluates each subexpression, in some unspecified order.
;;; Just for fun, let's evaluate the subexpressions in right-to-left order.

(expt 2 3) ; => 8

(* 2 5) ; => 10

(if (> 3 4) + -) ; => #<procedure ->  (the subtraction function)

;;; Now we can make the call to the subtraction procedure:

((if (> 3 4) + -) (* 2 5) (expt 2 3))

; =>

(- 10 8)

; =>

2

;;; Scheme's 'and' is a "short-circuit" operator.
;;; 'and' evaluates its arguments one at a time, until an
;;; argument evaluates to #f, or until all of the arguments
;;; have evaluated to true values.

;;; Let's verify that this is true (without looking at the console output).
;;; Consider the definition of 'omega':

(define omega
  (lambda ()
    (omega)))

;;; A call to 'omega' goes into an infinite loop (or "diverges").

(test "fail fast!"
      (and #f (omega))
      #f)

;;; This test passes, which means that the expression (omega) was never evaluated.

;;; We dare not try the same test with 'andf', as we will certainly enter an infinite loop.

; (test "don't try this at home"
;      (andf #f (omega))
;      #f)

;;; But we actually have technology to test infinite loops.
;;; At least, we can make sure that an expression that should diverge
;;; doesn't return within a few milliseconds.

;;; Let's spend 10000000 units of time evaluating 'omega'.

(define max-ticks 10000000)

((make-engine (lambda () (omega)))
 max-ticks
 (lambda (t v) (error 'omega "infinite loop returned ~s after ~s ticks" v (- max-ticks t)))
 (lambda (e^) (display "Test 'omega' ran out of fuel, as expected.\n")))

;;; We didn't get an error, which means that 'omega' was still looping at the end
;;; of 10000000 ticks of time.

;;; Let's verify that (andf #f (omega)) also diverges.

((make-engine (lambda () (andf #f (omega))))
 max-ticks
 (lambda (t v) (error 'andf/omega "infinite loop returned ~s after ~s ticks" v (- max-ticks t)))
 (lambda (e^) (display "Test 'andf/omega' ran out of fuel, as expected.\n")))

;;; Once again, the test passed.
;;; We can't run this next test, however, since it would signal an error
;;; once (and #f (omega)) terminated.

; ((make-engine (lambda () (and #f (omega))))
;  max-ticks
;  (lambda (t v) (error 'and/omega "infinite loop returned ~s after ~s ticks" v (- max-ticks t)))
;  (lambda (e^) (display "Test 'and/omega' ran out of fuel, as expected.\n")))

;;; To recap, the problem is that 'andf' is a function, and therefore
;;; a call to 'andf' evaluates every argument.

;;; Is there a way to control when an argument to 'andf' is evaluated?
;;; Yes!  We can 'thunkify' the arguments to 'andf'--that is, we can
;;; turn each argument 'a' into a lambda expression '(lambda () a)'.

;;; For example, instead of writing

(andf #f (display "You shouldn't be reading this!\n") (display "Blame andf!\n"))

;;; we would write

(andf (lambda () #f)
      (lambda () (display "You shouldn't be reading this!\n"))
      (lambda () (display "Blame andf!\n")))

;;; Evaluating a lambda expression (lambda () body) returns a procedure
;;; of zero arguments (a thunk), but does not evaluate 'body'.
;;; The 'body' expression is not evaluated until the thunk is invoked.

;;; Similarly, we could write

(andf (lambda () (> 3 4)) (lambda () (omega)))

;;; without fear of an infinite loop.

;;; Unfortunately, thunkifying the arguments
;;; wreaks havoc on 'andf'.

(let ([th (lambda () #f)])
  (test "doh!"
        (andf th)
        th))

;;; We can no longer make 'andf' return #f, since
;;; even #f is wrapped in a thunk, and since all
;;; thunks (procedures) are considered true values in Scheme.

;;; What can we do about this new problem?  We can
;;; modify 'andf' to invoke a thunk whenever we want to
;;; evaluate the expression wrapped inside the thunk.

(define andf
  (lambda args
    (letrec ([andf^ (lambda (args)
                      (cond
                        [(null? args) #t]
                        [(null? (cdr args)) ((car args))]
                        [((car args)) (andf^ (cdr args))]
                        [else #f]))])
      (andf^ args))))

;;; When we want the value associated with the thunk (car args),
;;; we invoke the thunk:  ((car args)).  Otherwise,
;;; this code is identical to the previous definition of 'andf'.


(test "Good times!"
      (andf (lambda () #f))
      #f)

(test "Look! No divergence"
      (andf (lambda () #f) (lambda () (omega)))
      #f)

(test "You shouldn't, and you won't!"
      (andf (lambda () #f)
            (lambda () (display "You shouldn't be reading this!\n"))
            (lambda () (display "Blame andf!\n")))
      #f)

;;; Now having to wrap everything in a thunk is a pain,
;;; and makes our beautiful code look like Java, or worse!
;;; We can do better, by defining our version of 'and'
;;; as a macro instead of a function.  A macro allow you to
;;; control if and when the macro's arguments are evaluated,
;;; which is exactly what we need.

;;; I'll say it again, because this is one of the main reasons macros are useful:

;;; *** A macro allow you to control if and when the macro's arguments are evaluated ***


;;; By the way, you might be wondering whether there is an easy way to
;;; tell whether (foo bar baz) is a call to a function 'foo', or whether
;;; 'foo' is syntax associated with a macro.  To find out, just type in
;;; 'foo' at the Chez prompt.  For example, you can type 'and':

; > and

; Error: invalid syntax and.
; Type (debug) to enter the debugger.

;;; Obviously 'and' is syntax associated with a macro, as opposed to a variable
;;; associated with a procedure.  In contrast, we can type in 'andf':

; > andf
; #<procedure>

;;; So the variable 'andf' is associated with a good old Scheme procedure.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; We will begin the next installment by writing the 'and' macro.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ignore the code fragments beyond this point.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#!eof

;;; Here is a the 'and' macro presented in class.
;;; We use the name 'and&' instead of 'and'
;;; to avoid clobbering the 'and' form built into Chez Scheme.

(define-syntax and&
  (syntax-rules ()
    [(and&) #t]
    [(and& e) e]
    [(and& e0 e1 ...) 
     (if e0
	 (and& e1 ...)
	 #f)]))

(define-syntax and&
  (syntax-rules ()
    [(foo) #t]
    [(foo e) e]
    [(foo e0 e1 ...) 
     (if e0
	 (and& e1 ...)
	 #f)]))

(define-syntax and&
  (syntax-rules ()
    [(_) #t]
    [(_ e) e]
    [(_ e0 e1 ...) 
     (if e0
	 (and& e1 ...)
	 #f)]))


(function args ...)

(+ 1 2)
(+ 1 2 3 4)

((if (> 3 4) + -) 4 5)

(macro-name arg ...)



(and (> 3 4)) => (> 3 4)

> (expand '(and (> 3 4)))
(> 3 4)
> (expand '(and (> 3 4) (> 4 5)))
(if (> 3 4) (> 4 5) #f)
> (expand '(and))
#t
> 


;;; Careful swapping order of patterns
;;; e0 e1 ...
;;; vs.
;;; e0 e1 e2 ...


;; This doesn't work!

(define-syntax and&
  (syntax-rules ()
    [(_) #t]
    [(_ e) e]
    [(_ e0 ...) 
     (if e0
	 (and& ...)
	 #f)]))



(define andf
  (lambda (e1 e2)
    (if e1
	e2
	#f)))




(define andf
  (lambda (th1 th2)
    (if (th1)
	(th2)
	#f)))

> (andf (> 3 4) (display "wow!\n"))
wow!



> (andf (lambda () (> 3 4)) (lambda () (display "wow!\n")))
#f





;;; No else in exact match list
(define-syntax exact-case
  (syntax-rules ()
    [(_ s [else e0 e1 ...])
     (begin e0 e1 ...)]
    [(_ s [sym e0 e1 ...] x ...)
     (if (eq? s 'sym)
	 (begin e0 e1 ...)
	 (exact-case s x ...))]))

(define-syntax exact-case
  (syntax-rules ()
    [(_ s [else e0 e1 ...])
     (begin e0 e1 ...)]
    [(_ s [sym e0 e1 ...][sym^ e0^ e1^ ...]  ...)
     (if (eq? s 'sym)
	 (begin e0 e1 ...)
	 (exact-case s [sym^ e0^ e1^ ...] ...))]))

> (exact-case 'z
    [x 3 4 (+ 2 3)]
    [y "foo"])
"foo"

> (exact-case 'z
    [y 3 4 (+ 2 3)]
    [y "foo"])
"foo"

> (exact-case 'z
    [y "bar"]
    [y "foo"])
"foo"


> (exact-case 'z
    [else "foo"])
"foo"

> (exact-case 'z
    [y "foo"])
"foo"

(define-syntax exact-case
  (syntax-rules (else)
    [(_ s [else e0 e1 ...])
     (begin e0 e1 ...)]
    [(_ s [sym e0 e1 ...] x ...)
     (if (eq? s 'sym)
	 (begin e0 e1 ...)
	 (exact-case s x ...))]))

> (exact-case 'y
    [x 3 4 (+ 2 3)]
    [y "foo"])
Error: invalid syntax (exact-case (quote y)).
Type (debug) to enter the debugger.

> (exact-case 'y
    [else (display "h") (display "i!\n") 5])
hi!
5

> (exact-case 'y
    [x 3 4 (+ 2 3)]
    [y "foo"]
    [else 6])
"foo"

> (let ([y 'x])
    (exact-case y
      [y "foo"]
      [x 3 4 (+ 2 3)]
      [else 6]))
5
> (let ([y 'z]) 
    (exact-case y 
      [x 3 4 (+ 2 3)]
      [else 6]))
6



;;; Do more quoting in the macro
(define-syntax exact-case
  (syntax-rules ()
    [(_ s [else e0 e1 ...])
     (begin e0 e1 ...)]
    [(_ s [sym e0 e1 ...][sym^ e0^ e1^ ...]  ...)
     (if (eq? 's 'sym)
	 (begin e0 e1 ...)
	 (exact-case s [sym^ e0^ e1^ ...] ...))]))

(exact-case y
    [y 3 4 (+ 2 3)]
    [y "foo"]
    [else 6])





;;; Want an extra base case

(define-syntax exact-case
  (syntax-rules (else)
    [(_ s [else e0 e1 ...])
     (begin e0 e1 ...)]
    [(_ s [sym e0 e1 ...])
     (if (eq? s 'sym)
	 (begin e0 e1 ...)
	 (if #f #f))]
    [(_ s [sym e0 e1 ...] x ...)
     (if (eq? s 'sym)
	 (begin e0 e1 ...)
	 (exact-case s x ...))]))



(expand '(define chris
    (lambda (variable)
      (exact-case variable
	[y 5]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[x 8]
	[else 3]))))