Added testing code back in.

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 1d2e21c..56ecab0 100644 (file)
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -1,4 +1,4 @@
-( = Type predicates = )
+( ==== Type predicates ==== )
 
 :noname ( args -- boolobj )
     2dup 1 ensure-arg-count
@@ -48,7 +48,7 @@
     car primitive-proc-type istype? -rot 2drop boolean-type
 ; make-primitive procedure?
 
-( = Type conversions = )
+( ==== Type conversions ==== )
 
 :noname ( args -- fixnum )
     2dup 1 ensure-arg-count
@@ -153,7 +153,7 @@
     charlist>symbol
 ; make-primitive string->symbol
 
-( = Arithmetic = )
+( ==== Arithmetic ==== )
 
 : add-prim ( args -- fixnum )
     2dup nil objeq? if
@@ -284,7 +284,7 @@ variable relcfa
 
 hide relcfa
 
-( = Pairs and Lists = )
+( ==== Pairs and Lists ==== )
 
 :noname ( args -- pair )
     2dup 2 ensure-arg-count
@@ -331,7 +331,7 @@ hide relcfa
     ok-symbol
 ; make-primitive set-cdr!
 
-( = Polymorphic equality testing = )
+( ==== Polymorphic equality testing ==== )
 
 :noname ( args -- bool )
     2dup 2 ensure-arg-count
@@ -340,3 +340,32 @@ hide relcfa
 
     objeq? boolean-type
 ; make-primitive eq?
+
+( ==== Input/Output ==== )
+
+:noname ( args -- finalResult )
+    2dup 1 ensure-arg-count
+    car string-type ensure-arg-type
+
+    drop pair-type
+    pad charlist>cstr
+    pad swap load
+; make-primitive load
+
+' read make-primitive read
+
+:noname ( args -- )
+    2dup 1 ensure-arg-count
+
+    car print cr
+
+    none
+; make-primitive write
+
+( ==== Evaluation ==== )
+
+:noname 
+    \ Dummy apply procedure
+    \ Should never actually run!
+    ." Error: Dummy apply procedure executed!" cr
+; make-primitive apply

diff --git a/scheme.4th b/scheme.4th
index 8c5b159..f96fec9 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -1188,7 +1188,7 @@ hide env
     2swap
 ;
 
-: apply ( proc argvals )
+: apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
                 drop execute
@@ -1210,11 +1210,24 @@ hide env
                 R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
 
-            bold fg red ." Object not applicable. Aboring." reset-term cr
+            bold fg red ." Object not applicable. Aborting." reset-term cr
             abort
         endcase
 ;
 
+: macro-expand ( proc expbody -- result )
+    2swap
+    2dup procedure-body ( expbody proc procbody )
+    -2rot 2dup procedure-params ( procbody expbody proc argnames )
+    -2rot procedure-env ( procbody argnames expbody procenv )
+    
+    -2rot 2swap
+    flatten-proc-args
+    2swap 2rot
+
+    extend-env eval-sequence eval
+;
+
 :noname ( obj env -- result )
     2swap
 
@@ -1296,13 +1309,15 @@ hide env
         else
             \ Macro function evaluation
 
-            ." Macro eval"
-
             ( env exp env opname mproc )
             2swap 2drop -2rot 2drop cdr ( env mproc body )
 
-            \ TODO: evaluate macro procedure on expression body
-            ." ABORTED: Macros not yet fully implemented!" abort
+            2dup print cr
+            macro-expand
+            2dup print cr
+
+            2swap
+            ['] eval goto-deferred
         then
         exit
     then
@@ -1507,6 +1522,49 @@ variable gc-stack-depth
 
 \ }}}
 
+\ ---- Loading files ---- {{{
+
+: charlist>cstr ( charlist addr -- n )
+
+    dup 2swap ( origaddr addr charlist )
+
+    begin 
+        nil? false =
+    while
+        2dup cdr 2swap car 
+        drop ( origaddr addr charlist char )
+        -rot 2swap ( origaddr charlist addr char )
+        over !
+        1+ -rot ( origaddr nextaddr charlist )
+    repeat
+
+    2drop ( origaddr finaladdr ) 
+    swap -
+;
+
+: load ( addr n -- finalResult )
+    open-input-file
+
+    empty-parse-str
+
+    ok-symbol ( port res )
+
+    begin
+        2over read-port ( port res obj )
+
+        2dup EOF character-type objeq? if
+            2drop 2swap close-port
+            exit
+        then
+
+        2swap 2drop ( port obj )
+
+        global-env obj@ eval ( port res )
+    again
+;
+
+\ }}}
+
 \ ---- Primitives ---- {{{
 
 : make-primitive ( cfa -- )
@@ -1562,58 +1620,6 @@ include scheme-primitives.4th
 
 \ }}}
 
-\ ---- Loading files ---- {{{
-
-: charlist>cstr ( charlist addr -- n )
-
-    dup 2swap ( origaddr addr charlist )
-
-    begin 
-        nil? false =
-    while
-        2dup cdr 2swap car 
-        drop ( origaddr addr charlist char )
-        -rot 2swap ( origaddr charlist addr char )
-        over !
-        1+ -rot ( origaddr nextaddr charlist )
-    repeat
-
-    2drop ( origaddr finaladdr ) 
-    swap -
-;
-
-: load ( addr n -- finalResult )
-    open-input-file
-
-    empty-parse-str
-
-    ok-symbol ( port res )
-
-    begin
-        2over read-port ( port res obj )
-
-        2dup EOF character-type objeq? if
-            2drop 2swap close-port
-            exit
-        then
-
-        2swap 2drop ( port obj )
-
-        global-env obj@ eval ( port res )
-    again
-;
-
-:noname ( args -- finalResult )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
-
-    drop pair-type
-    pad charlist>cstr
-    pad swap load
-; make-primitive load
-
-\ }}}
-
 \ ---- REPL ----
 
 : repl

diff --git a/testing.scm b/testing.scm
new file mode 100644 (file)
index 0000000..0b7d95b
--- /dev/null
+++ b/testing.scm
@@ -0,0 +1,40 @@
+;; Some simple procedures useful for implementation testing.
+
+; 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 (> count maxcount)
+      total
+      (sum-iter (+ total count) (+ 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 (= n 0)
+    0
+    (+ n (sum-recurse (- n 1)))))
+
+(define (null? args)
+  (eq? args ()))
+
+; Join two lists together
+(define (join l1 l2)
+  (if (null? l1)
+    l2
+    (cons (car l1) (join (cdr l1) l2))))
+
+; Append an arbitrary number of lists together
+(define (append . lists)
+  (if (null? lists)
+    ()
+    (if (null? (cdr lists))
+      (car lists)
+      (join (car lists) (apply append (cdr lists))))))
+
+; Macro definitions
+(define-macro (let value . body )
+              (list (list 'lambda (list (car value)) body)) (cdr value))