fix list-tail, add some tests

2 files changed, 75 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)))
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..f9c5c26
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,44 @@
+(import r7rs
+        (prefix (hascheme base) ha:)
+        (hascheme eager)
+        (srfi 64))
+
+(cond-expand
+  (chicken-5 (test-runner-current (test-runner-create)))
+  (else))
+
+(ha:define
+ (hascheme-natural-numbers)
+ (ha:let loop ((i 0)) (ha:seq i (ha:cons i (loop (ha:+ i 1))))))
+
+(ha:define (square-of-list list) (ha:map ha:square list))
+
+(test-group "lists"
+  (test-assert
+   "cons is lazy, car"
+   (force (ha:car (ha:cons #t (ha:error "boom")))))
+  (test-assert
+   "cons is lazy, cdr"
+   (guard (x ((equal? (force (error-object-message x)) "boom") #t)
+             (else #f))
+     (force (ha:cdr (ha:cons #f (ha:error "boom"))))
+     #f))
+  (test-equal
+   1000
+   (force (ha:list-ref (hascheme-natural-numbers) 1000)))
+  (let ((flag '()))
+    (test-equal
+     "map is lazy"
+     '(1000)
+     (begin
+       (force (ha:list-ref (ha:map (ha:lambda (x) (set! flag
+                                                        (cons (force x) flag)))
+                                   (hascheme-natural-numbers))
+                           1000))
+       flag)))
+  (test-equal "runs in bounded space"
+              (square 1000)
+              (force (ha:list-ref (square-of-list (hascheme-natural-numbers))
+                                  1000))))
+
+