release(v0.4): inline registers

HLasm.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.1.
+-- This file has been generated from package.yaml by hpack version 0.34.2.
 --
 -- see: https://github.com/sol/hpack
 
 name:           HLasm
-version:        0.3.0.0
+version:        0.4.0.0
 description:    Please see the README on GitHub at <https://github.com/vorotynsky/HLasm#readme>
 homepage:       https://github.com/vorotynsky/HLasm#readme
 bug-reports:    https://github.com/vorotynsky/HLasm/issues

package.yaml

@@ -1,5 +1,5 @@
 name:                HLasm
-version:             0.3.0.0
+version:             0.4.0.0
 github:              "vorotynsky/HLasm"
 license:             GPL-3
 author:              "Vorotynsky Maxim"

src/HLasm/Ast.hs

@@ -21,27 +21,34 @@ data CompareType =
     | Less
     deriving (Show, Eq)
 
-data HLValue = 
+data LValue =
     NameValue VariableName
+    | RegisterValue RegisterName
+    deriving (Eq)
+
+data RValue =
+    LeftValue LValue
     | IntegerValue Int
-    | StringValue String
     deriving (Eq)
 
-instance Show HLValue where
-    show (NameValue   name) = name
+instance Show LValue where
+    show (NameValue     name) = name
+    show (RegisterValue name) = '%':name
+
+instance Show RValue where
+    show (LeftValue  value) = show value
     show (IntegerValue num) = show num
-    show (StringValue  str) = show str
 
-data Condition = Condition (HLValue, CompareType, HLValue)
+data Condition = Condition (RValue, CompareType, RValue)
     deriving (Show, Eq)
 
 data HLElement = 
     Program
     | InstructionSet
     | RegisterDeclaration  VariableName RegisterName
     | VariableDeclaration  VariableName Type
-    | GlobalVarDeclaration VariableName Type HLValue
-    | ConstVarDeclaration  VariableName Type HLValue
+    | GlobalVarDeclaration VariableName Type RValue
+    | ConstVarDeclaration  VariableName Type RValue
     | FakeVariable         VariableName
     | FakeFrame            Label
     | Frame (Maybe Label)
@@ -50,11 +57,12 @@ data HLElement =
     | While Label
     | DoWhile Label
     | Break Label
-    | Call Label [VariableName]
-    | Assignment VariableName HLValue
+    | Call Label [RValue]
+    | Assignment LValue RValue
     | AssemblyCall String
     deriving (Show, Eq)
 
+
 getValuableName :: HLElement -> Maybe VariableName
 getValuableName (VariableDeclaration  name _  ) = Just name
 getValuableName (RegisterDeclaration  name _  ) = Just name
@@ -68,13 +76,17 @@ isVariable = isJust . getValuableName
 variableName :: HLElement -> VariableName
 variableName = fromJust . getValuableName
 
+variableNameValue :: RValue -> Maybe VariableName
+variableNameValue (LeftValue (NameValue name)) = Just name
+variableNameValue _                            = Nothing
+
 usedVariables :: HLElement -> [VariableName]
 usedVariables (IfBranch (Just (Condition(left, _, right)))) = name left ++ name right
-    where name (NameValue name) = [name]
-          name _                = []
-usedVariables (Call _ xs)                         = xs
-usedVariables (Assignment left (NameValue right)) = [left, right]
-usedVariables (Assignment left _)                 = [left]
+    where name (LeftValue (NameValue name)) = [name]
+          name _                            = []
+usedVariables (Call _ xs)                         = fromMaybe [] $ traverse variableNameValue xs
+usedVariables (Assignment left (LeftValue right)) = concatMap (maybeToList . variableNameValue . LeftValue) [left, right]
+usedVariables (Assignment left _)                 = fromMaybe [] $ traverse (variableNameValue . LeftValue) [left]
 usedVariables _                                   = []
 
 usedLabels :: HLElement -> [Label]

src/HLasm/Error.hs

@@ -10,7 +10,7 @@ data Error =
     | ParseError Text.Parsec.ParseError
     | VariableNotFound VariableName
     | LabelNotFound Label
-    | IncompatibleTypes (HLValue, HLValue)
+    | IncompatibleTypes (RValue, RValue)
     | GlobalVariableInFrame VariableName
     deriving (Eq)
 

src/HLasm/Instructions.hs

