compiler cleanup - changed if to when where appropriate

boot.sch

@@ -441,6 +441,26 @@ that decompose it according to the structure of var-forms"
 			(else `((eq? ,key-val ',(first c)) . ,(cdr c)))))
 		     clauses)))))
 
+
+(define-syntax (record-case val . clauses)
+  "case-like syntax that decomposes a list by its head"
+  (let ((vale (gensym))
+	(key (gensym))
+	(record (gensym)))
+    `(let* ((,vale ,val)
+	    (,key (first ,vale))
+	    (,record (cdr ,vale)))
+       (case ,key
+	 ,@(map (lambda (clause)
+		  (if (eq? (first clause) 'else)
+		      clause
+		      (list (first clause)
+			    `(apply (lambda ,(second clause)
+				      . ,(cddr clause))
+				    ,record))))
+		clauses)))))
+
+
 (define-syntax (dowhile pred . body)
   "execute body whle pred evaluates true. checks pred after evaluating
 body. always executes at least once"
@@ -474,11 +494,11 @@ body. always executes at least once"
 			     (second binding)))
 		     bindings)
 	  (if ,(first test-and-return)
-	      ,(if (rest test-and-return)
-		   `(begin . ,(rest test-and-return)))
+	      ,(when (rest test-and-return)
+		     `(begin . ,(rest test-and-return)))
 	      (begin
-		,(if body
-		     `(begin . ,body))
+		,(when body
+		       `(begin . ,body))
 		(,loop . ,(map (lambda (binding)
 				 (if (cddr binding)
 				     (third binding)
@@ -640,6 +660,8 @@ list"
       "load file name if it hasn't already been loaded"
       (let ((name (sym-to-name name)))
 	(unless (memq name required)
+		(display "require ")
+		(display name) (newline)
 		(push! name required)
 		(load name))))
 
@@ -850,7 +872,8 @@ it's found. return not-found otherwised"
 (define (sort-list pred lst . equal)
   "arrange a list such that applying pred to any sequential pairs
 returns true"
-  (let ((equal (if (null? equal) equal?
+  (let ((equal (if (null? equal)
+		   equal?
 		   (car equal))))
     (letrec ((pivot (lambda (l)
 		      (cond ((null? l) 'done)
@@ -860,7 +883,8 @@ returns true"
 			     (pivot (cdr l)))
 			    (else (car l)))))
 	     (partition (lambda (piv l p1 p2)
-			  (if (null? l) (list p1 p2)
+			  (if (null? l)
+			      (list p1 p2)
 			      (if (pred (car l) piv)
 				  (partition piv (cdr l)
 					     (cons (car l) p1)
@@ -870,7 +894,8 @@ returns true"
 					     (cons (car l) p2))))))
 	     (quicksort (lambda (l)
 			  (let ((piv (pivot l)))
-			    (if (eq? piv 'done) l
+			    (if (eq? piv 'done)
+				l
 				(let ((parts (partition piv l nil nil)))
 				  (append (quicksort (car parts))
 					  (quicksort (cadr parts)))))))))

clos.sch

@@ -184,8 +184,8 @@
   (write-stream strm "#(")
   (let loop ((idx 0))
     (when (< idx (vector-length vect))
-      (if (> idx 0)
-	  (write-stream strm " "))
+      (when (> idx 0)
+	    (write-stream strm " "))
       (print-object strm (vector-ref vect idx))
       (loop (+ idx 1))))
   (write-stream strm ")"))

clos/clos.sch

@@ -589,8 +589,8 @@
 
 (define-syntax (define-generic name . documentation)
   "syntax for declaring new generic functions"
-  (if documentation
-      (add-documentation name (car documentation)))
+  (when documentation
+	(add-documentation name (car documentation)))
   `(define ,name (make-generic)))
 
 
@@ -801,7 +801,9 @@
   (slot-set! class
 	     'direct-slots
 	     (map (lambda (s)
-		    (if (pair? s) s (list s)))
+		    (if (pair? s) 
+			s
+			(list s)))
 		  (getl initargs 'direct-slots  '())))
   (slot-set! class
 	     'class-name
@@ -921,7 +923,9 @@
     'class-name    '<primitive-class>))
 
 (define (make-primitive-class class name)
-  (make (if (null? class) <primitive-class> class)
+  (make (if (null? class)
+	    <primitive-class>
+	    class)
     'direct-supers (list <top>)
     'class-name name))
 

clos/support.sch

@@ -71,7 +71,9 @@
 
 (define position-of
     (lambda (x lst)
-      (if (eq? x (car lst)) 0 (+ 1 (position-of x (cdr lst))))))
+      (if (eq? x (car lst))
+	  0
+	  (+ 1 (position-of x (cdr lst))))))
 
 (define map-append
     (lambda (proc . lists)
@@ -116,15 +118,6 @@
 	    ((test? (car lst)) (cons (car lst) (collect-if test? (cdr lst))))
 	    (else (collect-if test? (cdr lst))))))
 
-;(define remove-unless
-;    (lambda (test list)
-;      (if (null? list)
-;	  ()
-;	  (let ((rest (remove-unless test (cdr list))))
-;	    (if (test (car list))
-;		(cons (car list) rest)
-;		rest)))))
-
 (define remove-duplicates
     (lambda (lst)
       (let loop ((result-so-far '())

compiler.sch

@@ -70,32 +70,34 @@ about its value and optionally with more forms following"
   (cond
    ((symbol? x) (comp-var x env val? more?))
    ((atom? x) (comp-const x val? more?))
-   (else (case (first x)
-	   (if-compiling (%arg-count x 2 2)
-			 (comp (second x) env val? more?))
-	   (quote (%arg-count x 1 1)
-		  (comp-const (second x) val? more?))
-	   (begin (comp-begin (rest x) env val? more?))
-	   (set! (%arg-count x 2 2)
-		 (seq (comp (third x) env #t #t)
-		      (gen-set (second x) env)
-		      (when (not val?) (gen 'pop))
-		      (unless more? (gen 'return))))
-	   (if (%arg-count x 2 3)
-	       (comp-if (second x) (third x) (fourth x)
-			env val? more?))
-	   (lambda (when val?
-			 (let ((f (comp-lambda (second x)
-					       (rest (rest x)) env)))
-			   (seq (gen 'fn f)
-				(unless more? (gen 'return))))))
-
-	   ;; generate an invocation
-	   (else
-	    (if (comp-macro? (first x))
-		(comp (comp-macroexpand0 x) env val? more?)
-		(comp-funcall (first x) (rest x)
-			      env val? more?)))))))
+   (else
+    (record-case x
+      (if-compiling (then else)
+        (comp then env val? more?))
+      (quote (obj)
+        (comp-const obj val? more?))
+      (begin exps
+        (comp-begin exps env val? more?))
+      (set! (sym val)
+        (seq (comp val env #t #t)
+	     (gen-set sym env)
+	     (when (not val?) (gen 'pop))
+	     (unless more? (gen 'return))))
+      (if (test then . else)
+	  (let ((else (car-else else nil)))
+	    (comp-if test then else env val? more?)))
+      (lambda (args . body)
+	(when val?
+	  (let ((f (comp-lambda args body env)))
+	    (seq (gen 'fn f)
+		 (unless more? (gen 'return))))))
+
+      ;; generate an invocation
+      (else
+       (if (comp-macro? (first x))
+	   (comp (comp-macroexpand0 x) env val? more?)
+	   (comp-funcall (first x) (rest x)
+			 env val? more?)))))))
 
 (define (%<=2 a b)
   (or (%fixnum-less-than a b) (%fixnum-equal a b)))

random.sch

@@ -34,8 +34,8 @@
                        (if (bound? '*random-state*)
                            (generate *random-state*)
                            0)
-                       (if (file-exists? "/dev/urandom")
-                           (random:urandom))
+                       (when (file-exists? "/dev/urandom")
+			     (random:urandom))
 		       (random:collapse-string (date-string)))))
 
 (define-class <random-state> ()
@@ -64,8 +64,8 @@
   "Generate a random number.")
 
 (define-method (generate (rng <mersenne>))
-  (if (= 0 (slot-ref rng 'index))
-      (regenerate rng))
+  (when (= 0 (slot-ref rng 'index))
+	(regenerate rng))
   (let ((y (vector-ref (slot-ref rng 'mt) (slot-ref rng 'index))))
     (set! y (logxor y (ash y -11)))
     (set! y (logxor y (logand (ash 1318464320 1) (ash y 7))))
@@ -98,9 +98,9 @@
 		 (logand *mask-31* (vector-ref mt j)))))
       (vector-set! mt i (logxor (vector-ref mt (mod (+ i 397) 624))
 				(ash y -1)))
-      (if (= 1 (abs (mod y 2)))
-	  (vector-set! mt i (logxor (vector-ref mt i)
-                                    (logor 1 (ash 1283741807 1))))))))
+      (when (= 1 (abs (mod y 2)))
+	    (vector-set! mt i (logxor (vector-ref mt i)
+				      (logor 1 (ash 1283741807 1))))))))
 
 ;; Middle-square algorithm -- don't use this seriously
 

read.sch

@@ -197,8 +197,8 @@
 
 (define (read:list stream char)
   "Read a list from the given stream, assuming opening char is gone."
-  (if (eof-object? (read:flush-whitespace stream))
-      (throw-error "unexpected eof" "eof"))
+  (when (eof-object? (read:flush-whitespace stream))
+	(throw-error "unexpected eof" "eof"))
   (let ((ch (read-stream-char-safe stream)))
     (cond
      ((eq? ch char) '())
@@ -254,8 +254,8 @@
      ((integer-string-list? lst *digits*) (string-list->integer lst 10))
      ((real-string-list? lst)             (string-list->real lst))
      (#t (let ((sym (string->symbol str)))
-	   (if (eq? (string-ref str 0) #\:)
-	       (set-global-unquoted! sym sym))
+	   (when (eq? (string-ref str 0) #\:)
+		 (set-global-unquoted! sym sym))
 	   sym)))))
 
 ;; Take over for old reader

string.sch

@@ -16,10 +16,10 @@
   (let* ((strlen (string-length str))
 	 (end (car-else end strlen))
 	 (len (- end start)))
-    (if (or (> len strlen) (> end strlen) (> start strlen))
-	(throw-error "out of string bounds" str start end))
-    (if (> start end)
-	(throw-error "invalid substring" start end))
+    (when (or (> len strlen) (> end strlen) (> start strlen))
+	  (throw-error "out of string bounds" str start end))
+    (when (> start end)
+	  (throw-error "invalid substring" start end))
     (let ((substr (make-string len #\.)))
       (dotimes (i len)
         (string-set! substr i (string-ref str (+ i start))))