From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sat, 22 Oct 2016 03:43:54 +0000 (+1300)
Subject: Working on GC.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=1e77138f35f12ccc6fe20d943482ac6b57c3f7cd;p=scheme.forth.jl.git

Working on GC.
---

diff --git a/debugging.4th b/debugging.4th
new file mode 100644
index 0000000..54e17a5
--- /dev/null
+++ b/debugging.4th
@@ -0,0 +1,40 @@
+\ Words useful for debugging
+
+: return-depth
+    RSP@ RSP0 - 1- ;
+
+: stack-trace
+    RSP@ RSP0 1+ do
+        i 0> if
+            i @ 1- dup 0> if
+                @ dup 0> if
+                    >name dup 0> if
+                        cr .name
+                    else
+                        cr ." ***"
+                        drop
+                    then
+                else
+                    cr ." ***"
+                    drop
+                then
+            else
+                cr ." ***"
+                drop
+            then
+        else
+            cr ." ***"
+            drop
+        then
+                
+        loop ;
+
+: trace
+    cr ." ---" cr
+    ." Return stack depth:" return-depth . cr
+    ." Stack trace:"
+    stack-trace
+    cr ." ---" cr
+
+    trace
+;
diff --git a/launcher.4th b/launcher.4th
new file mode 100644
index 0000000..c24c63d
--- /dev/null
+++ b/launcher.4th
@@ -0,0 +1,5 @@
+\ Loads scheme and runs repl.
+
+include scheme.4th
+
+scheme repl
diff --git a/scheme.4th b/scheme.4th
index 46c2969..89b3160 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -3,20 +3,23 @@ scheme definitions
 
 include term-colours.4th
 include defer-is.4th
-include throw-catch.4th
 include float.4th
 
+include debugging.4th
+
 defer read
 defer eval
 defer print
 
+defer collect-garbage
+
 \ ------ Types ------
 
 variable nexttype
 0 nexttype !
 : make-type
     create nexttype @ ,
-    nexttype @ 1+ nexttype !
+    1 nexttype +!
     does> @ ;
 
 make-type fixnum-type
@@ -52,6 +55,8 @@ variable nextfree
     nextfree @ pair-type
 
     1 nextfree +!
+
+    collect-garbage
 ;
 
 : car ( pair-obj -- car-obj )
@@ -114,6 +119,28 @@ variable nextfree
 
 \ }}}
 
+\ ---- Garbage Collection ---- {{{
+
+variable gc-enabled
+false gc-enabled !
+
+: gc-enable
+    true gc-enabled ! ;
+
+: gc-disable
+    false gc-enabled ! ;
+
+: gc-enabled?
+    gc-enabled @ ;
+
+:noname 
+    gc-enabled? if
+        .s ." GC!" cr
+    then
+; is collect-garbage
+
+\ }}}
+
 \ ---- Pre-defined symbols ---- {{{
 
 objvar symbol-table
@@ -341,6 +368,8 @@ global-env obj!
     bl word
     count
 
+    \ 2dup ." Defining primitive " type ." ..." cr
+
     (create-symbol)
     drop symbol-type
     
@@ -840,7 +869,7 @@ parse-idx-stack parse-idx-sp !
 
     eof? if
         inc-parse-idx
-        bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
+        bold fg blue ." Moriturus te saluto." reset-term cr
         quit
     then
 
@@ -1221,12 +1250,17 @@ parse-idx-stack parse-idx-sp !
     cr ." Welcome to scheme.forth.jl!" cr
        ." Use Ctrl-D to exit." cr
 
+    
     empty-parse-str
 
+    gc-enable
+
     begin
         cr bold fg green ." > " reset-term
         read
+
         global-env obj@ eval
+
         fg cyan ." ; " print reset-term
     again
 ;
diff --git a/throw-catch.4th b/throw-catch.4th
deleted file mode 100644
index 6bb88fb..0000000
--- a/throw-catch.4th
+++ /dev/null
@@ -1,39 +0,0 @@
-\ Words implementing exception handling
-
-: catch
-    execute
-    type ;
-
-: throw ( addr -- )
-    begin
-        R> 2dup 1- ' catch =
-    while
-        drop
-    repeat
-
-    >R
-;
-
-: return-depth
-    RSP@ RSP0 - 1- ;
-
-: stack-trace
-    RSP0 1+ begin
-        dup RSP@ <
-    while
-        dup @ 1- @ >name cr .name
-        1+
-    repeat
-
-    drop
-;
-
-: trace
-    cr ." ---" cr
-    ." Return stack depth:" return-depth . cr
-    ." Stack trace:"
-    stack-trace
-    cr ." ---" cr
-
-    trace
-;