additional core words

Dochi/Compile.hs

@@ -63,6 +63,7 @@ literalValue v =
       LChar value     -> return $ VChar value
       LKeyword value  -> return $ VKeyword value
       LList value     -> literalList value
+      LCons value     -> literalCons value
       LTable value    -> literalTable value
 
       CodeBlock ast   -> do st <- get

Dochi/Core.hs

@@ -9,9 +9,13 @@ import qualified Data.Map as M
 import Control.Monad.State
 import Random
 
+prettylist li h (VCons h2 t2) = prettylist (h:li) h2 t2
+prettylist li h (VBool False) = "L{" ++ (intercalate " " $ map prettyprint $ reverse $ h:li) ++ "}"
+prettylist li h t = "C{" ++ (intercalate " " $ map prettyprint $ reverse $ t:h:li) ++ "}"
+
 prettyprint v = 
     case v of
-      VString a -> a
+      VString a -> "\"" ++ a ++ "\""
       VChar a -> "Ch{" ++ [a] ++ "}"
       VInteger a -> show a
       VWord a -> "/" ++ a
@@ -20,13 +24,10 @@ prettyprint v =
       VBool True -> "t"
       VQuot _ -> "[QUOT]"
       VClosure vals _ -> "[closure over " ++ (intercalate " " $ map prettyprint vals) ++ "]"
-      VCons h t -> "L{" ++ pplist h t
+      VCons h t -> prettylist [] h t
       VTable t -> "T{" ++ (intercalate " " $ map pptable $ M.toList t) ++ "}"
 
-    where pplist h (VBool False) = prettyprint h ++ "}"
-          pplist h (VCons h2 t2) = prettyprint h ++ " " ++ pplist h2 t2
-          pplist h t = prettyprint h ++ " . " ++ prettyprint t ++ "}"
-          pptable (k,v) = (prettyprint k) ++ " " ++ (prettyprint v)
+    where pptable (k,v) = (prettyprint k) ++ " " ++ (prettyprint v)
 
 doprettyprint = popstack >>= (liftIO . putStrLn . prettyprint)
 
@@ -46,7 +47,9 @@ writestr = checkedString >>= (liftIO . putStr)
 
 toString = do
   v <- popstack
-  pushstack $ VString $ prettyprint v
+  pushstack $ VString $ case v of
+                          VString a -> a
+                          a -> prettyprint a
 
 checkedInteger = do
   v <- popstack
@@ -151,6 +154,19 @@ gettable = do
   t <- checkedTable
   pushstack $ fromMaybe (VBool False) $ M.lookup k t
 
+tableKeys = do
+  t <- checkedTable
+  pushstack $ foldr VCons (VBool False) $ M.keys t
+
+tableValues = do
+  t <- checkedTable
+  pushstack $ foldr VCons (VBool False) $ M.elems t
+
+tableUnion = do
+  t1 <- checkedTable
+  t2 <- checkedTable
+  pushstack $ VTable $ M.union t1 t2
+
 
 
 -- misc
@@ -172,8 +188,11 @@ corelib = M.fromList
           , (".e", printenv)
           , (".v", printvars)
 
-          , ("<<", inserttable)
-          , (">>", gettable)
+          , ("<<",     inserttable)
+          , (">>",     gettable)
+          , ("keys",   tableKeys)
+          , ("values", tableValues)
+          , ("union",  tableUnion)
 
           , ("if", ifstmt)
 

core.chi

@@ -3,11 +3,11 @@ module core
 
 def dup (a) a a
 def swap (a b) b a
+
 def bi (v q1 q2) v @q1 v @q2
+def bi* (v1 v2 q1 q2) v1 @q1 v2 @q2
 def tri (v q1 q2 q3) v @q1 v @q2 v @q3
-
-def square dup *
-
+def tri* (v1 v2 v3 q1 q2 q3) v1 @q1 v2 @q2 v3 @q3
 
 
 # lists
@@ -19,25 +19,43 @@ def each (l q)
     hd q call
     tl [tl q each] when
 
-def to-list (stack-count)
+def 2each (l1 l2 q)
+    l1 uncons (hd1 tl1)
+    l2 uncons (hd2 tl2)
+    hd1 hd2 q call
+    tl1 tl2 and [tl1 tl2 q 2each] when
+
+def ->list (stack-count)
     f [swap ;] stack-count do-times
 
 def choose
