haskeem-0.7.0: macro-test.scm

(write-string "################ numeric-if test\n")

; This tests how many times everything gets evaluated
(define probe 0)

(define neg-action (lambda () (set! probe (+ probe 1)) "negative!"))
(define zero-action (lambda () (set! probe (+ probe 10)) "zero!"))
(define pos-action (lambda () (set! probe (+ probe 100)) "positive!"))

; The value returned from this determines which of the three branches is chosen
(define test-value (lambda () (set! probe (+ probe 1000)) -1))

(define numeric-if-tmp "foo")

; This version is careful to evaluate tval only once
(defmacro (numeric-if-1 tval ifn ifz ifp)
  `(let ((numeric-if-tmp ,tval))
     (display numeric-if-tmp)
     (newline)
     (if (number? numeric-if-tmp)
	 (if (negative? numeric-if-tmp)
	     ,ifn
	     (if (positive? numeric-if-tmp)
		 ,ifp
		 ,ifz))
	 (raise "error: non-numeric test value passed to numeric-if"))))

; This version might evaluate tval two or three times
(defmacro (numeric-if-2 tval ifn ifz ifp)
  `(if (number? ,tval)
       (if (negative? ,tval)
	   ,ifn
	   (if (positive? ,tval)
	       ,ifp
	       ,ifz))
       (raise "error: non-numeric test value passed to numeric-if")))

; A function version of numeric-if would evaluate each argument precisely once,
; so that after the test the value of probe would be 1111

(display numeric-if-tmp)
(newline)
(write-string "before: probe is " (number->string probe) #\newline)
(define ret
  (guard
   (err ((begin (write-string "exception is '")
		(display err)
		(write-string "'\n")
		#t) err))
   (numeric-if-2 (test-value)
		 (neg-action)
		 (zero-action)
		 (pos-action))))
(write-string "after: probe is " (number->string probe) #\newline)
(write-string "result returned: ")
(display ret)
(newline)
(display numeric-if-tmp)
(newline)

(write-string "################ assertion test\n")
(defmacro (assert some-cond)
  `(when (not ,some-cond)
	 (write-string "assertion failure: ")
	 (display ',some-cond)
	 (newline)))

(define x "foo")
(display x)
(newline)
(assert (eqv? x "bar"))

(write-string "################ th-th-that's all, folks!\n")