From: Tim Vaughan <tgvaughan@gmail.com>
Date: Wed, 11 Oct 2017 11:09:55 +0000 (+0200)
Subject: Factored library, implemented make-continuation.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=41b469d050586a05cd43fdd4c78755616af3f7b4;p=scheme.forth.jl.git

Factored library, implemented make-continuation.
---

diff --git a/src/scheme-library-1-essential.scm b/src/scheme-library-1-essential.scm
new file mode 100644
index 0000000..ded8412
--- /dev/null
+++ b/src/scheme-library-1-essential.scm
@@ -0,0 +1,26 @@
+;; MISC ESSENTIAL PROCEDURES
+
+(define list
+  (lambda args args))
+
+(define map
+  (lambda (proc l)
+    (if (null? l)
+        '()
+        (cons (proc (car l)) (map proc (cdr l))))))
+
+(define join-lists
+  (lambda (l1 l2)
+    (if (null? l1)
+      l2
+      (cons (car l1) (join-lists (cdr l1) l2)))))
+
+; Append an arbitrary number of lists together
+(define append
+  (lambda lists
+  (if (null? lists)
+    ()
+    (if (null? (cdr lists))
+      (car lists)
+      (join-lists (car lists) (apply append (cdr lists)))))))
+
diff --git a/src/scheme-library-2-derived-forms.scm b/src/scheme-library-2-derived-forms.scm
new file mode 100644
index 0000000..ba1e182
--- /dev/null
+++ b/src/scheme-library-2-derived-forms.scm
@@ -0,0 +1,144 @@
+;; DERIVED FORMS
+
+;; define
+
+(define-macro (define args . body)
+              (if (pair? args)
+                (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
+                'no-match))
+
+;; not
+
+(define-macro (not x)
+              (list 'if x #f #t))
+
+;; let
+
+(define-macro (let args . body)
+              (join-lists
+                (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
+                (map (lambda (x) (car (cdr x))) args)))
+
+;; quasiquote/unquote (one nesting level only)
+
+((lambda ()
+   (define (qqhelper l)
+     (if (null? l)
+       l
+       (let ((head (car l))
+             (tail (cdr l)))
+
+         (if (pair? head)
+             (if (eq? (car head) 'unquote)
+                 (list 'cons (car (cdr head)) (qqhelper tail))
+                 (if (eq? (car head) 'unquote-splicing)
+                     (list 'join-lists (car (cdr head)) (qqhelper tail))
+                     (list 'cons (list 'quasiquote head) (qqhelper tail))))
+             (if (symbol? head)
+                 (list 'cons (list 'quote head) (qqhelper tail))
+                 (list 'cons head (qqhelper tail)))))))
+
+   (define-macro (quasiquote arg)
+                 (if (not (pair? arg))
+                   (list 'quote arg)
+                   (qqhelper arg)))))
+
+;; begin
+
+(define-macro (begin . sequence)
+              `((lambda () ,@sequence)))
+
+;; caddr etc.
+
+(define-macro (caar l) `(car (car ,l)))
+(define-macro (cadr l) `(car (cdr ,l)))
+(define-macro (cdar l) `(cdr (car ,l)))
+(define-macro (cddr l) `(cdr (cdr ,l)))
+(define-macro (caaar l) `(car (car (car ,l))))
+(define-macro (caadr l) `(car (car (cdr ,l))))
+(define-macro (cadar l) `(car (cdr (car ,l))))
+(define-macro (caddr l) `(car (cdr (cdr ,l))))
+(define-macro (cdaar l) `(cdr (car (car ,l))))
+(define-macro (cdadr l) `(cdr (car (cdr ,l))))
+(define-macro (cddar l) `(cdr (cdr (car ,l))))
+(define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
+(define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
+
+;; let*
+
+(define-macro (let* args . body)
+              (if (null? args)
+                `(let () ,@body)
+                `(let (,(car args))
+                   (let* ,(cdr args) ,@body))))
+
+;; while
+
+(define-macro (while condition . body)
+              (let ((loop (gensym)))
+                `(begin
+                   (define (,loop)
+                     (if ,condition
+                       (begin ,@body (,loop))))
+                   (,loop))))
+
+;; cond
+
+((lambda ()
+   (define (cond-predicate clause) (car clause))
+   (define (cond-actions clause) (cdr clause))
+   (define (cond-else-clause? clause)
+     (eq? (cond-predicate clause) 'else))
+
+   (define (expand-clauses clauses)
+     (if (null? clauses)
+       (none)
+       (let ((first (car clauses))
+             (rest (cdr clauses)))
+         (if (cond-else-clause? first)
+           (if (null? rest)
+             `(begin ,@(cond-actions first))
+             (error "else clause isn't last in cond expression."))
+           `(if ,(cond-predicate first)
+              (begin ,@(cond-actions first))
+              ,(expand-clauses rest))))))
+
+   (define-macro (cond . clauses)
+                 (if (null? clauses)
+                   (error "cond requires at least one clause.")
+                   (expand-clauses clauses)))))
+
+;; and
+
+((lambda ()
+   (define (expand-and-expressions expressions)
+     (let ((first (car expressions))
+           (rest (cdr expressions)))
+       (if (null? rest)
+         first
+         `(if ,first
+            ,(expand-and-expressions rest)
+            #f))))
+
+   (define-macro (and . expressions)
+                 (if (null? expressions)
+                   #t
+                   (expand-and-expressions expressions)))))
+
+;; or
+
+((lambda ()
+   (define (expand-or-expressions expressions)
+     (let ((first (car expressions))
+           (rest (cdr expressions)))
+       (if (null? rest)
+           first
+           `(if ,first
+                #t
+                ,(expand-or-expressions rest)))))
+
+   (define-macro (or . expressions)
+     (if (null? expressions)
+         #f
+         (expand-or-expressions expressions)))))
+
diff --git a/src/scheme-library-3-functional.scm b/src/scheme-library-3-functional.scm
new file mode 100644
index 0000000..0193a4b
--- /dev/null
+++ b/src/scheme-library-3-functional.scm
@@ -0,0 +1,14 @@
+;; FUNCTIONAL PROGRAMMING
+
+(define (fold-left proc init l)
+  (if (null? l)
+    init
+    (fold-left proc (proc init (car l)) (cdr l))))
+
+(define (reduce-left proc init l)
+  (if (null? l)
+    init
+    (if (null? (cdr l))
+      (car l)
+      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
+
diff --git a/src/scheme-library-4-numbers.scm b/src/scheme-library-4-numbers.scm
new file mode 100644
index 0000000..4865e68
--- /dev/null
+++ b/src/scheme-library-4-numbers.scm
@@ -0,0 +1,173 @@
+;; NUMBERS
+
+; Rational primitives
+
+(define (numerator x)
+  (if (ratnum? x)
+    (rat:numerator x)
+    x))
+
+(define (denominator x)
+  (if (ratnum? x)
+    (rat:denominator x)
+    (if (fixnum? x)
+      1
+      1.0)))
+
+(define (rat:+ x y)
+  (make-rational (fix:+ (fix:* (numerator x) (denominator y))
+                        (fix:* (denominator x) (numerator y)))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:- x y)
+  (make-rational (fix:- (fix:* (numerator x) (denominator y))
+                        (fix:* (denominator x) (numerator y)))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:* x y)
+  (make-rational (fix:* (numerator x) (numerator y))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:/ x y)
+  (make-rational (fix:* (numerator x) (denominator y))
+                 (fix:* (denominator x) (numerator y))))
+
+(define (rat:1/ x)
+  (make-rational (denominator x) (numerator x)))
+
+; Type dispatch and promotion
+
+(define (type-dispatch ops x)
+  (if (flonum? x)
+    ((cdr ops) x)
+    ((car ops) x)))
+
+(define (promote-dispatch ops x y)
+  (if (flonum? x)
+    (if (flonum? y)
+      ((cdr ops) x y)
+      ((cdr ops) x (fixnum->flonum y)))
+    (if (flonum? y)
+      ((cdr ops) (fixnum->flonum x) y)
+      ((car ops) x y))))
+
+; Unary ops
+
+(define (neg x)
+  (type-dispatch (cons fix:neg flo:neg) x))
+
+(define (abs x)
+  (type-dispatch (cons fix:abs flo:abs) x))
+
+(define (flo:1+ x) (flo:+ x 1.0))
+(define (flo:1- x) (flo:- x 1.0))
+
+(define (1+ n)
+  (type-dispatch (cons fix:1+ flo:1+) n))
+
+(define (1- n)
+  (type-dispatch (cons fix:1- flo:1-) n))
+
+(define (apply-to-flonum op x)
+  (if (flonum? x) (op x) x))
+
+(define (round x)
+  (apply-to-flonum flo:round x))
+(define (floor x)
+  (apply-to-flonum flo:floor x))
+(define (ceiling x)
+  (apply-to-flonum flo:ceiling x))
+(define (truncate x)
+  (apply-to-flonum flo:truncate x))
+
+; Binary operations
+
+(define (fix:/ x y) ; Non-standard definition while we don't have rationals
+  (if (fix:= 0 (fix:remainder x y))
+    (fix:quotient x y)
+    (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
+
+(define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
+(define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
+(define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
+(define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
+
+(define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
+(define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
+(define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
+(define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
+(define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
+
+(define (null? arg)
+  (eq? arg '()))
+
+(define (+ . args)
+  (fold-left pair+ 0 args))
+
+(define (- first . rest)
+  (if (null? rest)
+    (neg first)
+    (pair- first (apply + rest))))
+
+(define (* . args)
+  (fold-left pair* 1 args))
+
+(define (/ first . rest)
+  (if (null? rest)
+    (pair/ 1 first)
+    (pair/ first (apply * rest))))
+
+(define (quotient n1 n2)
+  (fix:quotient n1 n2))
+
+(define (remainder n1 n2)
+  (fix:remainder n1 n2))
+
+(define modulo remainder)
+
+; Relations
+
+(define (test-relation rel l)
+  (if (null? l)
+    #t
+    (if (null? (cdr l))
+      #t
+      (if (rel (car l) (car (cdr l)))
+        (test-relation rel (cdr l))
+        #f))))
+
+(define (= . args)
+  (test-relation pair= args))
+
+(define (> . args)
+  (test-relation pair> args))
+
+(define (< . args)
+  (test-relation pair< args))
+
+(define (>= . args)
+  (test-relation pair>= args))
+
+(define (<= . args)
+  (test-relation pair<= args))
+
+; Numeric tests 
+
+(define (zero? x) (pair= x 0.0))
+(define (positive x) (pair> x 0.0))
+(define (odd? n) (pair= (remainder n 2) 0))
+(define (odd? n) (not (pair= (remainder n 2) 0)))
+
+
+; Current state of the numerical tower
+(define (complex? x) #f)
+(define (real? x) #t)
+(define (rational? x) #t)
+(define (integer? x) (= x (round x)))
+(define (exact? x) (fixnum? x))
+(define (inexact? x) (flonum? x))
+(define (number? x)
+  (if (fixnum? x) #t
+    (if (flonum? x) #t
+      (if (ratnum? x) #t #f))))
+
diff --git a/src/scheme-library-5-lists.scm b/src/scheme-library-5-lists.scm
new file mode 100644
index 0000000..12bd3c3
--- /dev/null
+++ b/src/scheme-library-5-lists.scm
@@ -0,0 +1,16 @@
+;; LISTS
+
+; Return number of items in list
+(define (length l)
+  (define (iter a count)
+    (if (null? a)
+      count
+      (iter (cdr a) (fix:+ count 1))))
+  (iter l 0))
+
+; Reverse the contents of a list
+(define (reverse l)
+  (if (null? l)
+    ()
+    (append (reverse (cdr l)) (list (car l)))))
+
diff --git a/src/scheme-library-6-testing.scm b/src/scheme-library-6-testing.scm
new file mode 100644
index 0000000..196e238
--- /dev/null
+++ b/src/scheme-library-6-testing.scm
@@ -0,0 +1,27 @@
+;; TESTING
+
+; Test for the while macro.
+(define (count)
+  (define counter 10)
+  (while (> counter 0)
+         (display counter) (newline)
+         (set! counter (- counter 1))))
+
+; Basic iterative summation.  Run this on large numbers to
+; test garbage collection and tail-call optimization.
+(define (sum n)
+
+  (define (sum-iter total count maxcount)
+    (if (fix:> count maxcount)
+      total
+      (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
+  
+  (sum-iter 0 1 n))
+
+; Recursive summation. Use this to compare with tail call
+; optimized iterative algorithm.
+(define (sum-recurse n)
+  (if (fix:= n 0)
+    0
+    (fix:+ n (sum-recurse (fix:- n 1)))))
+
diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index 8740e15..e462a00 100644
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -2,410 +2,12 @@
 ;; Standard Library Procedures and Macros ;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; MISC ESSENTIAL PROCEDURES
-
-(define list
-  (lambda args args))
-
-(define map
-  (lambda (proc l)
-    (if (null? l)
-        '()
-        (cons (proc (car l)) (map proc (cdr l))))))
-
-(define join-lists
-  (lambda (l1 l2)
-    (if (null? l1)
-      l2
-      (cons (car l1) (join-lists (cdr l1) l2)))))
-
-; Append an arbitrary number of lists together
-(define append
-  (lambda lists
-  (if (null? lists)
-    ()
-    (if (null? (cdr lists))
-      (car lists)
-      (join-lists (car lists) (apply append (cdr lists)))))))
-
-
-;; DERIVED FORMS
-
-;; define
-
-(define-macro (define args . body)
-              (if (pair? args)
-                (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
-                'no-match))
-
-;; not
-
-(define-macro (not x)
-              (list 'if x #f #t))
-
-;; let
-
-(define-macro (let args . body)
-              (join-lists
-                (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
-                (map (lambda (x) (car (cdr x))) args)))
-
-;; quasiquote/unquote (one nesting level only)
-
-((lambda ()
-   (define (qqhelper l)
-     (if (null? l)
-       l
-       (let ((head (car l))
-             (tail (cdr l)))
-
-         (if (pair? head)
-             (if (eq? (car head) 'unquote)
-                 (list 'cons (car (cdr head)) (qqhelper tail))
-                 (if (eq? (car head) 'unquote-splicing)
-                     (list 'join-lists (car (cdr head)) (qqhelper tail))
-                     (list 'cons (list 'quasiquote head) (qqhelper tail))))
-             (if (symbol? head)
-                 (list 'cons (list 'quote head) (qqhelper tail))
-                 (list 'cons head (qqhelper tail)))))))
-
-   (define-macro (quasiquote arg)
-                 (if (not (pair? arg))
-                   (list 'quote arg)
-                   (qqhelper arg)))))
-
-;; begin
-
-(define-macro (begin . sequence)
-              `((lambda () ,@sequence)))
-
-;; caddr etc.
-
-(define-macro (caar l) `(car (car ,l)))
-(define-macro (cadr l) `(car (cdr ,l)))
-(define-macro (cdar l) `(cdr (car ,l)))
-(define-macro (cddr l) `(cdr (cdr ,l)))
-(define-macro (caaar l) `(car (car (car ,l))))
-(define-macro (caadr l) `(car (car (cdr ,l))))
-(define-macro (cadar l) `(car (cdr (car ,l))))
-(define-macro (caddr l) `(car (cdr (cdr ,l))))
-(define-macro (cdaar l) `(cdr (car (car ,l))))
-(define-macro (cdadr l) `(cdr (car (cdr ,l))))
-(define-macro (cddar l) `(cdr (cdr (car ,l))))
-(define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
-(define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
-
-;; let*
-
-(define-macro (let* args . body)
-              (if (null? args)
-                `(let () ,@body)
-                `(let (,(car args))
-                   (let* ,(cdr args) ,@body))))
-
-;; while
-
-(define-macro (while condition . body)
-              (let ((loop (gensym)))
-                `(begin
-                   (define (,loop)
-                     (if ,condition
-                       (begin ,@body (,loop))))
-                   (,loop))))
-
-;; cond
-
-((lambda ()
-   (define (cond-predicate clause) (car clause))
-   (define (cond-actions clause) (cdr clause))
-   (define (cond-else-clause? clause)
-     (eq? (cond-predicate clause) 'else))
-
-   (define (expand-clauses clauses)
-     (if (null? clauses)
-       (none)
-       (let ((first (car clauses))
-             (rest (cdr clauses)))
-         (if (cond-else-clause? first)
-           (if (null? rest)
-             `(begin ,@(cond-actions first))
-             (error "else clause isn't last in cond expression."))
-           `(if ,(cond-predicate first)
-              (begin ,@(cond-actions first))
-              ,(expand-clauses rest))))))
-
-   (define-macro (cond . clauses)
-                 (if (null? clauses)
-                   (error "cond requires at least one clause.")
-                   (expand-clauses clauses)))))
-
-;; and
-
-((lambda ()
-   (define (expand-and-expressions expressions)
-     (let ((first (car expressions))
-           (rest (cdr expressions)))
-       (if (null? rest)
-         first
-         `(if ,first
-            ,(expand-and-expressions rest)
-            #f))))
-
-   (define-macro (and . expressions)
-                 (if (null? expressions)
-                   #t
-                   (expand-and-expressions expressions)))))
-
-;; or
-
-((lambda ()
-   (define (expand-or-expressions expressions)
-     (let ((first (car expressions))
-           (rest (cdr expressions)))
-       (if (null? rest)
-           first
-           `(if ,first
-                #t
-                ,(expand-or-expressions rest)))))
-
-   (define-macro (or . expressions)
-     (if (null? expressions)
-         #f
-         (expand-or-expressions expressions)))))
-
-;; FUNCTIONAL PROGRAMMING
-
-(define (fold-left proc init l)
-  (if (null? l)
-    init
-    (fold-left proc (proc init (car l)) (cdr l))))
-
-(define (reduce-left proc init l)
-  (if (null? l)
-    init
-    (if (null? (cdr l))
-      (car l)
-      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
-
-
-;; NUMBERS
-
-; Rational primitives
-
-(define (numerator x)
-  (if (ratnum? x)
-    (rat:numerator x)
-    x))
-
-(define (denominator x)
-  (if (ratnum? x)
-    (rat:denominator x)
-    (if (fixnum? x)
-      1
-      1.0)))
-
-(define (rat:+ x y)
-  (make-rational (fix:+ (fix:* (numerator x) (denominator y))
-                        (fix:* (denominator x) (numerator y)))
-                 (fix:* (denominator x) (denominator y))))
-
-(define (rat:- x y)
-  (make-rational (fix:- (fix:* (numerator x) (denominator y))
-                        (fix:* (denominator x) (numerator y)))
-                 (fix:* (denominator x) (denominator y))))
-
-(define (rat:* x y)
-  (make-rational (fix:* (numerator x) (numerator y))
-                 (fix:* (denominator x) (denominator y))))
-
-(define (rat:/ x y)
-  (make-rational (fix:* (numerator x) (denominator y))
-                 (fix:* (denominator x) (numerator y))))
-
-(define (rat:1/ x)
-  (make-rational (denominator x) (numerator x)))
-
-; Type dispatch and promotion
-
-(define (type-dispatch ops x)
-  (if (flonum? x)
-    ((cdr ops) x)
-    ((car ops) x)))
-
-(define (promote-dispatch ops x y)
-  (if (flonum? x)
-    (if (flonum? y)
-      ((cdr ops) x y)
-      ((cdr ops) x (fixnum->flonum y)))
-    (if (flonum? y)
-      ((cdr ops) (fixnum->flonum x) y)
-      ((car ops) x y))))
-
-; Unary ops
-
-(define (neg x)
-  (type-dispatch (cons fix:neg flo:neg) x))
-
-(define (abs x)
-  (type-dispatch (cons fix:abs flo:abs) x))
-
-(define (flo:1+ x) (flo:+ x 1.0))
-(define (flo:1- x) (flo:- x 1.0))
-
-(define (1+ n)
-  (type-dispatch (cons fix:1+ flo:1+) n))
-
-(define (1- n)
-  (type-dispatch (cons fix:1- flo:1-) n))
-
-(define (apply-to-flonum op x)
-  (if (flonum? x) (op x) x))
-
-(define (round x)
-  (apply-to-flonum flo:round x))
-(define (floor x)
-  (apply-to-flonum flo:floor x))
-(define (ceiling x)
-  (apply-to-flonum flo:ceiling x))
-(define (truncate x)
-  (apply-to-flonum flo:truncate x))
-
-; Binary operations
-
-(define (fix:/ x y) ; Non-standard definition while we don't have rationals
-  (if (fix:= 0 (fix:remainder x y))
-    (fix:quotient x y)
-    (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
-
-(define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
-(define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
-(define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
-(define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
-
-(define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
-(define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
-(define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
-(define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
-(define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
-
-(define (null? arg)
-  (eq? arg '()))
-
-(define (+ . args)
-  (fold-left pair+ 0 args))
-
-(define (- first . rest)
-  (if (null? rest)
-    (neg first)
-    (pair- first (apply + rest))))
-
-(define (* . args)
-  (fold-left pair* 1 args))
-
-(define (/ first . rest)
-  (if (null? rest)
-    (pair/ 1 first)
-    (pair/ first (apply * rest))))
-
-(define (quotient n1 n2)
-  (fix:quotient n1 n2))
-
-(define (remainder n1 n2)
-  (fix:remainder n1 n2))
-
-(define modulo remainder)
-
-; Relations
-
-(define (test-relation rel l)
-  (if (null? l)
-    #t
-    (if (null? (cdr l))
-      #t
-      (if (rel (car l) (car (cdr l)))
-        (test-relation rel (cdr l))
-        #f))))
-
-(define (= . args)
-  (test-relation pair= args))
-
-(define (> . args)
-  (test-relation pair> args))
-
-(define (< . args)
-  (test-relation pair< args))
-
-(define (>= . args)
-  (test-relation pair>= args))
-
-(define (<= . args)
-  (test-relation pair<= args))
-
-; Numeric tests 
-
-(define (zero? x) (pair= x 0.0))
-(define (positive x) (pair> x 0.0))
-(define (odd? n) (pair= (remainder n 2) 0))
-(define (odd? n) (not (pair= (remainder n 2) 0)))
-
-
-; Current state of the numerical tower
-(define (complex? x) #f)
-(define (real? x) #t)
-(define (rational? x) #t)
-(define (integer? x) (= x (round x)))
-(define (exact? x) (fixnum? x))
-(define (inexact? x) (flonum? x))
-(define (number? x)
-  (if (fixnum? x) #t
-    (if (flonum? x) #t
-      (if (ratnum? x) #t #f))))
-
-
-;; LISTS
-
-; Return number of items in list
-(define (length l)
-  (define (iter a count)
-    (if (null? a)
-      count
-      (iter (cdr a) (fix:+ count 1))))
-  (iter l 0))
-
-; Reverse the contents of a list
-(define (reverse l)
-  (if (null? l)
-    ()
-    (append (reverse (cdr l)) (list (car l)))))
-
-
-;; TESTING
-
-; Test for the while macro.
-(define (count)
-  (define counter 10)
-  (while (> counter 0)
-         (display counter) (newline)
-         (set! counter (- counter 1))))
-
-; Basic iterative summation.  Run this on large numbers to
-; test garbage collection and tail-call optimization.
-(define (sum n)
-
-  (define (sum-iter total count maxcount)
-    (if (fix:> count maxcount)
-      total
-      (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
-  
-  (sum-iter 0 1 n))
-
-; Recursive summation. Use this to compare with tail call
-; optimized iterative algorithm.
-(define (sum-recurse n)
-  (if (fix:= n 0)
-    0
-    (fix:+ n (sum-recurse (fix:- n 1)))))
-
+(load "scheme-library-1-essential.scm")
+(load "scheme-library-2-derived-forms.scm")
+;(load "scheme-library-3-functional.scm")
+;(load "scheme-library-4-numbers.scm")
+;(load "scheme-library-5-lists.scm")
+;(load "scheme-library-6-testing.scm")
 
 ;; MISC
 
diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index f94701f..f6bb92d 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -607,10 +607,6 @@ defer display
     2swap apply
 ; make-primitive apply 
 
-: make-continuation
-  \ TODO: Capture parameter and return stacks in continuation
-;
-
 :noname ( args -- result )
   make-continuation nil cons
   2swap apply
diff --git a/src/scheme.4th b/src/scheme.4th
index 48c363a..9ad4fb3 100644
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -76,12 +76,6 @@ create car-type-cells scheme-memsize allot
 create cdr-cells scheme-memsize allot
 create cdr-type-cells scheme-memsize allot
 
-variable gc-enabled
-false gc-enabled !
-
-: gc-enabled?
-    gc-enabled @ ;
-
 create nextfrees scheme-memsize allot
 :noname
     scheme-memsize 0 do
@@ -97,9 +91,7 @@ variable nextfree
     nextfree !
 
     nextfree @ scheme-memsize >= if
-        gc-enabled? if
-            collect-garbage
-        then
+      collect-garbage
     then
 
     nextfree @ scheme-memsize >= if
@@ -141,6 +133,10 @@ variable nextfree
     cdr-cells + !
 ;
 
+variable object-stack-base
+: init-object-stack-base
+  depth object-stack-base ! ;
+
 : nil 0 nil-type ;
 : nil? nil-type istype? ;
 
@@ -530,6 +526,47 @@ global-env obj!
 
 \ }}}
 
+\ ---- Continuations ---- {{{
+
+: cons-return-stack ( -- listobj )
+  rsp@ 1- rsp0  = if
+    nil exit
+  then
+
+  nil rsp@ 1- rsp0 do
+    i 1+ @ fixnum-type 2swap cons
+  loop
+;
+
+: cons-param-stack ( -- listobj )
+  nil 
+
+  depth 2- object-stack-base @ = if
+    exit
+  then
+
+  depth 2- object-stack-base @ do
+        PSP0 i + 1 + @
+        PSP0 i + 2 + @
+
+        2swap cons
+    2 +loop
+;
+
+: make-continuation
+
+  cons-param-stack
+  cons-return-stack
+  cons drop continuation-type
+;
+
+: restore-continuation
+  \ TODO: replace current parameter and return stacks with
+  \ contents of continuation object.
+;
+
+\ }}}
+
 \ ---- Primitives ---- {{{
 
 : make-primitive ( cfa -- )
@@ -1954,15 +1991,6 @@ parse-idx-stack parse-idx-sp !
 
 \ ---- Garbage Collection ---- {{{
 
-variable gc-stack-depth
-
-: enable-gc
-    depth gc-stack-depth !
-    true gc-enabled ! ;
-
-: disable-gc
-    false gc-enabled ! ;
-
 : pairlike? ( obj -- obj bool )
     pair-type istype? if true exit then
     string-type istype? if true exit then
@@ -2038,7 +2066,7 @@ variable gc-stack-depth
     console-i/o-port obj@ gc-mark-obj
     global-env obj@ gc-mark-obj
 
-    depth gc-stack-depth @ do
+    depth object-stack-base @ do
         PSP0 i + 1 + @
         PSP0 i + 2 + @
 
@@ -2087,11 +2115,8 @@ variable gc-stack-depth
 
     include scheme-primitives.4th
 
-    enable-gc
-
+    init-object-stack-base
     s" scheme-library.scm" load 2drop
-
-    disable-gc
     
 \ }}}
 
@@ -2119,7 +2144,7 @@ variable gc-stack-depth
 : repl
     empty-parse-str
 
-    enable-gc
+    init-object-stack-base
 
     \ Display welcome message
     welcome-symbol nil cons global-env obj@ eval 2drop
@@ -2133,8 +2158,6 @@ variable gc-stack-depth
             throw false
         endcase
     until
-
-    disable-gc
 ;
 
 forth definitions