Make fiboY work

3 files changed, 75 insertions, 61 deletions

diff --git a/compiler.hs b/compiler.hs
index 64b887c..2e3b80b 100644
--- a/compiler.hs
+++ b/compiler.hs
@@ -6,6 +6,7 @@ import Control.Monad.State.Strict
 import Data.List
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import Debug.Trace
 
 import AST
 import Intermediate
@@ -70,8 +71,11 @@ data ScopeItem = SIParam Int | SIClosure Int | SIGlobal
 newtype CM a = CM {unCM :: StateT CompState (Except String) a}
   deriving (Functor, Applicative, Monad, MonadState CompState, MonadError String)
 
+-- TODO: extra info like number of arguments, dunno, might be useful
 builtinMap :: Map.Map Name ()
-builtinMap = Map.fromList [("+", ()), ("-", ()), ("<=", ()), ("print", ())]
+builtinMap = Map.fromList [
+    ("+", ()), ("-", ()), ("<=", ()), ("print", ()),
+    ("list", ()), ("car", ()), ("cdr", ())]
 
 bbId :: BB -> Int
 bbId (BB i _ _) = i
@@ -228,6 +232,7 @@ genTValue (TVDefine name value) nextnext = do
     dref <- genTemp
     defineAdd name dref
     vref <- genTValue value nextnext
+    -- traceM $ "Defining '" ++ name ++ "', ref " ++ show dref ++ ", with value " ++ show vref
     addIns (dref, IAssign vref)
     return RNone
 genTValue (TVLambda args body closure) nextnext = do
@@ -245,12 +250,11 @@ genTValue (TVLambda args body closure) nextnext = do
     resref <- case closure of
         [] -> return (RSClo uname)
         _ -> do
-            refs <- foldM (\refs' cname -> do
-                                b <- newBlock
-                                r <- genTValue (TVName cname undefined) b
-                                switchBlock b
-                                return (r : refs'))
-                          [] closure
+            refs <- forM closure $ \cname -> do
+                        b <- newBlock
+                        r <- genTValue (TVName cname undefined) b
+                        switchBlock b
+                        return r
             r <- genTemp
             addIns (r, IAllocClo uname refs)
             return r
@@ -279,3 +283,4 @@ genTValue (TVName name _) nextnext = do
                 _ -> throwError $ "Use of undefined name \"" ++ name ++ "\""
     setTerm $ IJmp nextnext
     return r
+genTValue TVEllipsis _ = throwError "Ellipses not supported in compiler"
diff --git a/fiboY.lisp b/fiboY.lisp
index f46c00a..d12a5ab 100644
--- a/fiboY.lisp
+++ b/fiboY.lisp
@@ -1,39 +1,24 @@
+(define cadr (l) (car (cdr l)))
+(define caddr (l) (car (cdr (cdr l))))
+
 (define YY (recur) (lambda (f) (lambda (a) (f ((recur recur) f) a))))
 (define Y (YY YY))
 
-(define forX (recur (low high func))
-	(if (low <= high)
+(define forX (recur low_high_func)
+	(if (<= (car low_high_func) (cadr low_high_func))
 		(do
-			(func low)
-			(recur (list (+ low 1) high func)))
+			((caddr low_high_func) (car low_high_func))
+			(recur (list (+ (car low_high_func) 1) (cadr low_high_func) (caddr low_high_func))))
 		'()))
 
 (define for (Y forX))
 
-(define fibohelperX (recur (n a b))
-	(if (n <= 0) a
-		(recur (list (- n 1) b (+ a b)))))
+(define fibohelperX (recur n_a_b)
+	(if (<= (car n_a_b) 0) (cadr n_a_b)
+		(recur (list (- (car n_a_b) 1) (caddr n_a_b) (+ (cadr n_a_b) (caddr n_a_b))))))
 
 (define fibohelper (Y fibohelperX))
 
-(define fibo (n) (fibohelper (n 0 1)))
-
-
-
-
-
-; Fill in the dots with the lines below...
-; If you're done, try to dump the whole expression into test.hs.
-
-; ((lambda (YY) ...) (lambda (recur) (lambda (f) (lambda (a) (f ((recur recur) f) a)))))
-; 
-; ((lambda (Y) ...) (YY YY))
-; 
-; ((lambda (forX) ...) (lambda (recur args)  ; args: (low high func)
-; 	(if ((car args) <= (cadr args))
-; 		(do
-; 			((cadr (cdr args)) (car args))
-; 			(recur (list (+ low 1) high func)))
-; 		'())))
-
+(define fibo (n) (fibohelper (list n 0 1)))
 
+(for (list 1 25 (lambda (n) (print (fibo n)))))
diff --git a/vm.hs b/vm.hs
index c21e228..04de0c5 100644
--- a/vm.hs
+++ b/vm.hs
@@ -21,7 +21,13 @@ type TempMap = Map.Map Int RunValue
 
 data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -})
 
-data RunValue = RClosure Name [RunValue] | RValue Value
+-- TODO: are more constructors from Value needed?
+data RunValue
+    = RVClosure Name [RunValue]
+    | RVList [RunValue]
+    | RVNum Int
+    | RVString String
+    | RVQuoted RunValue
   deriving Show
 
 kErrorExit :: String
@@ -47,20 +53,28 @@ vmRunInstr :: Info -> State -> Instruction -> IO State
 -- vmRunInstr _ _ ins | traceShow ins False = undefined
 vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest, instr) = case instr of
     IAssign ref -> return (assignRef state dest (findRef tmap ref))
-    IParam i -> return (assignRef state dest (args !! i))
-    IClosure i -> return (assignRef state dest (closure !! i))
-    IData i -> return (assignRef state dest (RValue (datas !! i)))
-    ICallC cl as -> case findRef tmap cl of
-        RClosure clname clvals -> case Map.lookup clname gfds of
-            Just (GlobFuncDef b _ _) ->
-                let Just bb = Map.lookup b bbmap
-                in do
-                    -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as))
-                    (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb
-                    return (assignRef state dest rv)
-            Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as))
-        _ -> error "VM: Cannot call non-closure object"
-    IAllocClo name clrefs -> return (assignRef state dest (RClosure name (map (findRef tmap) clrefs)))
+    IParam i ->
+        if i < length args then return (assignRef state dest (args !! i))
+            else error $ show closure ++ ", " ++ show i ++ ", param-out-of-range"
+    IClosure i ->
+        if i < length closure then return (assignRef state dest (closure !! i))
+            else error $ show closure ++ ", " ++ show i ++ ", closure-out-of-range"
+    IData i ->
+        if i < length datas then return (assignRef state dest (toRunValue (datas !! i)))
+            else error "data-out-of-range"
+    ICallC cl as ->
+        -- trace ("callc " ++ show (findRef tmap cl) ++ "  " ++ show (map (findRef tmap) as)) $
+        case findRef tmap cl of
+            RVClosure clname clvals -> case Map.lookup clname gfds of
+                Just (GlobFuncDef b _ _) ->
+                    let Just bb = Map.lookup b bbmap
+                    in do
+                        -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as))
+                        (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb
+                        return (assignRef state dest rv)
+                Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as))
+            obj -> error $ "VM: Cannot call non-closure object: " ++ show obj
+    IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs)))
     IDiscard _ -> return state
 
 vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State)
