make conditionals procedures

3 files changed, 137 insertions, 83 deletions

diff --git a/README.md b/README.md
index dde64f9..58e0273 100644
--- a/README.md
+++ b/README.md
@@ -1,14 +1,23 @@
 # HaScheme -- Call By Name Scheme
 
+> Scheme demonstrates that a very small number of rules for forming
+> expressions, with no restrictions on how they are composed, suffice to
+> form a practical and efficient programming language that is flexible
+> enough to support most of the major programming paradigms in use today.
+>
+> -- Revisedⁿ Reports on the Algorithmic Language Scheme (n ≥ 3, 1986–)
+
 This is a library that exports interfaces similar to the R7RS, except
 everything is call-by-need and not call-by-value: there is no need to
-explictly use `delay` or `delay-force`. Procedures can be written in
-ways that look almost identical to regular Scheme. The procedures
-return promises which can be forced by non-lazy code. Hence lazy and
-non-lazy code can co-exist.
+explictly use `delay` or `delay-force` (in most scenarios). Procedures
+can be written in ways that look almost identical to regular Scheme. The
+procedures return promises which can be forced by non-lazy code. Hence
+lazy and non-lazy code can co-exist.
 
 *Every* procedure in HaScheme is lazy. Values are forced in conditionals,
-or explicitly using `!`.
+or explicitly using `seq`. This allows for the call-by-value semantics
+of Scheme to be turned into call-by-need semantics without any syntactic
+cruft.
 
 ## Fun (or Pain) with Laziness
 
@@ -45,3 +54,58 @@ Instead of writing `force`, the operator `!` is used:
 
 where `(! x)` is defined to just be `x` in Scheme. Now the code block
 above operates the same in Scheme and HaScheme.
+
+Ok, now we have fixed our space leak issues. Right? Let's try another
+infinite list trick: a list of all natural numbers.
+
+    (define naturals (list-tabulate +inf.0 (lambda (x) x)))
+    (! (list-tail naturals 1000000000))
+
+This also leaks! This is because the promises are making new cons cells,
+and storing them in `naturals`. We need to organize things to make sure
+the program can clean up.
+
+    (! (list-tail (list-tabulate +inf.0 (lambda (x) x)) 1000000000))
+
+This will run in bounded space.
+
+## Call-by-Need and Conditionals
+
+Since call-by-need will only execute a function when needed, conditional
+forms like `if` can be implemented as functions and not syntax. In fact,
+HaScheme implements `if`, `and`, `or`, and the `cond`-like `cond*` as
+functions, meaning one can pass them around as values.
+
+For instance:
+
+    (define (map f l)
+      (cond
+        ((null? l) '())
+        ((pair? l) (cons (f (car l)) (cdr l)))
+        (else (error "not a list" l))))
+
+implemented with `cond*` is
+
+    (define (map f l)
+      (cond*
+       (null? l) '()
+       (pair? l) (cons f (car l) (cdr l))
+       #t (error "not a list" l)))
+
+Neat, right? Well, if we go to `list-tail` we have a problem:
+
+    (define (list-tail list n)
+      (if (zero? n)
+          list
+          (list-tail (! (cdr list)) (- n 1))))
+
+Since `if` is now a function, Scheme (our call-by-value host language)
+will attempt to reduce `(! (cdr list))` every time, even when we don't
+need to. We could go back to syntactic if, or we could add some wrapper
+to the procedure. The easiest thing to do is `delay-force`. I
+
+    (define (list-tail list n)
+      (if* (zero? n)
+           list
+           (seq (cdr list)
+                (list-tail (cdr list) (- n 1)))))
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