Feature/link all to vm

LobsterLang/app/Main.hs

@@ -15,10 +15,13 @@ import System.Environment (getArgs)
 import qualified AstEval
 import qualified AstOptimizer
 import qualified Compiler
+import qualified Vm
+import qualified CompiletoVm
 import Control.Exception
 import qualified AST
 import AstOptimizer (optimizeAst)
 
+import Debug.Trace
 
 lobsterNotHappy :: String -> String -> String -> String
 lobsterNotHappy color state str = "\ESC[" ++ color ++ "m\ESC[1mThe lobster is " ++ state ++ ": " ++ str ++ "\ESC[0m"
@@ -58,7 +61,7 @@ compileInfo :: String -> [AST.Ast] -> [Scope.ScopeMb] -> IO ()
 compileInfo _ [] _ = putStr ""
 compileInfo filename list stack = checkCompileInfo (optimizeAst stack list False) [] >>= \res -> case sequence res of
         Left _ -> exitWith (ExitFailure 84)
-        Right value -> Compiler.compile (map AstOptimizer.fromOptimised value) (filename ++ ".o") True
+        Right value -> Compiler.compile (map AstOptimizer.fromOptimised value) (filename ++ "o") True
 
 compileFile :: String -> String -> IO ()
 compileFile file s = case runParser parseLobster (0, 0) s of
@@ -68,6 +71,8 @@ compileFile file s = case runParser parseLobster (0, 0) s of
 
 checkArgs :: [String] -> IO ()
 checkArgs [] = print "Launch Interpreter" >> inputLoop []
+checkArgs ("-e":file:_) = CompiletoVm.makeConvert file
+                        >>= \instructions -> trace ("instructions to execute" ++ show instructions) print (Vm.exec 0 [] [] instructions [])
 checkArgs (file:_) = either
                         (\_ -> print "File doesn't exist" >> exitWith (ExitFailure 84))
                         (compileFile file)

LobsterLang/src/Compiler.hs

@@ -25,6 +25,7 @@ import qualified Data.ByteString.UTF8 as BSUTF8
 import Data.Binary
 import Data.Binary.Put
 import qualified Data.List
+import Debug.Trace (trace)
 
 data CompileConstants = Null
   | MagicNumber deriving (Show, Eq)
@@ -180,82 +181,84 @@ astToInstructions (Symbol symbolName (Just symbolArgs)) =
   [PushSym symbolName (Just symbolArgsInstructions)]
   where
     symbolArgsInstructions =
-      foldr (((:) . \b -> b ++ [PutArg]) . astToInstructions) [] symbolArgs
+      map astToInstructions symbolArgs
 astToInstructions (String stringValue) = [PushStr stringValue]
 astToInstructions (List values) =
-  [PushList (length valuesInstructions) valuesInstructions]
+  [PushList (_findAstInstrSize values) valuesInstructions]
   where
     valuesInstructions = map astToInstructions values
 astToInstructions (AST.Call "+" args) =
-  concatMap astToInstructions args ++ [Add]
+  reverse (concatMap astToInstructions args) ++ [Add]
 astToInstructions (AST.Call "-" args) =
-  concatMap astToInstructions args ++ [Sub]
+  reverse (concatMap astToInstructions args) ++ [Sub]
 astToInstructions (AST.Call "*" args) =
-  concatMap astToInstructions args ++ [Mul]
+  reverse (concatMap astToInstructions args) ++ [Mul]
 astToInstructions (AST.Call "/" args) =
-  concatMap astToInstructions args ++ [Div]
+  reverse (concatMap astToInstructions args) ++ [Div]
 astToInstructions (AST.Call "%" args) =
-  concatMap astToInstructions args ++ [Mod]
+  reverse (concatMap astToInstructions args) ++ [Mod]
 astToInstructions (AST.Call "^^" args) =
-  concatMap astToInstructions args ++ [XorB]
+  reverse (concatMap astToInstructions args) ++ [XorB]
 astToInstructions (AST.Call "==" args) =
-  concatMap astToInstructions args ++ [Eq]
+  reverse (concatMap astToInstructions args) ++ [Eq]
 astToInstructions (AST.Call "!=" args) =
-  concatMap astToInstructions args ++ [NotEq]
+  reverse (concatMap astToInstructions args) ++ [NotEq]
 astToInstructions (AST.Call "<" args) =
-  concatMap astToInstructions args ++ [Less]
+  reverse (concatMap astToInstructions args) ++ [Less]
 astToInstructions (AST.Call "<=" args) =
-  concatMap astToInstructions args ++ [LessEq]
+  reverse (concatMap astToInstructions args) ++ [LessEq]
 astToInstructions (AST.Call ">" args) =
-  concatMap astToInstructions args ++ [Great]
+  reverse (concatMap astToInstructions args) ++ [Great]
 astToInstructions (AST.Call ">=" args) =
-  concatMap astToInstructions args ++ [GreatEq]
+  reverse (concatMap astToInstructions args) ++ [GreatEq]
 astToInstructions (AST.Call "&&" args) =
-  concatMap astToInstructions args ++ [And]
+  reverse (concatMap astToInstructions args) ++ [And]
 astToInstructions (AST.Call "||" args) =
