diff --git a/HLasm.cabal b/HLasm.cabal index f3cd983..95592cc 100644 --- a/HLasm.cabal +++ b/HLasm.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.1. +-- This file has been generated from package.yaml by hpack version 0.34.1. -- -- see: https://github.com/sol/hpack --- --- hash: 6cca8ef12b48d6c2337ca3596a778423af51d8f48437da9bec4a4e2770142e12 name: HLasm version: 0.1.0.0 @@ -28,6 +26,7 @@ library exposed-modules: HLasm.Ast HLasm.Backend.Nasm + HLasm.Error HLasm.Frame HLasm.Instructions HLasm.Parser diff --git a/app/Main.hs b/app/Main.hs index 881a45d..7bb31a0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,6 +4,7 @@ module Main where import System.Environment (getArgs) import Control.Monad.Zip +import Data.Bifunctor (first) import Funcs import HLasm.Parser @@ -14,16 +15,16 @@ import HLasm.Instructions (instructions, BackEnd(..), runBackend) import HLasm.Backend.Nasm parseAll :: String -> String -parseAll = get . pipeline +parseAll = get . first show . pipeline where pipeline src = - do parsed <- parse src - semantic <- err "Scope error" semantic parsed - _ <- err "Type error" typeCheck semantic - stack <- Right $ (buildStackFrames Root) parsed - tree <- Right $ mzipWith (\(e, v, l) (_, sf) -> (e, v, l, sf)) semantic stack - instructions <- err "Assembly error" instructions tree - Right . runBackend nasm $ instructions - + do parsed <- parse src + semantic <- semantic parsed + _ <- typeCheck semantic + stack <- Right $ (buildStackFrames Root) parsed + tree <- Right $ mzipWith (\(e, v, l) (_, sf) -> (e, v, l, sf)) semantic stack + instructions <- instructions tree + runBackend nasm instructions + main :: IO () main = do args <- getArgs diff --git a/src/HLasm/Ast.hs b/src/HLasm/Ast.hs index 43cf726..01a292c 100644 --- a/src/HLasm/Ast.hs +++ b/src/HLasm/Ast.hs @@ -33,7 +33,12 @@ data HLValue = NameValue VariableName | IntegerValue Int | StringValue String - deriving (Show, Eq) + deriving (Eq) + +instance Show HLValue where + show (NameValue name) = name + show (IntegerValue num) = show num + show (StringValue str) = show str data Condition = Condition (HLValue, CompareType, HLValue) deriving (Show, Eq) diff --git a/src/HLasm/Backend/Nasm.hs b/src/HLasm/Backend/Nasm.hs index fb4795a..643df60 100644 --- a/src/HLasm/Backend/Nasm.hs +++ b/src/HLasm/Backend/Nasm.hs @@ -55,4 +55,4 @@ join s [x] = x join s (x:xs) = x ++ s ++ join s xs nasm :: BackEnd -nasm = BackEnd (\x -> join "\n" . concat $ fmap instruction x) +nasm = BackEnd (\x -> Right . join "\n" . concat $ fmap instruction x) diff --git a/src/HLasm/Error.hs b/src/HLasm/Error.hs new file mode 100644 index 0000000..4f193e5 --- /dev/null +++ b/src/HLasm/Error.hs @@ -0,0 +1,24 @@ +-- Copyright (c) 2020 Vorotynsky Maxim + +module HLasm.Error where + +import HLasm.Ast +import qualified Text.Parsec + +data Error = + StringError String + | ParseError Text.Parsec.ParseError + | VariableNotFound VariableName + | LabelNotFound Label + | IncompatibleTypes (HLValue, HLValue) + deriving (Eq) + +type Result a = Either Error a + +instance Show Error where + show (StringError msg) = "error: " ++ msg ++ ".\n" + show (VariableNotFound name) = "scope error: variable \'" ++ name ++ "\' not found.\n" + show (LabelNotFound label) = "scope error: label \'" ++ label ++ "\' not found.\n" + show (IncompatibleTypes (left, right)) = + "type error: incompatible types between \'" ++ show left ++ "\' and \'" ++ show right ++ "\'.\n" + show (ParseError err) = "parser error, " ++ show err diff --git a/src/HLasm/Instructions.hs b/src/HLasm/Instructions.hs index bb0176d..66ca01a 100644 --- a/src/HLasm/Instructions.hs +++ b/src/HLasm/Instructions.hs @@ -15,6 +15,7 @@ import Data.Tree import HLasm.Ast import HLasm.Frame import HLasm.Scope +import HLasm.Error type Offset = Int type Size = Int @@ -39,9 +40,10 @@ data Instructions = type InstructionSet = [Instructions] -newtype BackEnd = BackEnd (InstructionSet -> String) +newtype BackEnd = BackEnd (InstructionSet -> Result String) runBackend (BackEnd f) x = f x + target :: StackFrame -> VariableData -> Target target _ (VariableData (_, VariableDeclaration (HLasm.Ast.Register(_, reg)))) = HLasm.Instructions.Register reg target frame (VariableData (name, e)) = case findOffset frame name of @@ -49,42 +51,41 @@ target frame (VariableData (name, e)) = case findOffset frame name of Nothing -> NamedTarget name where size (VariableDeclaration v) = valueSize v -findTarget :: StackFrame -> [VariableData] -> VariableName -> Target +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 _ (IntegerValue v) = ConstantTarget v valuableTarget (sf, vd) (NameValue name) = findTarget sf vd name -loop :: Label -> Maybe (InstructionSet) -> Maybe (InstructionSet) +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 -instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Maybe (InstructionSet) +instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet) instructions (Node ((InstructionSet ), _, _, _) xs) = concatMapM instructions xs -instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Just [] +instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Right [] instructions (Node ((While lbl ), _, _, _) xs) = loop lbl (concatMapM instructions xs) instructions (Node ((DoWhile lbl ), _, _, _) xs) = loop lbl (concatMapM instructions xs) -instructions (Node ((Break lbl ), _, _, _) _ ) = Just [Jump (lbl ++ "end") Nothing] -instructions (Node ((HLasm.Ast.Call lbl ns ), d, _, f) _ ) = - Just [HLasm.Instructions.Call lbl (fmap (findTarget f d) ns) size] - where size = foldl (+) 0 . fmap (\(VariableData (_, (VariableDeclaration d))) -> valueSize d) $ d -instructions (Node ((AssemblyCall str ), _, _, _) _ ) = Just [PureAsm str] +instructions (Node ((Break lbl ), _, _, _) _ ) = Right [Jump (lbl ++ "end") Nothing] +instructions (Node ((AssemblyCall str ), _, _, _) _ ) = Right [PureAsm str] instructions (Node ((Frame lbl ), _, _, f) xs) = - fmap (\x -> [BeginFrame f lbl] ++ x ++ [EndFrame f lbl]) $ concatMapM instructions xs + (\body -> [BeginFrame f lbl] ++ body ++ [EndFrame f lbl]) <$> concatMapM instructions xs -instructions (Node ((Assignment name (NameValue val)), d, _, f) _) = Just [Move (findTarget f d name) (findTarget f d val)] -instructions (Node ((Assignment name (IntegerValue val)), d, _, f) _) = Just [Move (findTarget f d name) (ConstantTarget val)] +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 ((If lbl), _, _, _) []) = Just [] +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 (_, (VariableDeclaration d))) -> valueSize d) $ d + +instructions (Node ((If lbl), _, _, _) []) = Right [] instructions (Node ((If lbl), _, _, _) xs) = - let (conds, bodies') = traverse (uncurry branch) (zip [1..] xs); - bodies = fmap (concat) . sequence $ bodies' - in fmap (\b -> conds ++ b ++ [Label (lbl ++ "end")]) bodies - where condition pt lbl (Condition (left, cmp, right)) = - [Compare (valuableTarget pt left) (valuableTarget pt right), Jump lbl (Just cmp)] - wrapif lbl i = fmap (\b -> [Label (lbl ++ show i)] ++ b ++ [Jump (lbl ++ "end") Nothing]) - branch i (Node ((IfBranch (Just cond)), d, _, f) xs) = - (condition (f, d) (lbl ++ show i) cond, wrapif lbl i (concatMapM instructions xs)) - branch i (Node ((IfBranch Nothing), _, _, _) xs) = - ([Jump (lbl ++ show i) Nothing], wrapif lbl i (concatMapM instructions xs)) - a = traverse (uncurry branch) (zip [1..] xs) + do (conds, bodies') <- Right $ traverse (uncurry branch) (zip [1..] xs) + bodies <- fmap (concat) . sequence $ bodies' + Right $ conds ++ bodies ++ [Label (lbl ++ "end")] + + where condition lbl pt (Condition (left, cmp, right)) = + let find = valuableTarget pt in [Compare (find left) (find right), Jump lbl (Just cmp)] + wrapif i = fmap (\b -> [Label (lbl ++ show i)] ++ b ++ [Jump (lbl ++ "end") Nothing]) . concatMapM instructions + branch i (Node ((IfBranch (Just cond)), d, _, f) xs) = (condition (lbl ++ show i) (f, d) cond, wrapif i xs) + branch i (Node ((IfBranch Nothing), _, _, _) xs) = ([Jump (lbl ++ show i) Nothing], wrapif i xs) diff --git a/src/HLasm/Parser.hs b/src/HLasm/Parser.hs index 918ec20..7bb5272 100644 --- a/src/HLasm/Parser.hs +++ b/src/HLasm/Parser.hs @@ -5,6 +5,7 @@ module HLasm.Parser (HLasm.Parser.parse) where import HLasm.Ast +import HLasm.Error import Data.Bifunctor (first) import Data.Maybe (maybeToList) @@ -85,5 +86,5 @@ hlasm = reduce [ asmCall, call, HLasm.Parser.break, assignment ] where reduce (x:xs) = foldl (<|>) x xs -parse :: String -> Either String SyntaxTree -parse = first show . Text.Parsec.parse hlasm "" +parse :: String -> Result SyntaxTree +parse = first ParseError . Text.Parsec.parse hlasm "" diff --git a/src/HLasm/Scope.hs b/src/HLasm/Scope.hs index 1db7f3c..6d812f7 100644 --- a/src/HLasm/Scope.hs +++ b/src/HLasm/Scope.hs @@ -13,7 +13,9 @@ module HLasm.Scope import Control.Monad.Zip import Data.Tree +import Data.Bifunctor import HLasm.Ast +import HLasm.Error data ScopeData = FluentScope | IntroduceVariable HLValuable @@ -67,24 +69,24 @@ fromScopeData s (Node (el, sd) xs) = Node (el, currScope) (fmap (fromScopeData c newtype VariableData = VariableData (VariableName, HLElement) deriving (Show) newtype LabelData = LabelData (Label, HLElement) deriving (Show) -findVar :: Scope -> VariableName -> Maybe VariableData -findVar Root _ = Nothing +findVar :: Scope -> VariableName -> Either VariableName VariableData +findVar Root name = Left name findVar (Scope {scopeData = (IntroduceVariable var), scopeElement = el}) name | valuableName var == name = - Just $ VariableData (name, el) + Right $ VariableData (name, el) findVar (Scope {scopeParent = p}) name = findVar p name -findLabel :: Scope -> VariableName -> Maybe LabelData -findLabel Root _ = Nothing +findLabel :: Scope -> Label -> Either Label LabelData +findLabel Root label = Left label findLabel (Scope {scopeData = (IntroduceLabel lbl), scopeElement = el}) label | lbl == label = - Just $ LabelData (lbl, el) + Right $ LabelData (lbl, el) findLabel (Scope {scopeParent = p}) label = findLabel p label type SemanticTree = Tree (HLElement, [VariableData], [LabelData]) -semantic :: SyntaxTree -> Maybe SemanticTree +semantic :: SyntaxTree -> Result SemanticTree semantic t = traverse process . fromScopeData Root $ mzip t (fmap elementToScope t) where used f u s = sequence . fmap (f s) . u process (el, scope) = do - vars <- used findVar usedVariables scope el - labels <- used findLabel usedLabels scope el - Just (el, vars, labels) + vars <- first VariableNotFound $ used findVar usedVariables scope el + labels <- first LabelNotFound $ used findLabel usedLabels scope el + Right (el, vars, labels) diff --git a/src/HLasm/Types.hs b/src/HLasm/Types.hs index 4c6a5f0..4752ecb 100644 --- a/src/HLasm/Types.hs +++ b/src/HLasm/Types.hs @@ -4,8 +4,10 @@ module HLasm.Types where import Data.Maybe import Data.Tree +import Data.Bifunctor import HLasm.Ast import HLasm.Scope +import HLasm.Error typeSuit :: Type -> Type -> Bool typeSuit (Type lname _) (Type rname _) | (lname /= rname) = False @@ -32,18 +34,20 @@ literalType _ (IntegerValue x) = Just $ Type "int" (Just $ size x) literalType s (NameValue name) = lookupType name s literalType _ _ = undefined -astCheck :: HLElement -> [VariableData] -> Bool -astCheck (IfBranch (Just (Condition (left, _, right)))) xs = fromMaybe False $ - do leftType <- literalType xs left - rightType <- literalType xs right - Just $ typeSuit leftType rightType -astCheck (Assignment left right) xs = fromMaybe False $ - do leftType <- lookupType left xs - rightType <- literalType xs right - Just $ typeSuit leftType rightType -astCheck _ _ = True - -typeCheck :: SemanticTree -> Maybe SemanticTree +err a b = maybe (Left (a, b)) Right + +astCheck :: HLElement -> [VariableData] -> Either (HLValue, HLValue) () +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 + rightType <- error $ literalType xs right + if typeSuit leftType rightType then Right () else error Nothing +astCheck _ _ = Right () + +typeCheck :: SemanticTree -> Either Error SemanticTree typeCheck tree = traverse f tree - where f x@(elem, vars, _) = if astCheck elem vars then Just x else Nothing - + where f x@(elem, vars, _) = bimap IncompatibleTypes (const x) $ astCheck elem vars