hascheme init -- figured out some space leak issues

4 files changed, 291 insertions, 0 deletions

diff --git a/lib/hascheme/base.scm b/lib/hascheme/base.scm
new file mode 100644
index 0000000..87e8d10
--- /dev/null
+++ b/lib/hascheme/base.scm
@@ -0,0 +1,197 @@
+(define-syntax let
+  ;; Named let needs to be modified to use lazy lambda
+  (syntax-rules ()
+    ((let ((formal expr) ...) body ...)
+     (r7rs:let ((formal expr) ...) body ...))
+    ((let name ((formal expr) ...) body ...)
+     (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))
+
+;;; Equivalence procedures
+
+(define-wrappers-from-strict
+    ((eq? x y) r7rs:eq?)
+  ((eqv? x y) r7rs:eqv?)
+  ((equal? x y) r7rs:equal?))
+
+;;; Numbers
+
+(define-wrappers-from-strict
+    (+ r7rs:+)
+  (- r7rs:-)
+  (* r7rs:*)
+  ((negative? x) r7rs:negative?)
+  ((positive? x) r7rs:positive?)
+  ((zero? x) r7rs:zero?))
+
+(define-binary-wrapper (= r7rs:=))
+
+;;; Booleans
+
+(define-wrappers-from-strict
+    ((boolean? x) r7rs:boolean?)
+  ((not x) r7rs:not))
+
+(define-binary-wrapper (boolean=? r7rs:boolean=?))
+
+;;; Lists and pairs
+
+(define-wrappers-from-strict
+    ((car x) r7rs:car)
+  ((cdr x) r7rs:cdr)
+  ((null? x) r7rs:null?)
+  ((pair? x) r7rs:pair?))
+
+(define-wrappers-for-lazy
+    ((cons x y) r7rs:cons)
+  (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))))
+
+(define (caar x) (list-traverse x '(a a)))
+(define (cadr x) (list-traverse x '(d a)))
+(define (cdar x) (list-traverse x '(a d)))
+(define (cddr x) (list-traverse x '(d d)))
+
+(define (list? x)
+  (cond
+    ((null? x) #t)
+    ((pair? x) (list? (cdr x)))
+    (else #f)))
+
+(define make-list
+  (case-lambda
+    ((k) (make-list k #f))
+    ((k fill)
+     (let loop ((k k))
+       (if (zero? k)
+           '()
+           (cons fill (loop (- k 1))))))))
+
+(define (list-tabulate n proc)
+  (let loop ((i 0))
+    (if (= i n)
+        '()
+        (cons (proc i) (loop (+ i 1))))))
+
+(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)))))
+
+(define append
+  (case-lambda
+    (() '())
+    ((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)))))))
+
+(define (reverse x)
+  (let loop ((x x) (a '()))
+    (if (null? x)
+        a
+        (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)))))
+
+(define (list-ref list n)
+  (car (list-tail list n)))
+
+(define member
+  (case-lambda
+    ((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))))))))
+
+(define (memq obj list) (member obj list eq?))
+(define (memv obj list) (member obj list eqv?))
+
+(define assoc
+  (case-lambda
+    ((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))))))))
+
+(define (assq obj list) (assoc obj list eq?))
+(define (assv obj list) (assoc obj list eqv?))
+
+;;; Symbols
+
+(define-wrappers-from-strict ((symbol? x) r7rs:symbol?)
+  ((symbol->string x) r7rs:symbol->string)
+  ((string->symbol x) r7rs:string->symbol))
+(define-binary-wrapper (symbol=? r7rs:symbol=?))
+
+(define (map1 f list)
+  (if (null? list)
+      '()
+      (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
new file mode 100644
index 0000000..42513b9
--- /dev/null
+++ b/lib/hascheme/base.sld
@@ -0,0 +1,30 @@
+(define-library (hascheme base)
+  (import (prefix (except (scheme base)
+                          quote quasiquote
+                          define-syntax syntax-rules
+                          let* letrec letrec*)
+                  r7rs:)
+          (only (scheme base) define-syntax syntax-rules
+                let* letrec letrec* quote error)
+          (scheme lazy)
+          (rename (hascheme internal)
+                  (hs:lambda lambda)
+                  (hs:define define))
+          (hascheme case-lambda))
+  (export lambda define let if cond or and
+          eq? eqv? equal?
+          + - * negative? positive? zero?
+          boolean? not boolean=?
+          car cdr null? pair? list-traverse
+          list-tabulate
+          caar cadr cdar cddr
+          list? make-list length append reverse
+          list-tail list-ref
+          member memq memv
+          assoc assq assv
+          symbol? symbol->string string->symbol symbol=?
+          map1
+          natural-numbers
+          squares
+          find-nth-square)
+  (include "base.scm"))
\ No newline at end of file
diff --git a/lib/hascheme/case-lambda.sld b/lib/hascheme/case-lambda.sld
new file mode 100644
index 0000000..5278f8d
--- /dev/null
+++ b/lib/hascheme/case-lambda.sld
@@ -0,0 +1,9 @@
+(define-library (hascheme case-lambda)
+  (import (scheme base) (hascheme internal)
+          (prefix (scheme case-lambda) r7rs:))
+  (export case-lambda)
+  (begin
+    (define-syntax case-lambda
+      (syntax-rules ()
+        ((_ (clause body ...) ...)
+         (r7rs:case-lambda (clause (delay-force (let () body ...))) ...))))))
\ No newline at end of file
diff --git a/lib/hascheme/internal.sld b/lib/hascheme/internal.sld
new file mode 100644
index 0000000..fe0eb26
--- /dev/null
+++ b/lib/hascheme/internal.sld
@@ -0,0 +1,55 @@
+(define-library (hascheme internal)
+  (import (scheme base) (scheme lazy) (scheme case-lambda))
+  (export hs:lambda hs:define
+          define-wrappers-from-strict
+          define-wrappers-for-lazy
+          define-binary-wrapper)
+  (begin
+    (define-syntax define-wrappers-from-strict
+      (syntax-rules ()
+        ((_ ((wrapper formals ...) name) rest ...)
+         (begin
+           (hs:define (wrapper formals ...)
+                      (name (force formals) ...))
+           (define-wrappers-from-strict rest ...)))
+        ((_ (wrapper name) rest ...)
+         (begin
+           (hs:define wrapper
+                      (lambda formal (apply name (map force formal))))
+           (define-wrappers-from-strict rest ...)))
+        ((_) (begin))))
+    (define-syntax define-wrappers-for-lazy
+      (syntax-rules ()
+        ((_ ((wrapper formals ...) name) rest ...)
+         (begin
+           (hs:define (wrapper formals ...)
+                      (name formals ...))
+           (define-wrappers-for-lazy rest ...)))
+        ((_ (wrapper name) rest ...)
+         (begin (define wrapper (hs:lambda formal (apply name formal)))
+                (define-wrappers-for-lazy rest ...)))
+        ((_) (begin))))
+    (define-syntax define-binary-wrapper
+      (syntax-rules ()
+        ((_ (wrapper name) rest ...)
+         (begin
+           (define wrapper
+             (case-lambda
+               ((x y) (delay-force (name (force x) (force y))))
+               ((x y . z)
+                (delay-force
+                 (if (name (force x) (force y))
+                     (apply wrapper y z)
+                     #f)))))
+           (define-binary-wrapper rest ...)))
+        ((_) (begin))))
+    (define-syntax hs:lambda
+      (syntax-rules ()
+        ((_ formal body ...)
+         (lambda formal (delay-force (let () body ...))))))
+    (define-syntax hs:define
+      (syntax-rules ()
+        ((_ (name . formals) body ...)
+         (define name (hs:lambda formals body ...)))
+        ((_ name body) (define name body))))))
+