@@ -17,6 +17,7 @@ import           HLasm.Ast
 import           HLasm.Frame
 import           HLasm.Scope
 import           HLasm.Error
+import           HLasm.Types
 
 type Offset = Int
 type Size = Int
@@ -41,7 +42,7 @@ data Instructions =
 
 type InstructionSet = [Instructions]
 
-data Variable = Variable VariableName Type HLValue
+data Variable = Variable VariableName Type RValue
 
 data Section =
     Text InstructionSet
@@ -63,20 +64,25 @@ target frame (VariableData (name, e)) = case findOffset frame name of
 findTarget :: StackFrame -> [VariableData] -> VariableName -> Target --  was a lot of checks, target garanteed be here.
 findTarget frame xs name = target frame . fromJust . find (\(VariableData (n, _)) -> n == name) $ xs
 
-valuableTarget :: (StackFrame, [VariableData]) -> HLValue -> Target
-valuableTarget _        (IntegerValue v) = ConstantTarget v
-valuableTarget (sf, vd) (NameValue name) = findTarget sf vd name
+valuableTarget :: (StackFrame, [VariableData]) -> RValue -> Target
+valuableTarget _        (IntegerValue v)                = ConstantTarget v
+valuableTarget (sf, vd) (LeftValue(NameValue name))     = findTarget sf vd name
+valuableTarget (sf, vd) (LeftValue(RegisterValue name)) = Register name
 
 loop :: Label -> Result (InstructionSet) -> Result (InstructionSet)
 loop lbl i = let begin = lbl ++ "begin" in fmap (\x -> [Label begin] ++ x ++ [Jump begin Nothing, Label (lbl ++ "end")]) $ i
 
 isEmptyInstruction :: HLElement -> Bool
-isEmptyInstruction (FakeVariable _)       = True
-isEmptyInstruction (FakeFrame _)          = True
+isEmptyInstruction (FakeVariable _)          = True
+isEmptyInstruction (FakeFrame _)             = True
 isEmptyInstruction (VariableDeclaration _ _) = True
 isEmptyInstruction (RegisterDeclaration _ _) = True
 isEmptyInstruction _                         = False
 
+rval2target :: RValue -> StackFrame -> [VariableData] -> Target
+rval2target (IntegerValue val)               _ _ = ConstantTarget val
+rval2target (LeftValue (RegisterValue name)) _ _ = Register name
+rval2target (LeftValue (NameValue     name)) s d = findTarget s d name
 
 instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet)
 instructions (Node (el, _, _, _) _) | isEmptyInstruction el = Right []
@@ -91,12 +97,12 @@ instructions (Node ((Frame lbl              ), _, _, f) xs) =
 instructions (Node ((GlobalVarDeclaration n _ _), _, _, _) _ ) = Left (GlobalVariableInFrame n)
 instructions (Node ((ConstVarDeclaration n _ _), _, _, _) _ )  = Left (GlobalVariableInFrame n)
 
-instructions (Node ((Assignment name (NameValue val)),    d, _, f) _) = Right [Move (findTarget f d name) (findTarget f d val)]
-instructions (Node ((Assignment name (IntegerValue val)), d, _, f) _) = Right [Move (findTarget f d name) (ConstantTarget val)]
+instructions (Node ((Assignment left right), d, _, f) _) 
+    = Right [Move (rval2target (LeftValue left) f d) (rval2target right f d)]
 
 instructions (Node ((HLasm.Ast.Call lbl ns  ), d, _, f) _ ) = 
-    Right [HLasm.Instructions.Call lbl (fmap (findTarget f d) ns) size]
-    where size = foldl (+) 0 . fmap (\(VariableData (_, d)) -> stackVarSize d) $ d
+    Right [HLasm.Instructions.Call lbl (fmap (\n -> rval2target n f d) ns) size]
+    where size = foldl (+) 0 . fmap (fromMaybe 0 . fmap getSize . literalType d) $ ns
 
 instructions (Node ((If lbl), _, _, _) []) = Right []
 instructions (Node ((If lbl), _, _, _) xs) =

src/HLasm/Parser.hs

@@ -39,18 +39,21 @@ braces = around '{' '}'
 name :: Parser String
 name = (:) <$> letter <*> many (alphaNum <|> char '_')
 