-  concatMap astToInstructions args ++ [Or]
+  reverse (concatMap astToInstructions args) ++ [Or]
 astToInstructions (AST.Call "!" args) =
-  concatMap astToInstructions args ++ [Not]
+  reverse (concatMap astToInstructions args) ++ [Not]
 astToInstructions (AST.Call "$" args) =
-  concatMap astToInstructions args ++ [Then]
+  reverse (concatMap astToInstructions args) ++ [Then]
 astToInstructions (AST.Call "@" args) =
-  concatMap astToInstructions args ++ [ToStr]
+  reverse (concatMap astToInstructions args) ++ [ToStr]
 astToInstructions (AST.Call "++" args) =
-  concatMap astToInstructions args ++ [Apnd]
+  reverse (concatMap astToInstructions args) ++ [Apnd]
 astToInstructions (AST.Call "--" args) =
-  concatMap astToInstructions args ++ [RemAllOcc]
+  reverse (concatMap astToInstructions args) ++ [RemAllOcc]
 astToInstructions (AST.Call "!!" args) =
-  concatMap astToInstructions args ++ [Get]
+  reverse (concatMap astToInstructions args) ++ [Get]
 astToInstructions (AST.Call "~" args) =
-  concatMap astToInstructions args ++ [Len]
+  reverse (concatMap astToInstructions args) ++ [Len]
 astToInstructions (AST.Call _ _) = [NoOp]
 astToInstructions (Define symbolName value) =
   let symbolValue = astToInstructions value
-  in [Def symbolName (length symbolValue) symbolValue]
+  in [Def symbolName 1 symbolValue]
 astToInstructions (FunctionValue argsNames funcBody Nothing) =
   [ Fnv
     (length argsNames)
     argsNames
-    (length funcBodyInstructions)
+    nbFuncBodyInstructions
     funcBodyInstructions
     []
     Nothing ]
   where
+    nbFuncBodyInstructions = _findAstInstrSize [funcBody]
     funcBodyInstructions =
       _resolveFunctionPushArgs (astToInstructions funcBody ++ [Ret]) argsNames
 astToInstructions (FunctionValue argsNames funcBody (Just argsValues)) =
   [ Fnv
     (length argsNames)
     argsNames
-    (length funcBodyInstructions)
+    nbFuncBodyInstructions
     funcBodyInstructions
     nbArgsValuesInstructions
     argsValuesInstructions ]
   where
+    nbFuncBodyInstructions = _findAstInstrSize [funcBody]
     funcBodyInstructions =
       _resolveFunctionPushArgs (astToInstructions funcBody ++ [Ret]) argsNames
     argsValuesInstructions =
