fix list-tail, add some tests

1 files changed, 31 insertions, 26 deletions

diff --git a/lib/hascheme/base.scm b/lib/hascheme/base.scm
index c00ff49..d96547d 100644
--- a/lib/hascheme/base.scm
+++ b/lib/hascheme/base.scm
@@ -24,35 +24,38 @@
 
 (define-syntax if
   (syntax-rules ()
-    ((if x y ...) (r7rs:if (! x) y ...))))
+    ((if x y ...) (delay-force (r7rs:if (! x) y ...)))))
 
 (define-syntax cond
   (syntax-rules (else =>)
-    ((cond (else result1 result2 ...))
+    ((cond "iter" (else result1 result2 ...))
      (let () result1 result2 ...))
-    ((cond (test => result))
+    ((cond "iter" (test => result))
      (let ((temp test))
        (if temp (result temp))))
-    ((cond (test => result) clause1 clause2 ...)
+    ((cond "iter" (test => result) clause1 clause2 ...)
      (let ((temp test))
        (if temp
            (result temp)
-           (cond clause1 clause2 ...))))
-    ((cond (test)) test)
-    ((cond (test) clause1 clause2 ...)
+           (cond "iter" clause1 clause2 ...))))
+    ((cond "iter" (test)) test)
+    ((cond "iter" (test) clause1 clause2 ...)
      (let ((temp test))
        (if temp
            temp
-           (cond clause1 clause2 ...))))
-    ((cond (test result1 result2 ...))
+           (cond "iter" clause1 clause2 ...))))
+    ((cond "iter" (test result1 result2 ...))
      (if test (let () result1 result2 ...)))
-    ((cond (test result1 result2 ...)
+    ((cond "iter" (test result1 result2 ...)
            clause1 clause2 ...)
      (if test
          (let () result1 result2 ...)
-         (cond clause1 clause2 ...)))))
+         (cond "iter" clause1 clause2 ...)))
+    ((cond clauses ...)
+     (delay-force (cond "iter" clauses ...)))))
 
 (define-syntax case
+  ;; TODO: fix with delay-force
   (syntax-rules (else =>)
     ((case (key ...) clauses ...)
      (let ((atom-key (key ...)))
@@ -83,19 +86,19 @@
 
 (define-syntax and
   (syntax-rules ()
-    ((and x ...) (r7rs:and (! x) ...))))
+    ((and x ...) (delay-force (r7rs:and (! x) ...)))))
 
 (define-syntax or
   (syntax-rules ()
-    ((or x ...) (r7rs:or (! x) ...))))
+    ((or x ...) (delay-force (r7rs:or (! x) ...)))))
 
 (define-syntax when
   (syntax-rules ()
-    ((when pred x ...) (r7rs:when (! pred) x ...))))
+    ((when pred x ...) (delay-force (r7rs:when (! pred) x ...)))))
 
 (define-syntax unless
   (syntax-rules ()
-    ((unless pred x ...) (r7rs:unless (! pred) x ...))))
+    ((unless pred x ...) (delay-force (r7rs:unless (! pred) x ...)))))
 
 (define-syntax define-record-type
   (syntax-rules ()
@@ -122,8 +125,8 @@
 
 (define (apply proc . arguments) (r7rs:apply r7rs:apply (! proc) arguments))
 
-(define error
-  (r7rs:lambda formals (delay (r7rs:apply error formals))))
+(define (error message . irritants)
+  (r7rs:apply r7rs:error message irritants))
 
 (r7rs:define (!list list)
              (let loop ((list (! list))
@@ -289,10 +292,10 @@
     ((pair? x) (list? (cdr x)))
     (else #f)))
 
-(define (ensure-exact-positive-integer n k)
-  (if (not (and (exact-integer? k) (positive? k)))
-      (error "not an exact integer" k)
-      #t))
+(define (ensure-exact-positive-integer k)
+  (unless (or (and (number? k) (= k +inf.0))
+              (and (exact-integer? k) (positive? k)))
+    (error "not a positive integer" k)))
 
 (define make-list
   (case-lambda
@@ -338,11 +341,13 @@
       (else (error "not a pair" x)))))
 
 (define (list-tail list n)
-  (seq (ensure-exact-positive-integer n)
-       (let loop ((list list) (n n))
-         (if (zero? n)
-             list
-             (list-tail (! (cdr list)) (- n 1))))))
+  (unless (and (exact-integer? n) (not (negative? n)))
+    (error "n must be a non-negative exact finite integer" n))
+  (let loop ((list list) (n n))
+    (if (zero? n)
+        list
+        (seq list
+             (loop (cdr list) (- n 1))))))
 
 (define (list-ref list n)
   (car (list-tail list n)))