make conditionals procedures

2 files changed, 68 insertions, 78 deletions

diff --git a/lib/hascheme/base.scm b/lib/hascheme/base.scm
index 87e8d10..12bcf76 100644
--- a/lib/hascheme/base.scm
+++ b/lib/hascheme/base.scm
@@ -7,36 +7,41 @@
      (letrec ((name (lambda (formal ...) body ...)))
        (name expr ...)))))
 
-(define-syntax if
-  (syntax-rules ()
-    ((if e1 rest ...)
-     (r7rs:if (force e1) rest ...))))
-
-(define-syntax cond
-  (syntax-rules (else =>)
-    ((_ (else rest ...))
-     (let () rest ...))
-    ((_ (expr => proc) rest ...)
-     (let ((tmp expr))
-       (if expr
-           (proc expr)
-           (cond rest ...))))
-    ((_ (expr) rest ...)
-     (let ((tmp expr))
-       (if expr
-           expr
-           (cond rest ...))))
-    ((_ (expr body ...) rest ...)
-     (if expr (let () body ...)
-         (cond rest ...)))))
-
-(define-syntax and
-  (syntax-rules () ((and x ...) (r7rs:and (force x) ...))))
-(define-syntax or
-  (syntax-rules () ((or x ...) (r7rs:or (force x) ...))))
-
-(define (apply proc . arguments)
-  (r7rs:apply (force proc) arguments))
+(define if
+  (case-lambda
+    ((x y) (r7rs:if (force x) y #f))
+    ((x y z) (r7rs:if (force x) y z))))
+
+(define seq
+  (case-lambda
+    ((x) x)
+    ((x . y) (force x) (apply seq y))))
+
+(define (! x) (seq x x))
+
+(define cond*
+  (case-lambda
+    (() #f)
+    ((x) x)
+    ((x y) (if x y))
+    ((x y . rest) (if x y (apply cond* rest)))))
+
+(define and
+  (case-lambda
+    (() #t)
+    ((x) x)
+    ((x . y) (if x (apply and y) #f))))
+
+(define or
+  (case-lambda
+    (() #f)
+    ((x) x)
+    ((x . y) (if x x (apply or y)))))
+
+(define (apply proc . arguments) (r7rs:apply r7rs:apply (force proc) arguments))
+
+(define error
+  (r7rs:lambda formals (delay (r7rs:apply error formals))))
 
 ;;; Equivalence procedures
 
@@ -78,13 +83,11 @@
   (list r7rs:list))
 
 (define (list-traverse x path)
-  (cond
-    ((null? path) x)
-    ((eq? (car path) 'a)
-     (list-traverse (car x) (cdr path)))
-    ((eq? (cdr path) 'd)
-     (list-traverse (cdr x) (cdr path)))
-    (else (error "invalid path" x path))))
+  (cond*
+   (null? path) x
+   (eq? (car path) 'a) (list-traverse (car x) (cdr path))
+   (eq? (cdr path) 'd) (list-traverse (cdr x) (cdr path))
+   #t (error "invalid path" x path)))
 
 (define (caar x) (list-traverse x '(a a)))
 (define (cadr x) (list-traverse x '(d a)))
@@ -92,10 +95,10 @@
 (define (cddr x) (list-traverse x '(d d)))
 
 (define (list? x)
-  (cond
-    ((null? x) #t)
-    ((pair? x) (list? (cdr x)))
-    (else #f)))
+  (cond*
+   (null? x) #t
+   (pair? x) (list? (cdr x))
+   #t #f))
 
 (define make-list
   (case-lambda
@@ -115,10 +118,10 @@
 (define (length list)
   (let loop ((list list)
              (i 0))
-    (cond
-      ((pair? list) (loop (cdr list) (+ i 1)))
-      ((null? list) i)
-      (else (error "not a list" list)))))
+    (cond*
+     (pair? list) (loop (cdr list) (+ i 1))
+     (null? list) i
+     #t (error "not a list" list))))
 
 (define append
   (case-lambda
@@ -126,10 +129,10 @@
     ((x) x)
     ((x . y)
      (let loop ((x x))
-       (cond
-         ((pair? x) (cons (car x) (loop (cdr x))))
-         ((null? x) (apply append y))
-         (else (error "invalid value" x)))))))
+       (cond*
+        (pair? x) (cons (car x) (loop (cdr x)))
+        (null? x) (apply append y)
+        #t (error "invalid value" x))))))
 
 (define (reverse x)
   (let loop ((x x) (a '()))
@@ -138,10 +141,11 @@
         (loop (cdr x) (cons (car x) a)))))
 
 (define (list-tail list n)
-  (cond
-    ((negative? n) (error "invalid n" list n))
-    ((zero? n) list)
-    (else (list-tail (force (cdr list)) (- n 1)))))
+  (cond*
+   (negative? n) (error "invalid n" list n)
+   (zero? n) list
+   #t (seq (cdr list)
+           (list-tail (cdr list) (- n 1)))))
 
 (define (list-ref list n)
   (car (list-tail list n)))
@@ -151,10 +155,10 @@
     ((obj list) (member obj list equal?))
     ((obj list equal?)
      (let loop ((list list))
-       (cond
-         ((null? list) #f)
-         ((equal? (car list) obj) list)
-         (else (loop (cdr list))))))))
+       (cond*
+        (null? list) #f
+        (equal? (car list) obj) list
+        #t (loop (cdr list)))))))
 
 (define (memq obj list) (member obj list eq?))
 (define (memv obj list) (member obj list eqv?))
@@ -164,10 +168,10 @@
     ((obj list) (assoc obj list equal?))
     ((obj list equal?)
      (let loop ((list list))
-       (cond
-         ((null? list) #f)
-         ((equal? (caar list) obj) (car list))
-         (else (loop (cdr list))))))))
+       (cond*
+        (null? list) #f
+        (equal? (caar list) obj) (car list)
+        #t (loop (cdr list)))))))
 
 (define (assq obj list) (assoc obj list eq?))
 (define (assv obj list) (assoc obj list eqv?))
@@ -184,14 +188,3 @@
       '()
       (cons (f (car list)) (map1 f (cdr list)))))
 
-(define (find-nth-square n)
-  (list-ref (map1 (lambda (x) (* x x))
-                  (letrec ((next (lambda (x) (cons x (next (+ x 1))))))
-                    (next 0)))
-            n))
-
-(define natural-numbers
-  (letrec ((next (lambda (x) (cons x (next (+ x 1))))))
-    (next 0)))
-(define squares (map1 (lambda (x) (* x x)) natural-numbers))
-
diff --git a/lib/hascheme/base.sld b/lib/hascheme/base.sld
index 42513b9..a2543e1 100644
--- a/lib/hascheme/base.sld
+++ b/lib/hascheme/base.sld
@@ -5,13 +5,13 @@
                           let* letrec letrec*)
                   r7rs:)
           (only (scheme base) define-syntax syntax-rules
-                let* letrec letrec* quote error)
+                let* letrec letrec* quote)
           (scheme lazy)
           (rename (hascheme internal)
                   (hs:lambda lambda)
                   (hs:define define))
           (hascheme case-lambda))
-  (export lambda define let if cond or and
+  (export ! lambda define let if cond* or and error seq
           eq? eqv? equal?
           + - * negative? positive? zero?
           boolean? not boolean=?
@@ -23,8 +23,5 @@
           member memq memv
           assoc assq assv
           symbol? symbol->string string->symbol symbol=?
-          map1
-          natural-numbers
-          squares
-          find-nth-square)
+          map1)
   (include "base.scm"))
\ No newline at end of file