-      Just (foldr (((:) . \b -> b ++ [PutArg]) . astToInstructions) [] argsValues)
+      Just (map astToInstructions argsValues)
     nbArgsValuesInstructions = _instructionListLengths argsValuesInstructions
 astToInstructions (AST.Cond cond trueBlock (Just falseBlock)) =
   [ Compiler.Cond
@@ -267,8 +270,8 @@ astToInstructions (AST.Cond cond trueBlock (Just falseBlock)) =
     condInstructions = astToInstructions cond
     falseBlockInstructions = astToInstructions falseBlock
     trueBlockInstructions =
-      astToInstructions trueBlock ++ [Jump (length falseBlockInstructions)]
-    nbTrueBlockInstructions = length trueBlockInstructions
+      astToInstructions trueBlock ++ [Jump (_findAstInstrSize [falseBlock] + 1)]
+    nbTrueBlockInstructions = _findAstInstrSize [trueBlock] + 1
 astToInstructions (AST.Cond cond trueBlock Nothing) =
   [ Compiler.Cond
     condInstructions
@@ -279,7 +282,7 @@ astToInstructions (AST.Cond cond trueBlock Nothing) =
     condInstructions = astToInstructions cond
     trueBlockInstructions =
       astToInstructions trueBlock
-    nbTrueBlockInstructions = length trueBlockInstructions
+    nbTrueBlockInstructions = _findAstInstrSize [trueBlock] + 1
 
 _showInstruction :: Instruction -> Int -> [Char]
 _showInstruction NoOp _ = "NO_OP\n"
@@ -411,15 +414,53 @@ _showInstruction Len depth =
 
 _resolveFunctionPushArgs :: [Instruction] -> [String] -> [Instruction]
 _resolveFunctionPushArgs [] _ = []
-_resolveFunctionPushArgs [PushSym symbolName args] argsNames =
+_resolveFunctionPushArgs [PushSym symbolName Nothing] argsNames =
   case Data.List.elemIndex symbolName argsNames of
     Just value -> [PushArg value]
-    Nothing -> [PushSym symbolName args]
+    Nothing -> [PushSym symbolName Nothing]
+_resolveFunctionPushArgs [PushSym symbolName (Just args)] argsNames =
+  case Data.List.elemIndex symbolName argsNames of
+    Just value -> [PushArg value]
+    Nothing -> [PushSym symbolName (Just (fmap (`_resolveFunctionPushArgs` argsNames) args))]
+_resolveFunctionPushArgs [Compiler.Cond condInstructions
+  nbTrueBlockInstructions trueBlockInstructions
+  (Just falseBlockInstructions)] argsNames = trace (show (_resolveFunctionPushArgs falseBlockInstructions argsNames))
+    [ Compiler.Cond
+    (_resolveFunctionPushArgs condInstructions argsNames)
+    nbTrueBlockInstructions
+    (_resolveFunctionPushArgs trueBlockInstructions argsNames)
+    (Just (_resolveFunctionPushArgs falseBlockInstructions argsNames))]
+_resolveFunctionPushArgs [Compiler.Cond condInstructions
+  nbTrueBlockInstructions trueBlockInstructions Nothing] argsNames =
+    [ Compiler.Cond
+    (_resolveFunctionPushArgs condInstructions argsNames)
+    nbTrueBlockInstructions
+    (_resolveFunctionPushArgs trueBlockInstructions argsNames)
+    Nothing]
+_resolveFunctionPushArgs [PushList nbValuesInstructions valuesInstructions]
+  argsNames =
+  [PushList nbValuesInstructions
+    (fmap (`_resolveFunctionPushArgs` argsNames) valuesInstructions)]
 _resolveFunctionPushArgs [instruction] _ = [instruction]
 _resolveFunctionPushArgs (instruction:instructions) argsNames
   = _resolveFunctionPushArgs [instruction] argsNames
   ++ _resolveFunctionPushArgs instructions argsNames
 
+_findAstInstrSize :: [Ast] -> Int
+_findAstInstrSize [] = 0
+_findAstInstrSize (Value _:xs) = 1 + _findAstInstrSize xs
+_findAstInstrSize (Boolean _:xs) = 1 + _findAstInstrSize xs
+_findAstInstrSize (String _:xs) = 1 + _findAstInstrSize xs
+_findAstInstrSize (Define _ ast:xs) = 1 + _findAstInstrSize [ast] + _findAstInstrSize xs
+_findAstInstrSize (List asts:xs) = 1 + _findAstInstrSize asts + _findAstInstrSize xs
+_findAstInstrSize (Symbol _ Nothing:xs) = 1 + _findAstInstrSize xs
+_findAstInstrSize (Symbol _ (Just asts):xs) = _findAstInstrSize asts + 4 + _findAstInstrSize xs-- push nbGivenArgs, pushSym, Call
+_findAstInstrSize (AST.Call _ asts:xs) = _findAstInstrSize asts + 1 + _findAstInstrSize xs
+_findAstInstrSize (FunctionValue _ ast Nothing:xs) = _findAstInstrSize [ast] + 2 + _findAstInstrSize xs
+_findAstInstrSize (FunctionValue _ ast (Just asts):xs) = _findAstInstrSize asts + 1 + _findAstInstrSize [ast] + 3 + _findAstInstrSize xs
+_findAstInstrSize (AST.Cond astCond astTrue Nothing:xs) = _findAstInstrSize [astCond] + 1 + _findAstInstrSize [astTrue] + _findAstInstrSize xs
+_findAstInstrSize (AST.Cond astCond astTrue (Just astFalse):xs) = _findAstInstrSize [astCond] + 1 + _findAstInstrSize [astTrue] + 1 + _findAstInstrSize [astFalse] + _findAstInstrSize xs
+
 _instructionListLengths :: Maybe [[Instruction]] -> [Int]
 _instructionListLengths (Just []) = [0]
 _instructionListLengths (Just [instructionList]) = [length instructionList]
@@ -477,6 +518,7 @@ _compileInstruction (PushSym symbolName Nothing) =
   >> _putString symbolName
 _compileInstruction (PushSym symbolName (Just symbolArgs)) =
   _fputList compileInstructions symbolArgs
+  >> _putOpCodeFromInstruction (PushI (length symbolArgs))
   >> _putInt32 (length symbolArgs)
   >> _putOpCodeFromInstruction (PushSym symbolName (Just symbolArgs))
   >> _putString symbolName >> _putOpCodeFromInstruction Compiler.Call
@@ -552,6 +594,7 @@ _compileInstruction (Fnv nbArgsNames argsNames nbFuncBodyInstructions
   funcBodyInstructions nbArgsValuesInstructions
   (Just argsValuesInstructions)) =
     _fputList compileInstructions argsValuesInstructions
+    >> _putOpCodeFromInstruction (PushI (length argsValuesInstructions))
     >> _putInt32 (length argsValuesInstructions)
     >> _putOpCodeFromInstruction (Fnv nbArgsNames argsNames
     nbFuncBodyInstructions funcBodyInstructions nbArgsValuesInstructions
@@ -602,5 +645,5 @@ compile ast filepath showInst = if showInst
     >> writeCompiledInstructionsToFile filepath compiledInstructions
   else writeCompiledInstructionsToFile filepath compiledInstructions
   where
-    instructions = concatMap astToInstructions ast ++ [Ret]
+    instructions = trace (show ast) concatMap astToInstructions ast ++ [Ret]
     compiledInstructions = _putInt32 (fromEnum MagicNumber) >> _fputList _compileInstruction instructions