packages feed

simple-stacked-vm (empty) → 0.1

raw patch · 10 files changed

+1443/−0 lines, 10 filesdep +arraydep +basedep +binary-statesetup-changed

Dependencies added: array, base, binary-state, containers, filepath, mtl, parsec

Files

+ LICENSE view
@@ -0,0 +1,165 @@+                  GNU LESSER GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++  This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++  0. Additional Definitions. ++  As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++  "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++  An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++  A "Combined Work" is a work produced by combining or linking an+Application with the Library.  The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++  The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++  The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++  1. Exception to Section 3 of the GNU GPL.++  You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++  2. Conveying Modified Versions.++  If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++   a) under this License, provided that you make a good faith effort to+   ensure that, in the event an Application does not supply the+   function or data, the facility still operates, and performs+   whatever part of its purpose remains meaningful, or++   b) under the GNU GPL, with none of the additional permissions of+   this License applicable to that copy.++  3. Object Code Incorporating Material from Library Header Files.++  The object code form of an Application may incorporate material from+a header file that is part of the Library.  You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++   a) Give prominent notice with each copy of the object code that the+   Library is used in it and that the Library and its use are+   covered by this License.++   b) Accompany the object code with a copy of the GNU GPL and this license+   document.++  4. Combined Works.++  You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++   a) Give prominent notice with each copy of the Combined Work that+   the Library is used in it and that the Library and its use are+   covered by this License.++   b) Accompany the Combined Work with a copy of the GNU GPL and this license+   document.++   c) For a Combined Work that displays copyright notices during+   execution, include the copyright notice for the Library among+   these notices, as well as a reference directing the user to the+   copies of the GNU GPL and this license document.++   d) Do one of the following:++       0) Convey the Minimal Corresponding Source under the terms of this+       License, and the Corresponding Application Code in a form+       suitable for, and under terms that permit, the user to+       recombine or relink the Application with a modified version of+       the Linked Version to produce a modified Combined Work, in the+       manner specified by section 6 of the GNU GPL for conveying+       Corresponding Source.++       1) Use a suitable shared library mechanism for linking with the+       Library.  A suitable mechanism is one that (a) uses at run time+       a copy of the Library already present on the user's computer+       system, and (b) will operate properly with a modified version+       of the Library that is interface-compatible with the Linked+       Version. ++   e) Provide Installation Information, but only if you would otherwise+   be required to provide such information under section 6 of the+   GNU GPL, and only to the extent that such information is+   necessary to install and execute a modified version of the+   Combined Work produced by recombining or relinking the+   Application with a modified version of the Linked Version. (If+   you use option 4d0, the Installation Information must accompany+   the Minimal Corresponding Source and Corresponding Application+   Code. If you use option 4d1, you must provide the Installation+   Information in the manner specified by section 6 of the GNU GPL+   for conveying Corresponding Source.)++  5. Combined Libraries.++  You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++   a) Accompany the combined library with a copy of the same work based+   on the Library, uncombined with any other library facilities,+   conveyed under the terms of this License.++   b) Give prominent notice with the combined library that part of it+   is a work based on the Library, and explaining where to find the+   accompanying uncombined form of the same work.++  6. Revised Versions of the GNU Lesser General Public License.++  The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++  Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++  If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Language/SSVM/Binary.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module Language.SSVM.Binary+  (dumpCode, loadCode)+  where++import Control.Applicative+import Control.Monad (forM_)+import qualified Control.Monad.State as S+import Data.BinaryState+import qualified Data.Map as M+import Data.Char+import Data.Word++import Language.SSVM.Types++data BState = BState {+  bMarks :: Marks,+  bWords :: M.Map String Int,+  bLastWord :: Int,+  bAfterColon :: Bool }+  deriving (Eq, Show)++emptyBState :: BState+emptyBState = BState {+  bMarks = M.empty,+  bWords = M.empty,+  bLastWord = 0,+  bAfterColon = False }++type Put a = PutState BState a+type Get a = GetState BState a++allocWord :: String -> Put Int+allocWord w = do+  st <- S.get+  let next = 1 + bLastWord st+      ws = M.insert w next (bWords st)+  S.put $ st {bWords = ws, bLastWord = next}+  return next++getWordN :: String -> Put Int+getWordN w = do+  ws <- S.gets bWords+  case M.lookup w ws of+    Nothing -> fail $ "Undefined word: " ++ w+    Just i -> return i++byte :: Word8 -> Put ()+byte x = putZ x++char :: Char -> Put ()+char c = putZ (fromIntegral (ord c) :: Word8)++getChar8 :: Get Char+getChar8 = (chr . fromIntegral) <$> (getZ :: Get Word8)++getMark :: String -> Put Int+getMark name = do+  ms <- S.gets bMarks+  case M.lookup name ms of+    Nothing -> fail $ "Undefined mark: @" ++ name+    Just n  -> return n++wordName :: Int -> Get String+wordName n = return $ "WORD_" ++ show n++markName :: Int -> Get String+markName n = do+  let name = "mark_at_" ++ show n+  st <- S.get+  let ms = M.insert name n (bMarks st)+  S.put $ st {bMarks = ms}+  return name++instance BinaryState BState Instruction where+  put NOP      = byte 0+  put (PUSH x) = byte 1 >> put x+  put DROP     = byte 2+  put DUP      = byte 3+  put SWAP     = byte 4+  put OVER     = byte 5+  put PRINT    = byte 6+  put PRINTALL = byte 7+  put ADD      = byte 8+  put MUL      = byte 9+  put DIV      = byte 10+  put REM      = byte 11+  put SUB      = byte 12+  put NEG      = byte 13+  put ABS      = byte 14+  put CMP      = byte 15+  put DEFINE   = byte 16+  put COLON    = do+                 st <- S.get+                 S.put $ st {bAfterColon = True}+                 byte 17+  put (CALL s) = do+                 n <- getWordN s+                 byte 18+                 putZ n+  put VARIABLE = byte 19+  put ASSIGN   = byte 20+  put READ     = byte 21+  put INPUT    = byte 22+  put MARK     = byte 23+  put (GETMARK x) = do+                    n <- getMark x+                    byte 24+                    putZ n+  put GOTO     = byte 25+  put JZ       = byte 26+  put JNZ      = byte 27+  put JGT      = byte 28+  put JLT      = byte 29+  put JGE      = byte 30+  put JLE      = byte 31+  put ARRAY    = byte 32+  put READ_ARRAY   = byte 33+  put ASSIGN_ARRAY = byte 34++  get = do+    c <- getZ :: Get Word8+    case c of+      0 -> return NOP+      1 -> PUSH <$> get+      2 -> return DROP+      3 -> return DUP+      4 -> return SWAP+      5 -> return OVER+      6 -> return PRINT+      7 -> return PRINTALL+      8 -> return ADD+      9 -> return MUL+      10 -> return DIV+      11 -> return REM+      12 -> return SUB+      13 -> return NEG+      14 -> return ABS+      15 -> return CMP+      16 -> return DEFINE+      17 -> return COLON+      18 -> CALL <$> (wordName =<< getZ)+      19 -> return VARIABLE+      20 -> return ASSIGN+      21 -> return READ+      22 -> return INPUT+      23 -> return MARK+      24 -> GETMARK <$> (markName =<< getZ)+      25 -> return GOTO+      26 -> return JZ+      27 -> return JNZ+      28 -> return JGT+      29 -> return JLT+      30 -> return JGE+      31 -> return JLE+      32 -> return ARRAY+      33 -> return READ_ARRAY+      34 -> return ASSIGN_ARRAY+      _ -> fail $ "Unknown opcode: " ++ show c++instance BinaryState BState StackItem where+  put (SInteger x)     = putZ 'I' >> putZ x+  put (SString x)      = do+                         a <- S.gets bAfterColon+                         if a+                           then do+                                st <- S.get+                                S.put $ st {bAfterColon = False}+                                putZ 'W'+                                w <- allocWord x+                                putZ w+                            else putZ 'S' >> putZ x+  put (SInstruction x) = putZ 'O' >> put x+  put (SArray _)       = fail "Array literals are not supported"+  put (Quote x)        = putZ 'Q' >> put x++  get = do+    c <- getChar8+    case c of+      'I' -> SInteger <$> getZ+      'S' -> SString <$> getZ+      'O' -> SInstruction <$> get+      'Q' -> Quote <$> get+      'W' -> SString <$> (wordName =<< getZ)+      _   -> fail $ "Unknown stack item type: " ++ [c]++instance BinaryState BState [StackItem] where+  put list = forM_ list put++  get = getUntilEOF+    where+      getUntilEOF = do+        b <- isEmpty+        if b+          then return []+          else do+               x <- get+               next <- getUntilEOF+               return (x:next)++-- | Dump bytecode to file+dumpCode :: FilePath -> Code -> IO ()+dumpCode path (Code marks code) = encodeFile path (emptyBState {bMarks = head marks}) code++-- | Load bytecode from file+loadCode :: FilePath -> IO Code+loadCode path = do+  (code, st) <- decodeFile' path emptyBState+  return $ Code [bMarks st] code+
+ Language/SSVM/Interpreter.hs view
@@ -0,0 +1,129 @@++module Language.SSVM.Interpreter+  (interpret,+   runVM,+   runVM',+   traceVM+  ) where++import Control.Monad.State+import qualified Data.Map as M++import Language.SSVM.Types+import Language.SSVM.Operations++-- | Interpret code+interpret :: Code -> VM ()+interpret c@(Code marks code) = do+  t <- gets vmTraceMode+  if t+    then traceStack c+    else interpretWith (interpretOne marks) code++interpretWith :: (StackItem -> VM ()) -> Stack -> VM ()+interpretWith go code = do+  pc <- gets vmPC+  if pc >= length code+    then return ()+    else do+         go (code !! pc)+         interpretWith go code++printItem :: StackItem -> VM ()+printItem i = do+  pc <- gets vmPC+  lift $ putStr $ show pc+  lift $ putStr ".>>\t"+  lift $ putStrLn $ showItem i++traceStack :: Code -> VM ()+traceStack (Code marks code) = do+    lift $ putStrLn $ "Trace marks: " ++ show marks+    lift $ putStrLn $ "Trace code: " ++ show code+    lift $ putStr "Trace stack: "+    printStack+    interpretWith traceOne code+  where+    traceOne i = do+      printItem i+      interpretOne marks i+      printStack+      printCurrentDef++-- | Run VM+runVM :: VM () -> IO ()+runVM forth = evalStateT forth emptyVMState++runVM' :: VMState -> VM () -> IO ()+runVM' st forth = evalStateT forth st++-- | Run VM in trace mode+traceVM :: VM () -> IO ()+traceVM code = runVM' (emptyVMState {vmTraceMode = True}) code++interpretOne :: [Marks] -> StackItem -> VM ()+interpretOne _ (SInteger x) = push x >> step+interpretOne _ (SString x)  = push x >> step+interpretOne m (SInstruction x) = eval m x+interpretOne _ (SArray _) = fail "Array literals are not supported"+interpretOne _ (Quote x) = pushD x >> step++interpretLocal :: Int -> Code -> VM ()+interpretLocal pc code = do+  let oldMarks = cMarks code+      newMarks = shiftMarks pc (last oldMarks)+      code' = code {cMarks = newMarks:oldMarks}+  st <- get+  let oldPC = vmPC st+  put $ st {vmPC = 0}+  interpret code'+  st <- get+  put $ st {vmPC = oldPC}++shiftMarks :: Int -> Marks -> Marks+shiftMarks k = M.map shift+  where+    shift n = n-k++-- | Evaluate one instruction+eval :: [Marks] -> Instruction -> VM ()+eval _ NOP      = step+eval _ (PUSH x) = pushS x >> step+eval _ DROP     = pop >> step+eval _ DUP      = dup >> step+eval _ SWAP     = swap >> step+eval _ OVER     = over >> step+eval _ PRINT    = printF >> step+eval _ PRINTALL = printStack >> step+eval _ ADD      = add >> step+eval _ MUL      = mul >> step+eval _ DIV      = divide >> step+eval _ REM      = remF >> step+eval _ SUB      = sub >> step+eval _ NEG      = neg >> step+eval _ ABS      = absF >> step+eval _ CMP      = cmpF >> step+eval _ DEFINE   = define >> step+eval _ COLON    = push COLON >> step+eval m (CALL s) = do+                  (Definition pc code) <- recall s+--                   lift $ putStrLn $ "Calling to " ++ show pc+                  interpretLocal pc $ Code m code+                  step+eval _ VARIABLE = variable >> step+eval _ ASSIGN   = assign >> step+eval _ READ     = readVar >> step+eval _ INPUT    = input >> step+eval _ MARK     = mark >> step+eval m (GETMARK x) = getMark m x >> step+eval _ GOTO     = goto+eval _ JZ       = jumpIf (== 0)+eval _ JNZ      = jumpIf (/= 0)+eval _ JGT      = jumpIf (> 0)+eval _ JLT      = jumpIf (< 0)+eval _ JGE      = jumpIf (>= 0)+eval _ JLE      = jumpIf (<= 0)+eval _ ARRAY    = allocArray >> step+eval _ READ_ARRAY   = readArray   >> step+eval _ ASSIGN_ARRAY = assignArray >> step+
+ Language/SSVM/Operations.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Language.SSVM.Operations+  (push, pushS, pushD,+   pop, dup, swap, over,+   printStack, printCurrentDef, printF,+   add, sub, neg, mul, divide, absF,+   remF, cmpF,+   variable, recall, assign, readVar, define,+   allocArray, readArray, assignArray,+   goto, jumpIf,+   mark, getMark,+   input,+   step+  ) where++import Data.Data+import Data.Char+import Data.Array+import qualified Data.Map as M+import Control.Monad.State++import Language.SSVM.Types++-- | Increment PC+step :: VM ()+step = do+  st <- get+  let was = vmPC st+  put $ st {vmPC = was + 1}++-- | Change stack with given function+withStack :: (Stack -> Stack) -> VM ()+withStack fn = do+  st <- get+  let stk = vmStack st+  setStack (fn stk)++-- | Change stack with given monadic action+withStackM :: (Stack -> VM Stack) -> VM ()+withStackM fn = do+  st <- get+  let stk = vmStack st+  stk' <- fn stk+  setStack stk'++-- | Set VM stack+setStack :: Stack -> VM ()+setStack stk = do+  st <- get+  put $ st { vmStack = stk }++-- | Push value to the stack+push :: (StackType a) => a -> VM ()+push x = withStack (toStack x:)++-- | Push stack item to the stack+pushS :: StackItem -> VM ()+pushS x = withStack (x:)++-- | Add item to current definition+pushD :: StackItem -> VM ()+pushD x = do+  st <- get+  let def = vmCurrentDefinition st+  put $ st {vmCurrentDefinition = (x:def)}++-- | Empty current definition+endDef :: VM ()+endDef = do+  st <- get+  put $ st {vmCurrentDefinition = []}++-- | Drop stack head+-- (a -- )+pop :: VM ()+pop = withStackM pop'+  where+    pop' [] = fail "DROP on empty stack!"+    pop' (x:xs) = return xs++-- | Duplicate stack head+-- (a -- a a)+dup :: VM ()+dup = withStackM dup'+  where+    dup' [] = fail "DUP on empty stack!"+    dup' (x:xs) = return (x:x:xs)++-- | Swap two top items on the stack+-- (a b -- b a)+swap :: VM ()+swap = withStackM swap'+  where+    swap' [] = fail "SWAP on empty stack!"+    swap' [_] = fail "SWAP on single-element stack!"+    swap' (x:y:xs) = return (y:x:xs)++-- | (a b -- a b a)+over :: VM ()+over = withStackM over'+  where+    over' [] = fail "OVER on empty stack!"+    over' [_] = fail "OVER on single-element stack!"+    over' (x:y:xs) = return (y:x:y:xs)++-- | Print stack content+printStack :: VM ()+printStack = do+  stk <- gets vmStack+  lift $ putStrLn $ unwords $ map showPrint stk++-- | Print current definition+printCurrentDef :: VM ()+printCurrentDef = do+  def <- gets vmCurrentDefinition+  lift $ putStr "Current definition: "+  lift $ putStrLn $ unwords $ map showItem (reverse def)++-- | Get stack head (and drop it from stack)+-- (a -- )+getStack :: VM StackItem+getStack = do+  stk <- gets vmStack+  case stk of+    [] -> fail "Trying to get element from empty stack!"+    (x:xs) -> do+              setStack xs+              return x++-- | Get stack head (and drop it from stack)+getArg :: forall a. (StackType a) => VM a+getArg = do+  stk <- gets vmStack+  case stk of+    [] -> fail "Trying to get element from empty stack!"+    (x:xs) -> case fromStack x of+                Just r -> do+                          setStack xs+                          return r+                Nothing -> fail $ "Stack type error: got " ++ showType x +++                                  " while expecting " ++ show (typeOf (undefined :: a))++-- | Run given function on stack head+-- (a -- f(a))+liftF :: (StackType a) => (a -> a) -> VM ()+liftF fn = do+  x <- getArg+  push (fn x)++-- | Run given operation on two top stack items+-- (a b -- a `op` b)+liftF2 :: (StackType a) => (a -> a -> a) -> VM ()+liftF2 op = do+  y <- getArg+  x <- getArg+  let result = x `op` y+  push result++add :: VM ()+add = liftF2 ((+) :: Integer -> Integer -> Integer)++sub :: VM ()+sub = liftF2 ((-) :: Integer -> Integer -> Integer)++neg :: VM ()+neg = liftF ((\x -> -x) :: Integer -> Integer)++absF :: VM ()+absF = liftF (abs :: Integer -> Integer)++mul :: VM ()+mul = liftF2 ((*) :: Integer -> Integer -> Integer)++divide :: VM ()+divide = liftF2 (div :: Integer -> Integer -> Integer)++remF :: VM ()+remF = liftF2 (mod :: Integer -> Integer -> Integer)++cmpF :: VM ()+cmpF = do+    y <- getStack+    x <- getStack+    case (x,y) of+      (SInteger a, SInteger b) -> push (cmp a b)+      (SString a, SString b) -> push (cmp a b)+      _ -> fail $ "Invalid types on CMP: " ++ showType x ++ ", " ++ showType y+  where+    cmp :: (Ord a) => a -> a -> Integer+    cmp a b = case compare a b of+               LT -> -1+               EQ -> 0+               GT -> 1++-- | Print stack head+-- (a -- )+printF :: VM ()+printF = do+  x <- getStack+  lift $ putStr $ showPrint x++-- | Define word+define :: VM ()+define = do+    ws <- gets vmCurrentDefinition+    endDef+    w <- getStack+    col <- getStack+    when (col /= SInstruction COLON) $+      fail $ "No COLON before DEFINE!"+    case w of+      SString name -> do+        st <- get+        dict <- gets vmDefinitions+        pc <- gets vmPC+        let start = pc - length ws+            dict' = M.insert name (Definition start $ reverse ws) dict+        put $ st {vmDefinitions = dict'}+      x -> fail $ "New word name is " ++ showType x ++ ", not String!"++-- | Recall word definition+recall :: String -> VM Definition+recall name = do+  dict <- gets vmDefinitions+  case M.lookup name dict of+    Nothing -> fail $ "Unknown word: " ++ name+    Just list -> return list++-- | Define variable+variable :: VM ()+variable = do+  name <- getArg+  col <- getStack+  when (col /= SInstruction COLON) $+    fail $ "No COLON before VARIABLE!"+  st <- get+  pc <- gets vmPC+  let n = vmNextVariable st+      dict = M.insert name (Definition (pc-1) [SInteger $ fromIntegral n]) (vmDefinitions st)+  put $ st {vmDefinitions = dict, vmNextVariable = n+1}++-- | Assign value to variable+-- (value variable-number -- )+assign :: VM ()+assign = do+  n <- getArg+  value <- getStack+  st <- get+  let vars = M.insert n value (vmVariables st)+  put $ st {vmVariables = vars}++-- | Read variable value+-- (variable-number -- value)+readVar :: VM ()+readVar = do+  n <- getArg+  vars <- gets vmVariables+  case M.lookup n vars of+    Nothing -> fail $ "Trying to read variable before assignment: #" ++ show n+    Just value -> pushS value++-- | Allocate an array+-- (size variable-number -- )+allocArray :: VM ()+allocArray = do+  a  <- getArg+  sz <- getArg :: VM Int+  st <- get+  let arr = listArray (1,sz) (replicate sz $ SInteger 0)+      vars = M.insert a (SArray arr) (vmVariables st)+  put $ st {vmVariables = vars}++-- | Assign value to array item.+-- (value array-or-variable-number index -- )+assignArray :: VM ()+assignArray = do+  i <- getArg+  a <- getStack+  value <- getStack+  case a of+    SInteger n -> do+      st <- get+      let v = fromIntegral n :: Int+          vars = vmVariables st+      case M.lookup v vars of+        Just (SArray arr) -> do+                      let vars' = M.insert v (SArray (arr // [(i, value)])) vars+                      put $ st {vmVariables = vars'}+        Just x ->  fail $ "[!]: variable type is " ++ showType x ++ ", not Array!"+        Nothing -> fail $ "Trying to assign array item before array allocation!"+    SArray arr ->  push $ arr // [(i, value)]+    _ ->           fail $ "[!]: second argument is not array nor variable number, but " ++ showType a++-- | Read item from array.+-- (array-or-variable-number index -- value)+readArray :: VM ()+readArray = do+  i <- getArg+  a <- getStack+  case a of+    SInteger n -> do+      st <- get+      let v = fromIntegral n :: Int+          vars = vmVariables st+      case M.lookup v vars of+        Just (SArray arr) -> pushS (arr ! i)+        Just x ->   fail $ "[@]: variable type is " ++ showType x ++ ", not Array!"+        Nothing ->  fail "Trying to read array item before array allocation!"+    SArray arr ->   pushS (arr ! i)+    _ ->            fail $ "[@]: second argument is not array nor variable number, but " ++ showType a++-- | Read value from stdin+-- ( -- value)+input :: VM ()+input = do+  str <- lift getLine+  if all isDigit str+    then pushS (SInteger $ read str)+    else pushS (SString str)++-- | Mark at current PC+-- ( -- pc)+mark :: VM ()+mark = do+  pc <- gets vmPC+  pushS (SInteger $ fromIntegral pc)++-- | Go to named instruction+branch :: Int -> VM ()+branch n = do+  st <- get+  put $ st {vmPC = n}++-- | Get PC from stack+-- (pc -- )+goto :: VM ()+goto = do+  n <- getArg :: VM Integer+  branch (fromIntegral n)++-- | Jump to given address if condition is satisfied+jumpIf :: (Integer -> Bool) -> VM ()+jumpIf test = do+  addr <- getArg :: VM Integer+  cond <- getStack+  case cond of+    SInteger i -> if test i+                    then branch (fromIntegral addr)+                    else step+    _ -> fail $ "Condition value is " ++ showType cond ++ ", not Integer!"++-- | Get mark by name+-- ( -- pc)+getMark :: [Marks] -> String -> VM ()+getMark [] _ = fail $ "Internal error: getMark with empty marks stack!"+getMark (marks:_) name = do+  case M.lookup name marks of+    Just x -> pushS (SInteger $ fromIntegral x)+    Nothing -> fail $ "Undefined mark: " ++ name+
+ Language/SSVM/Parser.hs view
@@ -0,0 +1,159 @@++module Language.SSVM.Parser+  (parseVM, parseSourceFile) where++import Data.Monoid+import qualified Data.Map as M+import Text.Parsec+import Text.Parsec.Token+import Text.Parsec.Language++import Language.SSVM.Types++baseLanguage = haskell++data ParserState = PState {+  inDefinition :: Bool,+  newWord :: Bool,+  wordsCounter :: Int }+  deriving (Eq, Show)++emptyState = PState {+  inDefinition = False,+  newWord = False,+  wordsCounter = 0 }++type TParser a = Parsec String ParserState a++code :: [StackItem] -> TParser Code+code list = return $ Code [M.empty] list++startDefinition :: TParser ()+startDefinition = do+  st <- getState+  putState $ st {inDefinition = True, newWord = True}++endDefinition :: TParser ()+endDefinition = do+  st <- getState+  putState $ st {inDefinition = False, newWord = False}++pString :: TParser Code+pString = do+  st <- getState+  str <- stringLiteral baseLanguage+  if newWord st+    then do+         putState $ st {newWord = False}+         code [SString str]+    else if inDefinition st+           then code [Quote $ SString str]+           else code [SString str]++pInteger :: TParser Code+pInteger = do+  m <- optionMaybe (char '-')+  digits <- many1 digit+  let s = read digits+      n = case m of+            Nothing -> s+            Just _  -> -s+  st <- getState+  if inDefinition st+    then code [Quote $ SInteger n]+    else code [SInteger n]++addMark :: String -> TParser Code+addMark name = do+  st <- getState+  let addr = wordsCounter st+  return $ Code [M.singleton name addr] []++instr :: Instruction -> TParser Code+instr i = do+  st <- getState+  if inDefinition st+    then code [Quote (SInstruction i)]+    else code [SInstruction i]++pWord :: TParser Code+pWord = do+  word <- many1 (noneOf " \t\r\n")+  case word of+    "NOP"  -> instr NOP+    "DROP" -> instr DROP+    "DUP" ->  instr DUP+    "SWAP" -> instr SWAP+    "OVER" -> instr OVER+    "." ->    instr PRINT+    ".." ->   instr PRINTALL+    "+" ->    instr ADD+    "-" ->    instr SUB+    "*" ->    instr MUL+    "/" ->    instr DIV+    "REM" ->  instr REM+    "NEG" ->  instr NEG+    "ABS" ->  instr ABS+    "CMP" ->  instr CMP+    ";" ->    endDefinition >> code [SInstruction DEFINE]+    ":" ->    startDefinition >> code [SInstruction COLON]+    "VARIABLE" -> endDefinition >> code [SInstruction VARIABLE]+    "!" ->    instr ASSIGN+    "@" ->    instr READ+    "INPUT" -> instr INPUT+    "MARK" -> instr MARK+    "GOTO" -> instr GOTO+    "JZ"   -> instr JZ+    "JNZ"  -> instr JNZ+    "JGT"  -> instr JGT+    "JLT"  -> instr JLT+    "JGE"  -> instr JGE+    "JLE"  -> instr JLE+    "ARRAY" -> instr ARRAY+    "[@]"   -> instr READ_ARRAY+    "[!]"   -> instr ASSIGN_ARRAY+    _ | head word == '@' -> instr (GETMARK $ tail word)+      | otherwise -> do+         st <- getState+         if newWord st+           then do+                putState $ st {newWord = False}+                code [SString word]+           else if inDefinition st+                  then code [Quote $ SInstruction $ CALL word]+                  else code [SInstruction $ CALL word]++pLabel :: TParser Code+pLabel = do+  char '.'+  name <- many1 (noneOf ". \t\r\n")+  addMark name++step :: Int -> TParser ()+step k = do+  st <- getState+  putState $ st {wordsCounter = k + wordsCounter st}++pSpaces :: TParser Code+pSpaces = do+  many1 (oneOf " \t\r\n")+  code []++pSource :: TParser Code+pSource = do+    ws <- many1 anyWord+    return (mconcat ws)+  where+    anyWord = do+      word <- (try pSpaces <|> try pString <|> try pInteger <|> try pLabel <|> pWord)+      step (length $ cCode word)+      return word++parseVM :: FilePath -> String -> Either ParseError Code+parseVM name str = runParser pSource emptyState name str++parseSourceFile :: FilePath -> IO (Either ParseError Code)+parseSourceFile path = do+  str <- readFile path+  return $ runParser pSource emptyState path str+
+ Language/SSVM/Types.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}+module Language.SSVM.Types where++import Control.Monad.State+import Data.Data+import Data.Monoid+import Data.Array+import qualified Data.Map as M++type DArray = Array Int StackItem++-- | Stack item+data StackItem =+    SInteger Integer+  | SString String+  | SInstruction Instruction+  | SArray DArray+  | Quote StackItem+  deriving (Eq, Data, Typeable)++-- | Show type of item+showType :: StackItem -> String+showType x = show (toConstr x)++instance Show StackItem where+  show (SInteger x) = show x+  show (SString s)  = show s+  show (SArray a)   = "[" ++ unwords (map show $ elems a) ++ "]"+  show (SInstruction i) = show i+  show (Quote x)    = show x++showItem :: StackItem -> String+showItem = show++showPrint :: StackItem -> String+showPrint (SInteger x) = show x+showPrint (SString s)  = s+showPrint (SArray a)   = "[" ++ unwords (map show $ elems a) ++ "]"+showPrint (SInstruction i) = show i+showPrint (Quote x)    = show x++showCode :: Code -> String+showCode (Code marks code) =+    unwords $  zipWith (showOne $ head marks) [1..] code+  where+    showOne ms n item = showItem item ++ concatMap (" ."++) (lookupRev n $ M.assocs ms)++    lookupRev _ [] = []+    lookupRev key ((v,k):other) +                  | key == k  = v: lookupRev key other+                  | otherwise = lookupRev key other+    +type Stack = [StackItem]++type Marks = M.Map String Int++showMarks :: Marks -> String+showMarks ms = unlines $ map s $ M.assocs ms+  where+    s (k,v) = "\t" ++ k ++ ": " ++ show v++-- | VM code+data Code = Code {+  cMarks :: [Marks],   -- ^ marks stack+  cCode :: [StackItem] }+  deriving (Eq, Show, Data, Typeable)++instance Monoid Code where+  mempty = Code [M.empty] []+  mappend (Code l1 c1) (Code l2 c2) = Code (M.union m1 m2: ms) (c1 ++ c2)+    where+      (m1:ms) = l1+      (m2:_)  = l2++class (Data a, Typeable a) => StackType a where+  toStack :: a -> StackItem+  fromStack :: StackItem -> Maybe a++instance StackType Integer where+  toStack = SInteger++  fromStack (SInteger x) = Just x+  fromStack _ = Nothing++instance StackType Int where+  toStack = SInteger . fromIntegral++  fromStack (SInteger x) = Just (fromIntegral x)+  fromStack _            = Nothing++instance StackType String where+  toStack = SString++  fromStack (SString x) = Just x+  fromStack _ = Nothing++instance StackType Instruction where+  toStack = SInstruction++  fromStack (SInstruction x) = Just x+  fromStack _ = Nothing++instance StackType DArray where+  toStack = SArray++  fromStack (SArray a) = Just a+  fromStack _          = Nothing++-- | VM instructions+data Instruction =+    NOP            -- ^ Do nothing+  | PUSH StackItem+  | DROP+  | DUP+  | SWAP+  | OVER+  | PRINT+  | PRINTALL+  | ADD+  | MUL+  | DIV+  | REM+  | SUB+  | NEG+  | ABS+  | CMP+  | DEFINE+  | COLON+  | CALL String     -- ^ Call named user-defined word+  | VARIABLE+  | ASSIGN+  | READ+  | INPUT+  | MARK+  | GETMARK String+  | GOTO+  | JZ+  | JNZ+  | JGT+  | JLT+  | JGE+  | JLE+  | ARRAY+  | READ_ARRAY+  | ASSIGN_ARRAY+  deriving (Eq, Data, Typeable)++instance Show Instruction where+  show NOP = "NOP"+  show (PUSH x) = show x+  show DROP     = "DROP"+  show DUP      = "DUP"+  show SWAP     = "SWAP"+  show OVER     = "OVER"+  show PRINT    = "."+  show PRINTALL = ".."+  show ADD      = "+"+  show MUL      = "*"+  show DIV      = "/"+  show REM      = "REM"+  show SUB      = "-"+  show NEG      = "NEG"+  show ABS      = "ABS"+  show CMP      = "CMP"+  show DEFINE   = ";"+  show COLON    = ":"+  show (CALL s) = s+  show VARIABLE = "VARIABLE"+  show ASSIGN   = "!"+  show READ     = "@"+  show INPUT    = "INPUT"+  show MARK     = "MARK"+  show (GETMARK x) = "@" ++ x+  show GOTO     = "GOTO"+  show JZ       = "JZ"+  show JNZ      = "JNZ"+  show JGT      = "JGT"+  show JLT      = "JLT"+  show JGE      = "JGE"+  show JLE      = "JLE"+  show ARRAY    = "ARRAY"+  show READ_ARRAY   = "[@]"+  show ASSIGN_ARRAY = "[!]"++-- | Word definition+data Definition = Definition Int Stack+  deriving (Eq, Show)++-- | VM state+data VMState = VMState {+  vmStack :: Stack,                         -- ^ current VM stack+  vmCurrentDefinition :: Stack,             -- ^ current definition+  vmDefinitions :: M.Map String Definition, -- ^ already defined words+  vmVariables :: M.Map Int StackItem,       -- ^ variables values+  vmNextVariable :: Int,                    -- ^ next variable number+  vmPC :: Int,                              -- ^ program counter+  vmTraceMode :: Bool                       -- ^ trace mode+  }+  deriving (Eq, Show)++-- | Starting VM state+emptyVMState :: VMState+emptyVMState = VMState {+  vmStack = [],+  vmCurrentDefinition = [],+  vmDefinitions = M.empty,+  vmVariables = M.empty,+  vmNextVariable = 0,+  vmPC = 0,+  vmTraceMode = False }++-- | VM monad+type VM a = StateT VMState IO a+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ simple-stacked-vm.cabal view
@@ -0,0 +1,33 @@+Name:           simple-stacked-vm+Version:        0.1+Cabal-Version:  >= 1.6+License:        BSD3+License-File:   LICENSE+Author:         Ilya V. Portnov+Maintainer:     portnov84@rambler.ru+Synopsis:       Simple stacked virtual machine: assembler, disassembler, bytecode interpreter+Category:       Languages, Compilers/Interpreters+Build-Type:     Simple+Description:    This is a simple stacked virtual machine. It works like Forth or JVM.+                This package includes declarations of data types, assembler, disassembler, +                and bytecode interpreter.++Extra-source-files: test.f++library+  Exposed-Modules: Language.SSVM.Types+                   Language.SSVM.Parser+                   Language.SSVM.Operations+                   Language.SSVM.Interpreter+                   Language.SSVM.Binary++  Build-Depends:  base >= 3 && <= 5, containers,+                  mtl > 1, filepath, parsec >= 3,+                  binary-state, array++  ghc-options: -fwarn-unused-imports++executable ssvm+  Main-is: ssvm.hs++
+ ssvm.hs view
@@ -0,0 +1,131 @@++import Control.Monad (when)+import System.Environment+import System.Console.GetOpt+import System.FilePath+import System.IO++import Language.SSVM.Types+import Language.SSVM.Parser+import Language.SSVM.Interpreter+import Language.SSVM.Binary++-- | Command-line flag+data Flag =+    Mode Mode+  | Output FilePath+  deriving (Eq, Show)++-- | Working mode+data Mode =+    Interpret+  | Trace+  | TraceBytecode+  | Compile+  | Run+  | Decompile+  | Help+  deriving (Eq, Show)++-- | config+data RunMode = RunMode {+  mode :: Mode,+  inputFile :: FilePath,+  outputFile :: Maybe FilePath }+  deriving (Eq, Show)++-- | Default run mode+defaultMode :: RunMode+defaultMode = RunMode {+  mode = Run,+  inputFile = "-",+  outputFile = Nothing }++-- | Command-line options description+options :: [OptDescr Flag]+options = [+  Option "c" ["compile"]   (NoArg $ Mode Compile)   "compile source code to bytecode",+  Option "i" ["interpret"] (NoArg $ Mode Interpret) "interpret source code",+  Option "e" ["run"]       (NoArg $ Mode Run)       "run compiled bytecode",+  Option "d" ["decompile"] (NoArg $ Mode Decompile) "decompile bytecode into pseudo source code",+  Option "t" ["trace"]     (NoArg $ Mode Trace)     "interpret and trace source code ",+  Option ""  ["trace-bytecode"] (NoArg $ Mode TraceBytecode)     "run and trace bytecode ",+  Option "o" ["output"]    (ReqArg Output "FILE")   "set output file name",+  Option "h" ["help"]      (NoArg $ Mode Help)      "show this help and exit" ]++usage :: String+usage = usageInfo header options+  where+    header = "Usage: ssvm [MODE] [-o OUTPUT] FILE"++flags2runmode :: [Flag] -> RunMode+flags2runmode flags = foldl go defaultMode flags+  where+    go acc (Mode m)      = acc {mode = m}+    go acc (Output path) = acc {outputFile = Just path}++parseCmdLine :: [String] -> Either String RunMode+parseCmdLine args =+  case getOpt Permute options args of+    (flags, [], []) | Mode Help `elem` flags -> Right (flags2runmode flags)+                    | otherwise              -> Left "No input file"+    (flags, [file], []) -> Right $ (flags2runmode flags) {inputFile = file}+    (_, (_:_:_), [])    -> Left "More than one input file"+    (_, _, errs)        -> Left $ unlines errs ++ usage++doInterpret :: FilePath -> IO ()+doInterpret path = do+  mbCode <- parseSourceFile path+  case mbCode of+    Left err -> fail (show err)+    Right code -> runVM (interpret code)++doTrace :: FilePath -> IO ()+doTrace path = do+  mbCode <- parseSourceFile path+  case mbCode of+    Left err -> fail (show err)+    Right code -> traceVM (interpret code)++doTraceBytecode :: FilePath -> IO ()+doTraceBytecode path = do+  code <- loadCode path+  traceVM (interpret code)++doCompile :: FilePath -> Maybe FilePath -> IO ()+doCompile src mbdst = do+  let dst = case mbdst of+              Just x -> x+              Nothing -> replaceExtension src ".bytecode"+  mbCode <- parseSourceFile src+  case mbCode of+    Left err -> fail (show err)+    Right code -> dumpCode dst code++doRun :: FilePath -> IO ()+doRun path = do+  code <- loadCode path+  runVM (interpret code)++doDecompile :: FilePath -> IO ()+doDecompile path = do+    code <- loadCode path+    putStrLn $ showCode code++main = do+  args <- getArgs+  case parseCmdLine args of+    Left err -> error err+    Right m -> do+      term <- hIsTerminalDevice stdout+      when term $+        hSetBuffering stdout NoBuffering+      case mode m of+        Interpret -> doInterpret (inputFile m)+        Compile   -> doCompile (inputFile m) (outputFile m)+        Run       -> doRun (inputFile m)+        Decompile -> doDecompile (inputFile m) +        Trace     -> doTrace (inputFile m) +        TraceBytecode -> doTraceBytecode (inputFile m) +        Help      -> putStrLn usage+
+ test.f view
@@ -0,0 +1,40 @@+: CR "\n" . ;+: INC DUP @ 1 + SWAP ! ;+: ODD 2 REM ;+: ? @ . ;++: PRINT_ODD+  DUP @ ODD+  @even JZ+  ? " is odd." .+  @endprint GOTO+  .even+  ? " is even." .+  .endprint+  CR+  ;++: n VARIABLE+: i VARIABLE+: arr VARIABLE++5 arr ARRAY+17 arr 3 [!]+"test" arr 4 [!]+"abc" arr @ 2 [!] arr !+arr ? CR+arr 3 [@] . CR++"Enter number: " .+INPUT n !++0 i !+.loop+"Hello." . CR+i PRINT_ODD+i INC+i @ n @ CMP+@loop JLT++"End" . CR+