diff --git a/Dochi/Compile.hs b/Dochi/Compile.hs index 54c7d7a..107ee1f 100644 --- a/Dochi/Compile.hs +++ b/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 diff --git a/Dochi/Core.hs b/Dochi/Core.hs index 141e11a..908db7e 100644 --- a/Dochi/Core.hs +++ b/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) diff --git a/core.chi b/core.chi index d60c2a4..1aa37d4 100644 --- a/core.chi +++ b/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 diff --git a/test.chi b/test.chi index d7775cd..477470c 100644 --- a/test.chi +++ b/test.chi @@ -1,31 +1,12 @@ module test -#import blah de blah ; -#export rah de rah ; -#private de re de ; - - -# simple object orientation - -def (size) T{:class :square} size :size << -def (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,6 +24,22 @@ 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 >] @@ -50,11 +47,6 @@ def main [2 1 swap swap >] [5 factorial 120 =] - # object/table tests - - [5 area 225 =] - [5 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