Started adding support for pre-defined symbols.

[scheme.forth.jl.git] / scheme.4th

diff --git a/scheme.4th b/scheme.4th
index 10e4f26..120edd2 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -18,7 +18,7 @@ include defer-is.4th
 
 \ ------ Memory ------
 
-100 constant N
+1000 constant N
 create car-cells N allot
 create car-type-cells N allot
 create cdr-cells N allot
@@ -65,6 +65,33 @@ variable nextfree
 objvar symbol-table
 nil symbol-table setobj
 
+\ ---- Pre-defined symbols ----
+
+: (create-symbol) ( addr n -- symbol-obj )
+    dup 0= if
+        2drop nil
+    else
+        2dup drop @ character-type 2swap
+        swap 1+ swap 1-
+        recurse
+
+        cons
+    then
+;
+
+: create-symbol ( -- )
+    bl word
+    count
+    (create-symbol)
+    drop symbol-type
+
+    symbol-table fetchobj
+    cons
+    symbol-table setobj
+;
+
+create-symbol quote
+
 \ ---- Read ----
 
 variable parse-idx
@@ -353,44 +380,54 @@ parse-idx-stack parse-idx-sp !
     if
         nil? -rot 2drop
         if
-            true exit
+            2drop 2drop true exit
         else
-            false exit
+            2drop 2drop false exit
         then
     else
         nil? -rot 2drop
         if
-            false exit
+            2drop 2drop false exit
         then
     then
 
     2over 2over
 
     \ Neither nil
-    car 2swap car rot = -rot = and if
+    car drop -rot car drop = if
             cdr 2swap cdr recurse
         else
             2drop 2drop false
     then
 ;
 
-: (symbol-in-table?) ( charlist symbol-table -- charlist symbol-obj )
+: charlist>symbol ( charlist -- symbol-obj )
+
+    symbol-table fetchobj
 
     begin
         nil? false =
     while
         2over 2over
-        car
+        car drop pair-type
         charlist-equiv if
+            2swap 2drop
+            car
+            exit
+        else
+            cdr
+        then
     repeat
-;
 
-: symbol-in-table? ( charlist -- charlist bool )
-    symbol-table (symbol-in-table?) ;
+    2drop
+    drop symbol-type 2dup
+    symbol-table fetchobj cons
+    symbol-table setobj
+;
 
 defer read
 
-: readpair ( -- obj )
+: readpair ( -- pairobj )
     eatspaces
 
     \ Empty lists
@@ -467,12 +504,7 @@ defer read
     then
 
     symbol? if
-        readsymbol
-        drop symbol-type
-        2dup
-        symbol-table fetch
-        cons
-        symbol-table set
+        readsymbol charlist>symbol
         exit
     then