+lvalue' = ((RegisterValue <$> (char '%' *> name)) <|> (NameValue <$> name))
+lvalue = aparse lvalue'
+rvalue' = (IntegerValue <$> nat) <|> (LeftValue <$> lvalue')
+rvalue = aparse rvalue'
+
 break   = leafP Break        (keyword "break" *> parens name)
 asmCall = leafP AssemblyCall (spaces *> char '!' *> many1 (noneOf ";") <* char ';' <* spaces)
-call    = leafP id (Call <$> (keyword "call" *> angles name) <*> parens (name `sepBy` achar ','))
+call    = leafP id (Call <$> (keyword "call" *> angles name) <*> parens (rvalue `sepBy` achar ','))
 
 vtype = Type <$> name <*> (Just <$> parens nat)
 register = leafP id . aparse $ RegisterDeclaration <$> (keyword "reg" *> name) <*> (achar ':' *> name )
 variable = leafP id . aparse $ VariableDeclaration <$> (keyword "var" *> name) <*> (achar ':' *> vtype)
 
-value = (IntegerValue <$> aparse nat) <|> (NameValue <$> aparse name)
-
-assignment = leafP id (Assignment <$> name <*> (achar '=' *> value))
-condition = curry3 Condition <$> value <*> cond <*> value
+assignment = leafP id (Assignment <$> lvalue <*> (achar '=' *> rvalue))
+condition = curry3 Condition <$> rvalue <*> cond <*> rvalue
     where p x s = const x <$> string s
           cond = p Equals "=="  <|> p NotEquals "!=" <|> p Greater ">" <|> p Less "<"
 
@@ -86,7 +89,7 @@ hlasm = reduce [ asmCall,             call,           HLasm.Parser.break,
                  assignment ]
     where reduce (x:xs) = foldl (<|>) x xs
 
-globalVariable word f = leafP id . aparse $ f <$> (keyword word *> name) <*> (achar ':' *> vtype) <*> (achar '=' *> value)
+globalVariable word f = leafP id . aparse $ f <$> (keyword word *> name) <*> (achar ':' *> vtype) <*> (achar '=' *> rvalue)
 constant = globalVariable "const" ConstVarDeclaration
 globvar  = globalVariable "var"   GlobalVarDeclaration
 

src/HLasm/Types.hs

@@ -28,32 +28,38 @@ registerSize ('e':x)     | elem x sysregs = 32
 registerSize ('r':x)     | elem x sysregs = 64
 registerSize _                            = 0
 
+registerType = Type "int" . Just . registerSize
+
 getType :: HLElement -> Type
 getType (VariableDeclaration _ t)    = t
 getType (ConstVarDeclaration _ t _)  = t
 getType (GlobalVarDeclaration _ t _) = t
 getType (RegisterDeclaration _ r)    = Type "int" (Just (registerSize r))
 getType (FakeVariable _)             = Type "any" Nothing
 
+getSize :: Type -> Int
+getSize (Type "int" (Just size)) = size
+getSize _                        = 0
+
 lookupType :: VariableName -> [VariableData] -> Maybe Type
 lookupType name = fmap getType . lookup name . fmap (\(VariableData x) -> x)
 
-literalType :: [VariableData] -> HLValue -> Maybe Type
+literalType :: [VariableData] -> RValue -> Maybe Type
 literalType _ (IntegerValue x) = Just $ Type "int" (Just $ size x)
     where size = ceiling . (\x -> log (x + 1) / log 2) . toEnum
-literalType s (NameValue name) = lookupType name s
-literalType _ _ = undefined
+literalType s (LeftValue (NameValue     name)) = lookupType name s
+literalType s (LeftValue (RegisterValue name)) = Just $ registerType name
 
 err a b = maybe (Left (a, b)) Right
 
-astCheck :: HLElement -> [VariableData] -> Either (HLValue, HLValue) ()
+astCheck :: HLElement -> [VariableData] -> Either (RValue, RValue) ()
 astCheck (IfBranch (Just (Condition (left, _, right)))) xs =
     do leftType  <- err left right $ literalType xs left
        rightType <- err left right $ literalType xs right
        if typeSuit leftType rightType then Right () else err left right Nothing
 astCheck (Assignment left right) xs =
-    let error = err (NameValue left) right in
-    do leftType  <- error $ lookupType left xs
+    let error = err (LeftValue left) right in
+    do leftType  <- error $ literalType xs (LeftValue left)
        rightType <- error $ literalType xs right
        if typeSuit leftType rightType then Right () else error Nothing
 astCheck _ _ = Right ()