haskeem-0.7.4: 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))

; This version is careful to evaluate tval only once
(defmacro (numeric-if-1 tval ifn ifz ifp)
  (let ((nit (new-symbol)))
    `(let ((,nit ,tval))
       (if (number? ,nit)
	   (if (negative? ,nit)
	       ,ifn
	       (if (positive? ,nit)
		   ,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

(write-string "test-value returns ")
(display (test-value))
(newline)
(set! probe 0)
(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-1 (test-value)
		 (neg-action)
		 (zero-action)
		 (pos-action))))
(write-string "after:  probe is " (number->string probe) #\newline)
(write-string "result is ")
(display ret)
(newline)

(write-string "################ assertion test\n")
; really we ought to raise an exception here if the assertion failed;
; this is just to be friendly for the test
(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 "################ while test\n")
(defmacro (while some-cond . some-actions)
  (let ((mc (new-symbol)))
    `(do ((,mc 0 (+ ,mc 1)))
	 ((not ,some-cond) ,mc)
       ,@some-actions)))

(define i 0)
(define count (while (< i 10) (set! i (+ i 1)) (display i)))
(write-string #\newline "i sez " (number->string i) #\newline
	      "loop count sez " (number->string count) #\newline)

(write-string "######## nested while test\n")
(define j 0)
(set! i 0)
(while (< i 4)
       (set! j 0)
       (while (< j 4)
	      (set! j (+ j 1))
	      (write-string (number->string i) "/"
			    (number->string j) #\newline))
       (set! i (+ i 1)))

(write-string "################ swap test\n")
(defmacro (swap var1 var2)
  (let ((vs (new-symbol)))
    `(let ((,vs ,var1))
       (set! ,var1 ,var2)
       (set! ,var2 ,vs))))

(define val1 0)
(define val2 1)
(write-string "before: val1 is " (number->string val1)
	      ", val2 is " (number->string val2) #\newline)
(swap val1 val2)
(write-string "after:  val1 is " (number->string val1)
	      ", val2 is " (number->string val2) #\newline)

; can we break it? I don't think so... at least not this way:
; haskeem doesn't support re-binding of special forms, and set! is one
(write-string "before: val1 is " (number->string val1)
	      ", val2 is " (number->string val2) #\newline)
(let ((set! display))
  (swap val1 val2))
(write-string "after:  val1 is " (number->string val1)
	      ", val2 is " (number->string val2) #\newline)

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