@@ -72,9 +86,9 @@ vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of
     IUnknown -> undefined
 
 findRef :: TempMap -> Ref -> RunValue
-findRef _ (RConst n) = RValue (VNum n)
+findRef _ (RConst n) = RVNum n
 findRef tmap (RTemp i) = fromJust (Map.lookup i tmap)
-findRef _ (RSClo name) = RClosure name []
+findRef _ (RSClo name) = RVClosure name []
 findRef _ RNone = error "VM: None ref used"
 
 assignRef :: State -> Ref -> RunValue -> State
@@ -83,19 +97,29 @@ assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned"
 
 vmRunBuiltin :: Name -> [RunValue] -> IO RunValue
 -- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined
-vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RValue (VList []))
-vmRunBuiltin "<=" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (fromEnum (a <= b))))
-vmRunBuiltin "+" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a + b)))
-vmRunBuiltin "-" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a - b)))
-vmRunBuiltin "car" [RValue (VList (a:_))] = return (RValue a)
-vmRunBuiltin "cdr" [RValue (VList (_:a))] = return (RValue (VList a))
+vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [])
+vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b)))
+vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b))
+vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b))
+vmRunBuiltin "car" [RVList (a:_)] = return a
+vmRunBuiltin "cdr" [RVList (_:a)] = return (RVList a)
+vmRunBuiltin "list" values = return (RVList values)
 vmRunBuiltin name args = error (name ++ " " ++ show args)
 
 printshow :: RunValue -> String
-printshow (RValue (VString str)) = str
-printshow (RValue value) = show value
-printshow (RClosure _ _) = "[closure]"
+printshow (RVString str) = str
+printshow (RVList values) = show values
+printshow (RVNum i) = show i
+printshow (RVQuoted value) = '\'' : show value
+printshow (RVClosure _ _) = "[closure]"
 
 truthy :: RunValue -> Bool
-truthy (RValue (VNum n)) = n /= 0
+truthy (RVNum n) = n /= 0
 truthy _ = True
+
+toRunValue :: Value -> RunValue
+toRunValue (VList values) = RVList (map toRunValue values)
+toRunValue (VNum i) = RVNum i
+toRunValue (VString s) = RVString s
+toRunValue (VQuoted value) = RVQuoted (toRunValue value)
+toRunValue _ = undefined