-    dup length -- 0 swap rand-range nth
+    dup length dec 0 swap rand-range nth
 
 
-def remove-if (test)
-    dup [uncons (hd tl) tl test remove-if hd @test [hd ;] unless]
-        [drop f]
-        if
+def remove-if (test) dup
+    [uncons (hd tl) tl test remove-if hd @test [hd ;] unless]
+    [drop f]
+    if
 
 def remove (item) [item =] remove-if
 def filter (test) [@test not] remove-if
 
+def range (low high)
+    low high <= [low inc high range low ;] [f] if
+
+def reverse (li) f li [;] each
 
-def map t
-def set-difference t
+def map (fn) f swap [fn call ;] each reverse
 
+def set-difference [remove] each
+
+def append (l1 l2) l1 reverse l2 [;] each reverse
+
+# tables
+
+def table-each (tbl q) tbl keys tbl values q 2each
+
+# misc
 
 def when [] if
 def unless [] swap if
@@ -46,11 +64,14 @@ def not [f] [t] if
 def and [drop f] unless
 def or [drop t] when
 
-def -- 1 -
-def ++ 1 +
+def lazy-or (q) dup [drop q call] unless
+def lazy-and (q) dup [drop q call] when
+
+def dec 1 -
+def inc 1 +
 
 def do-times (q i)
     q call
-    i -- (i)
+    i dec (i)
     i 0 > [q i do-times] when
 

test.chi

@@ -1,31 +1,12 @@
 
 module test
 
-#import blah de blah ;
-#export rah de rah ;
-#private de re de ;
-
-
-# simple object orientation
-
-def <square> (size) T{:class :square} size :size <<
-def <circle> (dia) T{:class :circle} dia :dia <<
-
-def method-call (obj m) m obj :class >> >> obj swap call
-
-def area T{
-
-    :square [:size >> square]
-    :circle [:dia >> 3 * square]
-
-    } method-call
-
-
 def factorial (n) n 1 <= [1] [n 1 - factorial n *] if
 
 def run-test call ["."] ["X"] if write
 
 
+
 module main
 
 def main
@@ -43,18 +24,29 @@ def main
     [f t or]
     [f f or not]
 
+    [t [t] lazy-and]
+    [t [f] lazy-and not]
+    [f [t] lazy-and not]
+    [f [f] lazy-and not]
+    [t [t] lazy-or]
+    [t [f] lazy-or]
+    [f [t] lazy-or]
+    [f [f] lazy-or not]
+
+    [1 [2] lazy-or 1 =]
+    [f [2] lazy-or 2 =]
+
+    [f L{ [f] [f] [f] [4] [5] [6] } [lazy-or] each 4 =]
+    [t L{ [1] [2] [3] [4] [5] [6] } [lazy-and] each 6 =]
+    [t L{ [1] [2] [f] [4] [5] [6] } [lazy-and] each not]
+
     [1 1 + 2 =]
     [1 2 <]
     [2 1 >]
     ["test" dup =]
     [2 1 swap swap >]
     [5 factorial 120 =]
 
-    # object/table tests
-
-    [5 <circle> area 225 =]
-    [5 <square> area 25 =]
-
     # combinator test
 
     [1 [5 +] [4 +] bi >]
@@ -64,19 +56,26 @@ def main
 
     [0 L{1 2 3} [+] each 6 =]
     [f 3 ; 2 ; 1 ; L{1 2 3} =]
-    [1 2 3 3 to-list L{1 2 3} =]
-
+    [1 2 3 3 ->list L{1 2 3} =]
     [L{1 2 3} 2 remove L{1 3} =]
     [L{1 2 3 4} [2 <=] remove-if L{3 4} =]
     [L{1 2 3 4} [2 <=] filter L{1 2} =]
-
     [1 (a) {a a a} L{1 1 1} =]
+    [L{1 2 3} reverse L{3 2 1} =]
+    [L{1 2 3} [inc] map L{2 3 4} =]
+    [L{1 2 3 4} L{3 4 5 6} set-difference L{1 2} =]
+    [L{1 2 3} L{3 4 5} append L{1 2 3 3 4 5} =]
 
     # literal test
 
-    [C{1 2} uncons -- =]
-    [T{:a 1 :b 2} [:a >>] [:b >>] bi -- =]
+    [C{1 2} uncons dec =]
+
+    # table test
+
+    [T{:a 1 :b 2} [:a >>] [:b >>] bi dec =]
     [T{:a 1 :b 2} 3 :c << T{:a 1 :b 2 :c 3} =]
+    [f T{:a 1 :b 2 :c 0} [swap ; ;] table-each reverse L{C{:a 1} C{:b 2} C{:c 0}} =]
+    [T{:a 1 :b 2} T{:b 3 :c 4} union T{:a 1 :b 3 :c 4} =]
 
     } [run-test] each