diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. diff --git a/Language/Pascal/Builtin.hs b/Language/Pascal/Builtin.hs new file mode 100644 --- /dev/null +++ b/Language/Pascal/Builtin.hs @@ -0,0 +1,60 @@ + +module Language.Pascal.Builtin + (i, push, + builtinFunctions, + lookupBuiltin + ) where + +import Control.Monad.State + +import Language.SSVM.Types + +import Language.Pascal.Types + +-- | Add any stack item to the code +putItem :: StackItem -> Generate () +putItem x = do + st <- get + let gen = generated st + code = x: cCode (generated st) + put $ st {generated = gen {cCode = code}} + +-- | Generate instruction +i :: Instruction -> Generate () +i x = do + q <- gets quoteMode + if q + then putItem (Quote $ SInstruction x) + else putItem (SInstruction x) + +-- | Generate PUSH instruction +push :: StackType a => a -> Generate () +push x = i (PUSH $ toStack x) + +-- | List of builtin functions +builtinFunctions :: [(Id, Type, Generate ())] +builtinFunctions = + [("write", TFunction [TAny] TVoid, write), + ("writeln", TFunction [TAny] TVoid, writeln), + ("readln", TFunction [] TAny, readln) ] + +-- | If named symbol is builtin, return it's definition +lookupBuiltin :: Id -> Maybe (Generate ()) +lookupBuiltin name = look builtinFunctions + where + look [] = Nothing + look ((s, _, code):other) | s == name = Just code + | otherwise = look other + +write :: Generate () +write = i PRINT + +writeln :: Generate () +writeln = do + i PRINT + push "\n" + i PRINT + +readln :: Generate () +readln = i INPUT + diff --git a/Language/Pascal/CodeGen.hs b/Language/Pascal/CodeGen.hs new file mode 100644 --- /dev/null +++ b/Language/Pascal/CodeGen.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE TypeSynonymInstances, TypeOperators, ViewPatterns, FlexibleInstances, RecordWildCards, FlexibleContexts, OverlappingInstances #-} +module Language.Pascal.CodeGen (runCodeGen, CodeGen (..)) where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Error +import Data.List (intercalate, findIndex) +import qualified Data.Map as M + +import Language.SSVM.Types + +import Language.Pascal.Types +import Language.Pascal.Builtin + +instance Checker Generate where + enterContext c = do + st <- get + put $ st {currentContext = c: currentContext st} + + dropContext = do + st <- get + case currentContext st of + [] -> failCheck "Internal error: empty context on dropContext!" + (_:xs) -> put $ st {currentContext = xs} + + failCheck msg = do + cxs <- gets currentContext + throwError $ TError { + errLine = 0, + errColumn = 0, + errContext = if null cxs + then Unknown + else head cxs, + errMessage = msg } + +-- | Run code generator +runCodeGen :: Generate () -> Code +runCodeGen gen = generated $ execState go emptyGState + where + go :: State CodeGenState () + go = do + x <- runErrorT (runGenerate gen) + case x of + Right result -> return result + Left err -> fail $ "code generator: " ++ show err + +-- | Get full name of current context +getContextString :: Generate String +getContextString = do + cxs <- gets (map contextId . filter isProgramPart . currentContext) + return $ intercalate "_" (reverse cxs) + where + isProgramPart (ForLoop _ _) = False + isProgramPart _ = True + +setQuoteMode :: Bool -> Generate () +setQuoteMode b = do + st <- get + put $ st {quoteMode = b} + +-- | Get label which is at end of current context +-- (program or function) +getEndLabel :: Generate String +getEndLabel = do + cstr <- getContextString + return $ cstr ++ "__END" + +variable :: String -> Generate String +variable seed = do + st <- get + cstr <- getContextString + let name = cstr ++ "_" ++ seed + put $ st {variables = name: variables st} + return name + +-- | Get full name of variable (with context) +getFullName :: String -> Generate String +getFullName seed = do + cstr <- getContextString + return $ cstr ++ "_" ++ seed + +-- | Put a label and return it's full name +label :: String -> Generate String +label seed = do + st <- get + cstr <- getContextString + let n = length $ cCode (generated st) + name = cstr ++ "_" ++ seed ++ "_at_" ++ show n + gen = generated st + (curMarks:oldMarks) = cMarks gen + marks = M.insert name n curMarks + put $ st {generated = gen {cMarks = marks:oldMarks}} + return name + +-- | Return full name of label in the for loop. +-- fail if current context is not for loop. +forLoopLabel :: String -> String -> Generate String +forLoopLabel src seed = do + cxs <- gets currentContext + case cxs of + [] -> failCheck "Internal error: forLoopLabel on empty context!" + (ForLoop _ _:_) -> return $ intercalate "_" (map contextId $ reverse cxs) ++ "_" ++ seed + _ -> failCheck $ src ++ " not in for loop" + +-- | Get name of counter variable of for loop. +-- fail if current context is not for loop. +getForCounter :: Generate Id +getForCounter = do + cxs <- gets currentContext + case cxs of + [] -> failCheck "Internal error: getForCounter on empty context!" + (ForLoop i _:_) -> return i + _ -> failCheck "Internal error: getForCounter not in for loop!" + +-- | Generate full label name +labelFromHere :: String -> Generate String +labelFromHere seed = do + st <- get + cstr <- getContextString + let n = length $ cCode (generated st) + name = cstr ++ "_" ++ seed ++ "_from_" ++ show n + return name + +-- | Put label here +putLabelHere :: String -> Generate () +putLabelHere name = do + st <- get + let gen = generated st + n = length $ cCode (generated st) + (curMarks:oldMarks) = cMarks gen + marks = M.insert name n curMarks + put $ st {generated = gen {cMarks = marks:oldMarks}} + +goto :: String -> Generate () +goto name = jumpWith GOTO name + +jumpWith :: Instruction -> String -> Generate () +jumpWith jump name = do + i (GETMARK name) + i jump + +assignTo :: Id -> Generate () +assignTo name = do + i (CALL name) + i ASSIGN + +readFrom :: Id -> Generate () +readFrom name = do + i (CALL name) + i READ + +findFieldIndex :: Id -> [(Id, Type)] -> Maybe Int +findFieldIndex name pairs = + (1+) `fmap` findIndex (\p -> fst p == name) pairs + +class CodeGen a where + generate :: a -> Generate () + +instance (CodeGen (a TypeAnn)) => CodeGen (a :~ TypeAnn) where + generate = generate . content + +instance (CodeGen a) => CodeGen [a] where + generate list = forM_ list generate + +instance CodeGen (Expression :~ TypeAnn) where + generate e@(content -> RecordField base field) = do + rec <- getFullName base + case typeOfA e of + TRecord pairs -> case findFieldIndex field pairs of + Just ix -> do + i (CALL rec) + push ix + i READ_ARRAY + Nothing -> failCheck $ "Internal error: no such field in " ++ base ++ " record: " ++ field + TField ix _ -> do + i (CALL rec) + push ix + i READ_ARRAY + x -> failCheck $ "Internal error: " ++ base ++ " is " ++ show x ++ ", not a Record" + + generate e = generate (content e) + +instance CodeGen (Expression TypeAnn) where + generate (Variable name) = do + consts <- gets constants + case lookup name consts of + Just (LInteger i) -> push i + Just (LString s) -> push s + Just (LBool b) -> push (fromEnum b) + Nothing -> readFrom =<< getFullName name + + generate (ArrayItem name ix) = do + arr <- getFullName name + i (CALL arr) + generate ix + i READ_ARRAY + + generate (RecordField _ _) = + failCheck "Internal error: RecordField in instance CodeGen (Expression TypeAnn)" + + generate (Literal x) = + case x of + LInteger n -> push n + LString s -> push s + LBool b -> push (fromIntegral (fromEnum b) :: Integer) + + generate (Call name args) = do + generate args + case lookupBuiltin name of + Just code -> code + Nothing -> i (CALL name) + + generate (Op op x y) = do + generate x + generate y + case op of + Add -> i ADD + Sub -> i SUB + Mul -> i MUL + Div -> i DIV + Mod -> i REM + Pow -> failCheck "pow() is not supported yet" + IsGT -> i CMP + IsLT -> i CMP >> i NEG + IsEQ -> i CMP >> i ABS >> push (1 :: Integer) >> i SUB + IsNE -> i CMP >> i ABS + +instance CodeGen (LValue :~ TypeAnn) where + generate (content -> LVariable name) = + assignTo =<< getFullName name + + generate (content -> LArray name ix) = do + arr <- getFullName name + i (CALL arr) + generate ix + i ASSIGN_ARRAY + + generate v@(content -> LField base field) = do + var <- getFullName base + case typeOfA v of + TRecord pairs -> case findFieldIndex field pairs of + Just ix -> do + i (CALL var) + push ix + i ASSIGN_ARRAY + Nothing -> failCheck $ "Internal error: no such field in " ++ base ++ " record: " ++ field + TField ix _ -> do + i (CALL var) + push ix + i ASSIGN_ARRAY + x -> failCheck $ "Internal error: " ++ base ++ " is " ++ show x ++ ", not a Record" + +instance CodeGen (Statement TypeAnn) where + generate (Assign lvalue expr) = do + generate expr + generate lvalue + + generate (Procedure name args) = do + generate args + case lookupBuiltin name of + Just code -> code + Nothing -> i (CALL name) + + generate (Return expr) = do + generate expr + goto =<< getEndLabel + + generate Break = + goto =<< forLoopLabel "break" "endFor" + + generate Continue = do + start <- forLoopLabel "continue" "forLoop" + var <- getFullName =<< getForCounter + -- increment counter + readFrom var + push (1 :: Integer) + i ADD + assignTo var + -- go to start of loop + goto start + + generate Exit = + -- go to end of procedure or program + goto =<< getEndLabel + + generate (IfThenElse condition ifStatements elseStatements) = do + generate condition + elseLabel <- labelFromHere "else" + jumpWith JZ elseLabel + generate ifStatements + endIfLabel <- labelFromHere "endIf" + goto endIfLabel + putLabelHere elseLabel + generate elseStatements + putLabelHere endIfLabel + + generate (For counter start end body) = do + -- get current instruction number + n <- gets (length . cCode . generated) + inContext (ForLoop counter n) $ do + -- assign start value to counter + generate start + var <- getFullName counter + assignTo var + -- loop start label + loop <- forLoopLabel "for" "forLoop" + putLabelHere loop + -- check if counter > end value + readFrom var + generate end + i CMP + endLoop <- forLoopLabel "end for" "endFor" + -- jump to end of cycle if it's done + jumpWith JGT endLoop + generate body + -- increment counter + readFrom var + push (1 :: Integer) + i ADD + assignTo var + -- go to start of loop + goto loop + putLabelHere endLoop + +instance CodeGen (Program TypeAnn) where + generate (Program {..}) = do + inContext Outside $ do + st <- get + put $ st {constants = map getLit $ reverse progConsts} + -- declare global variables + forM progVariables $ \v -> do + declare (symbolNameC v) + allocIfNeeded (symbolNameC v) (symbolTypeC v) + -- for all functions, declare their local variables + -- and arguments + forM progFunctions $ \fn -> do + forM (fnFormalArgs $ content fn) $ \a -> do + i COLON + let name = (fnName $ content fn) ++ "_" ++ symbolNameC a + push name + i VARIABLE + allocIfNeeded' name (symbolTypeC a) + forM (fnVars $ content fn) $ \v -> do + i COLON + let name = (fnName $ content fn) ++ "_" ++ symbolNameC v + push name + i VARIABLE + allocIfNeeded' name (symbolTypeC v) + -- generate functions + generate progFunctions + vars <- gets variables + inContext Outside $ do + forM vars declare + -- generate program body + inContext ProgramBody $ do + generate progBody + putLabelHere =<< getEndLabel + where + getLit (n, (content -> Literal x)) = (n, x) + getLit (n, x) = error $ "Internal error: not a literal in constant " ++ n ++ ": " ++ show x + + declare name = do + i COLON + push =<< getFullName name + i VARIABLE + + allocIfNeeded' fullName tp = + case tp of + TArray sz _ -> do + push sz + i (CALL fullName) + i ARRAY + TRecord pairs -> do + push (length pairs) + i (CALL fullName) + i ARRAY + _ -> return () + + allocIfNeeded name tp = do + fullName <- getFullName name + allocIfNeeded' fullName tp + +instance CodeGen (Function TypeAnn) where + generate (Function {..}) = do + i COLON + push fnName + setQuoteMode True + inContext (InFunction fnName fnResultType) $ do + -- get actual arguments values from stack + forM (reverse fnFormalArgs) $ \a -> + assignTo =<< getFullName (symbolNameC a) + generate fnBody + putLabelHere =<< getEndLabel + i NOP + setQuoteMode False + i DEFINE + diff --git a/Language/Pascal/Parser.hs b/Language/Pascal/Parser.hs new file mode 100644 --- /dev/null +++ b/Language/Pascal/Parser.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE RecordWildCards, TypeOperators, StandaloneDeriving, FlexibleContexts, UndecidableInstances #-} +module Language.Pascal.Parser (parseSource, pProgram) where + +import Control.Applicative ((<$>)) +import qualified Data.Map as M +import Text.Parsec +import qualified Text.Parsec.Token as P +import Text.Parsec.Language +import Text.Parsec.Expr + +import Language.Pascal.Types + +type Parser a = Parsec String () a + +pascal = P.makeTokenParser $ javaStyle { + P.commentStart = "(*", + P.commentEnd = "*)", + P.reservedNames = ["program", "function", "begin", "end", "var", "true", "false", + "return", "if", "then", "else", "for", "to", "do", "of", + "exit", "procedure", "break", "continue", "array", "record", + "const", "type" ] } + +symbol = P.symbol pascal +reserved = P.reserved pascal +reservedOp = P.reservedOp pascal +identifier = P.identifier pascal +stringLiteral = P.stringLiteral pascal +integer = P.integer pascal +semi = P.semi pascal +colon = P.colon pascal +comma = P.comma pascal +dot = P.dot pascal +parens = P.parens pascal +brackets = P.brackets pascal + +withAnnotation :: Parser x -> Parser (Annotate x SrcPos) +withAnnotation p = do + pos <- getPosition + x <- p + return $ Annotate x $ SrcPos { + srcLine = sourceLine pos, + srcColumn = sourceColumn pos } + +pProgram :: Parser (Program :~ SrcPos) +pProgram = withAnnotation $ do + reserved "program" + identifier + semi + consts <- option [] pConsts + types <- M.fromList <$> option [] pTypes + vars <- option [] pVars + fns <- many (try pFunction <|> pProcedure) + reserved "begin" + sts <- pStatement `sepEndBy1` semi + reserved "end" + dot + return $ Program consts types vars fns sts + +readType str = + case str of + "integer" -> TInteger + "string" -> TString + "boolean" -> TBool + "void" -> TVoid + s -> TUser s + +pVars :: Parser [Annotate Symbol SrcPos] +pVars = do + reserved "var" + lists <- pVarsList `sepEndBy1` semi + return $ concat lists + +pTypes :: Parser [(Id, Type)] +pTypes = do + reserved "type" + many1 $ do + name <- identifier + reservedOp "=" + tp <- pType + semi + return (name, content tp) + +pConsts :: Parser [(Id, Expression :~ SrcPos)] +pConsts = do + reserved "const" + many1 $ do + name <- identifier + reservedOp "=" + value <- pExpression + semi + return (name, value) + +pVarsList :: Parser [Annotate Symbol SrcPos] +pVarsList = do + pos <- getPosition + names <- identifier `sepBy` comma + colon + tp <- pType + return $ map (ret tp pos) names + where + ret tp pos name = Annotate (name # content tp) $ + SrcPos { + srcLine = sourceLine pos, + srcColumn = sourceColumn pos } + +pType :: Parser (Annotate Type SrcPos) +pType = try arrayType <|> try recordType <|> simpleType + where + arrayType = withAnnotation $ do + reserved "array" + sz <- brackets integer + reserved "of" + tp <- pType + return (TArray sz $ content tp) + + recordType = withAnnotation $ do + reserved "record" + fields <- field `sepEndBy1` semi + reserved "end" + return (TRecord fields) + + field = do + name <- identifier + colon + tp <- pType + return (name, content tp) + + simpleType = withAnnotation $ do + name <- identifier + return (readType name) + +pNameType :: Parser (Annotate Symbol SrcPos) +pNameType = withAnnotation $ do + name <- identifier + colon + tp <- pType + return $ name # content tp + +pFunction :: Parser (Function :~ SrcPos) +pFunction = withAnnotation $ do + reserved "function" + name <- identifier + args <- parens $ pNameType `sepBy` comma + colon + res <- identifier + semi + vars <- option [] pVars + reserved "begin" + body <- pStatement `sepEndBy1` semi + reserved "end" + semi + return $ Function name args (readType res) vars body + +pProcedure :: Parser (Function :~ SrcPos) +pProcedure = withAnnotation $ do + reserved "procedure" + name <- identifier + args <- parens $ pNameType `sepBy` comma + semi + vars <- option [] pVars + reserved "begin" + body <- pStatement `sepEndBy1` semi + reserved "end" + semi + return $ Function name args TVoid vars body + +pStatement :: Parser (Statement :~ SrcPos) +pStatement = + try pIfThenElse + <|> try pAssign + <|> try pProcedureCall + <|> try (withAnnotation (reserved "break" >> return Break)) + <|> try (withAnnotation (reserved "continue" >> return Continue)) + <|> try (withAnnotation (reserved "exit" >> return Exit)) + <|> try pReturn + <|> pFor + +pAssign :: Parser (Statement :~ SrcPos) +pAssign = withAnnotation $ do + lv <- pLValue + symbol ":=" + expr <- pExpression + return $ Assign lv expr + +pLValue :: Parser (LValue :~ SrcPos) +pLValue = try arrayItem <|> try recordField <|> variable + where + arrayItem = withAnnotation $ do + arr <- identifier + ix <- brackets pExpression + return (LArray arr ix) + + variable = withAnnotation (LVariable <$> identifier) + + recordField = withAnnotation $ do + base <- identifier + dot + field <- identifier + return (LField base field) + +pProcedureCall = withAnnotation $ do + name <- identifier + args <- parens $ pExpression `sepBy` comma + return $ Procedure name args + +pReturn :: Parser (Statement :~ SrcPos) +pReturn = withAnnotation $ do + reserved "return" + x <- pExpression + return $ Return x + +pIfThenElse :: Parser (Statement :~ SrcPos) +pIfThenElse = withAnnotation $ do + reserved "if" + cond <- pExpression + reserved "then" + ok <- pBlock + el <- option [] $ try $ do + reserved "else" + pBlock + return $ IfThenElse cond ok el + +pBlock = try (one <$> pStatement) <|> do + reserved "begin" + sts <- pStatement `sepEndBy1` semi + reserved "end" +-- semi + return sts + where + one x = [x] + +pFor = withAnnotation $ do + reserved "for" + var <- identifier + reserved ":=" + start <- pExpression + reserved "to" + end <- pExpression + reserved "do" + sts <- pBlock + return $ For var start end sts + +pExpression :: Parser (Expression :~ SrcPos) +pExpression = buildExpressionParser table term "expression" + where + table = [ + [binary "^" Pow AssocLeft], + [binary "*" Mul AssocLeft, binary "/" Div AssocLeft, binary "%" Mod AssocLeft ], + [binary "+" Add AssocLeft, binary "-" Sub AssocLeft ], + [binary "=" IsEQ AssocLeft, binary "!=" IsNE AssocLeft, binary ">" IsGT AssocLeft, binary "<" IsLT AssocLeft ] + ] + binary name fun assoc = Infix (op name fun) assoc + op name fun = do + pos <- getPosition + reservedOp name + return $ \x y -> Annotate (Op fun x y) $ SrcPos { + srcLine = sourceLine pos, + srcColumn = sourceColumn pos } + +term = parens pExpression + <|> try (withAnnotation $ Literal <$> pLiteral) + <|> try pCall + <|> try pArrayItem + <|> try pRecordField + <|> pVariable + +pLiteral = try stringLit <|> try intLit <|> boolLit + where + stringLit = LString <$> stringLiteral + intLit = LInteger <$> integer + boolLit = try (reserved "true" >> return (LBool True)) <|> (reserved "false" >> return (LBool False)) + +pVariable :: Parser (Expression :~ SrcPos) +pVariable = withAnnotation $ Variable <$> identifier + +pArrayItem :: Parser (Expression :~ SrcPos) +pArrayItem = withAnnotation $ do + arr <- identifier + ix <- brackets pExpression + return (ArrayItem arr ix) + +pRecordField :: Parser (Expression :~ SrcPos) +pRecordField = withAnnotation $ do + base <- identifier + dot + field <- identifier + return (RecordField base field) + +pCall :: Parser (Expression :~ SrcPos) +pCall = withAnnotation $ do + name <- identifier + args <- parens $ pExpression `sepBy` comma + return $ Call name args + +parseSource :: FilePath -> IO (Program :~ SrcPos) +parseSource path = do + src <- readFile path + case parse pProgram path src of + Left err -> fail $ show err + Right x -> return x diff --git a/Language/Pascal/TypeCheck.hs b/Language/Pascal/TypeCheck.hs new file mode 100644 --- /dev/null +++ b/Language/Pascal/TypeCheck.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE RecordWildCards, TypeOperators, TypeSynonymInstances, FlexibleInstances, ViewPatterns #-} +module Language.Pascal.TypeCheck + (checkTypes, + checkSource, + builtinSymbols + ) where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Error +import qualified Data.Map as M +import Data.Maybe +import Text.Parsec hiding (State) + +import Language.Pascal.Types +import Language.Pascal.Builtin +import Language.Pascal.Parser + +-- | Look up for named symbol +lookupSymbol :: Id -> SymbolTable -> Maybe Symbol +lookupSymbol name table = + case filter isJust $ map (M.lookup name) table of + [] -> Nothing + (s:_) -> s + +-- | Symbol table of builtin symbols +builtinSymbols :: M.Map Id Symbol +builtinSymbols = M.fromList $ map pair builtinFunctions + where + pair (name, tp, _) = (name, Symbol { + symbolName = name, + symbolType = tp, + symbolDefLine = 0, + symbolDefCol = 0 }) + +isSubtypeOf :: Type -> Type -> Bool +isSubtypeOf TVoid TVoid = True +isSubtypeOf TVoid _ = False +isSubtypeOf _ TAny = True +isSubtypeOf (TArray _ t1) (TArray _ t2) = t1 `isSubtypeOf` t2 +isSubtypeOf t1 (TField _ t2) = t1 `isSubtypeOf` t2 +isSubtypeOf (TField _ t1) t2 = t1 `isSubtypeOf` t2 +isSubtypeOf (TFunction a1 r1) (TFunction a2 r2) = + (r1 `isSubtypeOf` r2) && areSubtypesOf a1 a2 +isSubtypeOf t1 t2 = t1 == t2 + +areSubtypesOf :: [Type] -> [Type] -> Bool +areSubtypesOf ts1 ts2 = + (length ts1 == length ts2) && and (zipWith isSubtypeOf ts1 ts2) + +-- | Starting type checker state +emptyState :: CheckState +emptyState = CheckState { + userConsts = [], + userTypes = M.empty, + symbolTable = [builtinSymbols], + contexts = [], + ckLine = 0, + ckColumn = 0 } + +class Typed a where + typeCheck :: a :~ SrcPos -> Check (a :~ TypeAnn) + +isFor :: Context -> Bool +isFor (ForLoop _ _) = True +isFor _ = False + +returnT :: Type -> Annotate node1 SrcPos -> node -> Check (Annotate node TypeAnn) +returnT t x res = + return $ Annotate res $ TypeAnn { + srcPos = SrcPos { + srcLine = srcLine (annotation x), + srcColumn = srcColumn (annotation x) }, + typeOf = t, + localSymbols = M.empty} + +instance Checker Check where + enterContext c = do + st <- get + put $ st {contexts = c: contexts st} + + dropContext = do + st <- get + case contexts st of + [] -> failCheck "Internal error in TypeCheck: dropContext on empty context!" + (_:old) -> put $ st {contexts = old} + + failCheck msg = do + line <- gets ckLine + col <- gets ckColumn + cxs <- gets contexts + throwError $ TError { + errLine = line, + errColumn = col, + errContext = if null cxs + then Unknown + else head cxs, + errMessage = msg } + +setPos :: Annotate a SrcPos -> Check () +setPos x = do + st <- get + put $ st {ckLine = srcLine (annotation x), + ckColumn = srcColumn (annotation x)} + +errorOnUserTypeSymbol :: Annotate Symbol a -> Annotate Symbol a +errorOnUserTypeSymbol (Annotate (symbolType -> TUser t) _) = error $ "Internal error (symbol): user type: " ++ t +errorOnUserTypeSymbol x = x + +checkType :: Type -> Check Type +checkType (TArray sz t) = do + t' <- checkType t + return (TArray sz t') +checkType (TRecord pairs) = withSymbolTable $ do + pairs' <- forM pairs $ \(n,t) -> do + t' <- checkType t + addSymbol $ Annotate (n # t') (SrcPos 0 0) + return (n, t') + return (TRecord pairs') +checkType (TUser name) = do + types <- gets userTypes + case M.lookup name types of + Just t -> checkType t + Nothing -> failCheck $ "Undefined type: " ++ name +checkType t = return t + +checkSymbol :: Annotate Symbol SrcPos -> Check (Annotate Symbol TypeAnn) +checkSymbol s = do + setPos s + t <- checkType (symbolTypeC s) + case t of + TUser name -> failCheck $ "Internal error: undefined user type: " ++ name + _ -> do + let s' = setType s t + addSymbol s' + return $ s' `withType` t + +getSymbol :: Id -> Check Symbol +getSymbol name = do + table <- gets symbolTable + case lookupSymbol name table of + Nothing -> failCheck $ "Unknown symbol: " ++ name + Just s -> return s + +addSymbol :: Annotate Symbol SrcPos -> Check () +addSymbol (Annotate (Symbol {..}) (SrcPos {..})) = do + st <- get + (current:other) <- gets symbolTable + case M.lookup symbolName current of + Just s -> failCheck $ "Symbol is already defined: " ++ showSymbol s + Nothing -> do + let new = M.insert symbolName (Symbol symbolName symbolType srcLine srcColumn) current + put $ st {symbolTable = (new:other)} + +addSymbolTable :: Check () +addSymbolTable = do + st <- get + was <- gets symbolTable + put $ st {symbolTable = (M.empty: was)} + +dropSymbolTable :: Check () +dropSymbolTable = do + st <- get + was <- gets symbolTable + case was of + [] -> failCheck "Internal error: empty symbol table on dropSymbolTable!" + (_:older) -> put $ st {symbolTable = older} + +withSymbolTable :: Check a -> Check a +withSymbolTable check = do + addSymbolTable + x <- check + dropSymbolTable + return x + +addType :: Id -> Type -> Check (Id, Type) +addType name tp = do + st <- get + let types = userTypes st + case M.lookup name types of + Just _ -> failCheck $ "Type is already defined: " ++ name + Nothing -> do + tp' <- checkType tp + put $ st {userTypes = M.insert name tp' types} + return (name, tp') + +evalConst :: Expression :~ a -> Check Lit +evalConst expr = do + case content expr of + Variable name -> do + consts <- gets userConsts + case lookup name consts of + Just v -> evalConst v + Nothing -> failCheck $ "No such constant: " ++ name + Literal v -> return v + Op op x y -> do + x' <- evalConst x + y' <- evalConst y + return $ eval op x' y' + x -> failCheck $ "Expression is not constant: " ++ show x + where + eval Add (LInteger x) (LInteger y) = LInteger (x+y) + eval Sub (LInteger x) (LInteger y) = LInteger (x-y) + eval Mul (LInteger x) (LInteger y) = LInteger (x*y) + eval Div (LInteger x) (LInteger y) = LInteger (x `div` y) + eval Pow (LInteger x) (LInteger y) = error "pow() is not supported yet" + eval IsGT (LInteger x) (LInteger y) = LBool (x > y) + eval IsLT (LInteger x) (LInteger y) = LBool (x < y) + eval IsEQ (LInteger x) (LInteger y) = LBool (x == y) + eval IsNE (LInteger x) (LInteger y) = LBool (x /= y) + eval _ _ _ = error "Unsupported operand types in constant expression" + +litType :: Lit -> Type +litType (LInteger _) = TInteger +litType (LString _) = TString +litType (LBool _) = TBool + +addConst :: Id -> Expression :~ SrcPos -> Check (Expression :~ TypeAnn) +addConst name e = do + st <- get + let consts = userConsts st + case lookup name consts of + Just c -> failCheck $ "Constant " ++ name ++ " was already defined as " ++ show c + Nothing -> do + val <- evalConst e + let result = Annotate (Literal val) $ TypeAnn { + srcPos = annotation e, + typeOf = litType val, + localSymbols = M.empty } + put $ st {userConsts = (name, result): consts} + return result + +instance Typed Program where + typeCheck p@(content -> Program consts types vars fns body) = withSymbolTable $ do + setPos p + consts' <- inContext Outside $ + forM consts $ \(n,v) -> do + v' <- addConst n v + let sym = Annotate { + content = Symbol { + symbolName = n, + symbolType = typeOfA v', + symbolDefLine = srcLine (annotation v), + symbolDefCol = srcColumn (annotation v) }, + annotation = annotation v } + addSymbol sym + return (n, v') + + types' <- inContext Outside $ + forM (M.assocs types) $ uncurry addType + vars' <- inContext Outside $ + forM vars checkSymbol + fns' <- inContext Outside $ + forM fns $ \fn -> do + fn' <- typeCheck fn + let f = content fn' + tp = TFunction (argTypes f) (fnResultType f) + s = SrcPos { + srcLine = srcLine (annotation fn), + srcColumn = srcColumn (annotation fn) } + addSymbol $ Annotate (fnName f # tp) s + return fn' + body' <- inContext ProgramBody $ + forM body typeCheck + let program = Program consts' (M.fromList types') (map errorOnUserTypeSymbol vars') fns' body' + return $ Annotate program $ TypeAnn { + srcPos = SrcPos 0 0, + typeOf = TVoid, + localSymbols = makeSymbolTable vars'} + where + argTypes :: Function TypeAnn -> [Type] + argTypes (Function {..}) = map symbolTypeC fnFormalArgs + +makeSymbolTable :: [Annotate Symbol TypeAnn] -> M.Map Id Symbol +makeSymbolTable xs = M.fromList $ map pair xs + where + pair :: Annotate Symbol TypeAnn -> (Id, Symbol) + pair (Annotate s (TypeAnn {..})) = + (symbolName s, + s { symbolDefLine = srcLine srcPos, + symbolDefCol = srcColumn srcPos }) + +findField :: Id -> [(Id, Type)] -> Maybe (Int, Type) +findField name pairs = go 1 pairs + where + go _ [] = Nothing + go i ((k,v):other) + | k == name = Just (i, v) + | otherwise = go (i+1) other + +instance Typed LValue where + typeCheck v@(content -> LVariable name) = do + setPos v + sym <- getSymbol name + returnT (symbolType sym) v (LVariable name) + + typeCheck v@(content -> LArray name ix) = do + setPos v + sym <- getSymbol name + case symbolType sym of + TArray _ tp -> do + ix' <- typeCheck ix + when (typeOfA ix' /= TInteger) $ + failCheck $ "Invalid array item lvalue: index is " ++ show (typeOfA ix') ++ ", not Integer" + returnT tp v (LArray name ix') + x -> failCheck $ "Invalid lvalue: " ++ name ++ " is " ++ show x ++ ", not Array" + + typeCheck v@(content -> LField base field) = do + setPos v + baseSym <- getSymbol base + case symbolType baseSym of + TRecord pairs -> case findField field pairs of + Just (ix,t) -> returnT (TField ix t) v (LField base field) + Nothing -> failCheck $ "No such field in " ++ base ++ " record: " ++ field + x -> failCheck $ base ++ " is " ++ show x ++ ", not Record" + +instance Typed Statement where + typeCheck x@(content -> Assign lvalue expr) = do + setPos x + lhs <- typeCheck lvalue + rhs <- typeCheck expr + let rhsType = typeOfA rhs + lhsType = typeOfA lhs + if (rhsType == TAny) || (rhsType `isSubtypeOf` lhsType) + then do + let result = Assign lhs rhs + returnT lhsType x result + else failCheck $ "Invalid assignment: LHS type is " ++ show lhsType ++ ", but RHS type is " ++ show rhsType + + typeCheck s@(content -> Procedure name args) = do + setPos s + sym <- getSymbol name + case symbolType sym of + TFunction formalArgTypes TVoid -> do + args' <- mapM typeCheck args + let actualTypes = map typeOfA args' + if actualTypes `areSubtypesOf` formalArgTypes + then returnT TVoid s (Procedure name args') + else failCheck $ "Invalid types in procedure call: " ++ show actualTypes ++ " instead of " ++ show formalArgTypes + t -> failCheck $ "Symbol " ++ name ++ " is not a procedure, but " ++ show t + + typeCheck s@(content -> Break) = do + setPos s + cxs <- gets contexts + if null (filter isFor cxs) + then failCheck "break statement not in for loop" + else returnT TVoid s Break + + typeCheck s@(content -> Continue) = do + setPos s + cxs <- gets contexts + if null (filter isFor cxs) + then failCheck "continue statement not in for loop" + else returnT TVoid s Continue + + typeCheck s@(content -> Exit) = do + setPos s + cxs <- gets contexts + case cxs of + (InFunction _ TVoid:_) -> returnT TVoid s Exit + (ProgramBody:_) -> returnT TVoid s Exit + _ -> failCheck "exit statement not in procedure or program body" + + typeCheck s@(content -> Return x) = do + setPos s + x' <- typeCheck x + let retType = typeOfA x' + cxs <- gets contexts + case cxs of + (InFunction _ TVoid:_) -> failCheck "return statement in procedure" + (InFunction _ t:_) + | retType `isSubtypeOf` t -> returnT (typeOfA x') s (Return x') + | otherwise -> failCheck $ "Return value type does not match: expecting " ++ show t ++ ", got " ++ show retType + _ -> failCheck $ "return statement not in function" + + typeCheck s@(content -> IfThenElse c a b) = do + setPos s + c' <- typeCheck c + when (typeOfA c' /= TBool) $ + failCheck $ "Condition type is not Boolean: " ++ show c + a' <- mapM typeCheck a + b' <- mapM typeCheck b + returnT TVoid s (IfThenElse c' a' b') + + typeCheck s@(content -> For name start end body) = inContext (ForLoop name 0) $ do + setPos s + sym <- getSymbol name + when (symbolType sym /= TInteger) $ + failCheck $ "Counter variable is not Integer: " ++ name + start' <- typeCheck start + when (typeOfA start' /= TInteger) $ + failCheck $ "Counter start value is not Integer: " ++ show start + end' <- typeCheck end + when (typeOfA end' /= TInteger) $ + failCheck $ "Counter end value is not Integer: " ++ show end + body' <- mapM typeCheck body + returnT TVoid s (For name start' end' body') + +instance Typed Function where + typeCheck x@(content -> Function {..}) = do + setPos x + inContext (InFunction fnName fnResultType) $ withSymbolTable $ do + args <- mapM checkSymbol fnFormalArgs + vars <- mapM checkSymbol fnVars + body <- mapM typeCheck fnBody + let fn = Function fnName args fnResultType vars body + tp = TFunction (map typeOfA args) fnResultType + Annotate result ta <- returnT fnResultType x fn + return $ Annotate result $ ta {localSymbols = makeSymbolTable vars} + +instance Typed Expression where + typeCheck e@(content -> Variable x) = do + setPos e + sym <- getSymbol x + returnT (symbolType sym) e (Variable x) + + typeCheck e@(content -> ArrayItem name ix) = do + setPos e + sym <- getSymbol name + case symbolType sym of + TArray _ tp -> do + ix' <- typeCheck ix + when (typeOfA ix' /= TInteger) $ + failCheck $ "Array index is " ++ show (typeOfA ix') ++ ", not Integer" + returnT tp e (ArrayItem name ix') + x -> failCheck $ name ++ " is " ++ show x ++ ", not Array" + + typeCheck e@(content -> RecordField base field) = do + setPos e + baseSym <- getSymbol base + case symbolType baseSym of + TRecord pairs -> case findField field pairs of + Just (ix,t) -> returnT (TField ix t) e (RecordField base field) + Nothing -> failCheck $ "No such field in " ++ base ++ " record: " ++ field + TField ix t -> returnT (TField ix t) e (RecordField base field) + x -> failCheck $ base ++ " is " ++ show x ++ ", not Record" + + typeCheck e@(content -> Literal x) = returnT (litType x) e (Literal x) + + typeCheck e@(content -> Call name args) = do + setPos e + sym <- getSymbol name + case symbolType sym of + TFunction formalArgTypes resType -> do + args' <- mapM typeCheck args + let actualTypes = map typeOfA args' + if actualTypes `areSubtypesOf` formalArgTypes + then returnT resType e (Call name args') + else failCheck $ "Invalid types in function call: " ++ show actualTypes ++ " instead of " ++ show formalArgTypes + t -> failCheck $ "Symbol " ++ name ++ " is not a function, but " ++ show t + + typeCheck e@(content -> Op op x y) = do + setPos e + x' <- typeCheck x + y' <- typeCheck y + let tx = typeOfA x' + ty = typeOfA y' + if (TInteger `isSubtypeOf` tx) && (TInteger `isSubtypeOf` ty) + then if op `elem` [IsEQ, IsNE, IsGT, IsLT] + then returnT TBool e (Op op x' y') + else returnT TInteger e (Op op x' y') + else failCheck $ "Invalid operand types: " ++ show tx ++ ", " ++ show ty + +checkTypes :: Program :~ SrcPos -> Program :~ TypeAnn +checkTypes prog = evalState check emptyState + where + check :: State CheckState (Program :~ TypeAnn) + check = do + x <- runErrorT (runCheck $ typeCheck prog) + case x of + Right result -> return result + Left err -> fail $ "type checker: " ++ show err + +checkSource :: FilePath -> IO (Program :~ TypeAnn) +checkSource path = do + str <- readFile path + case parse pProgram path str of + Left err -> fail $ "parser: " ++ show err + Right prog -> return (checkTypes prog) + diff --git a/Language/Pascal/Types.hs b/Language/Pascal/Types.hs new file mode 100644 --- /dev/null +++ b/Language/Pascal/Types.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE RecordWildCards, TypeOperators, StandaloneDeriving, FlexibleContexts, UndecidableInstances, GeneralizedNewtypeDeriving #-} +module Language.Pascal.Types where + +import Control.Monad.State +import Control.Monad.Error +import qualified Data.Map as M +import Data.List (intercalate) +import Text.Printf + +import Language.SSVM.Types + +-- | Type for symbol identifiers +type Id = String + +-- | Attach annotation to node +data Annotate node ann = Annotate { + content :: node, + annotation :: ann } + deriving (Eq) + +instance (Show node) => Show (Annotate node ann) where + show (Annotate x _) = show x + +-- | Position of node in the source code +data SrcPos = SrcPos { + srcLine :: Int, + srcColumn :: Int } + deriving (Eq) + +instance Show SrcPos where + show (SrcPos l c) = printf "[l. %d, c. %d]" l c + +-- | Node type info +data TypeAnn = TypeAnn { + srcPos :: SrcPos, + typeOf :: Type, + localSymbols :: M.Map Id Symbol } + deriving (Eq, Show) + +-- | Recursive annotated type +type node :~ ann = Annotate (node ann) ann + +-- | Attach type info to node +withType :: Annotate a SrcPos -> Type -> Annotate a TypeAnn +withType (Annotate x pos) t = Annotate x $ TypeAnn { + srcPos = pos, + typeOf = t, + localSymbols = M.empty} + +setType :: Annotate Symbol a -> Type -> Annotate Symbol a +setType (Annotate s pos) t = Annotate (s {symbolType = t}) pos + +-- | Change annotation of annotated node +annotate :: ann -> Annotate node old -> Annotate node ann +annotate a (Annotate x _) = Annotate x a + +-- | Program +data Program a = Program { + progConsts :: [(Id, Expression :~ a)], -- ^ constants + progTypes :: M.Map Id Type, -- ^ user defined types + progVariables :: [Annotate Symbol a], -- ^ global variables + progFunctions :: [Function :~ a], -- ^ functions + progBody :: [Statement :~ a] -- ^ program body statements + } + deriving (Eq, Show) + +-- | Function (or procedure) +data Function a = Function { + fnName :: String, -- ^ function name + fnFormalArgs :: [Annotate Symbol a], -- ^ formal arguments + fnResultType :: Type, -- ^ return type (if TVoid then this is procedure) + fnVars :: [Annotate Symbol a], -- ^ local variables + fnBody :: [Statement :~ a] -- ^ function body statements + } + deriving (Eq, Show) + +-- | Symbol table +type SymbolTable = [M.Map Id Symbol] + +-- | A symbol +data Symbol = Symbol { + symbolName :: Id, + symbolType :: Type, + symbolDefLine :: Int, -- ^ Source line where symbol was defined + symbolDefCol :: Int -- ^ Source column + } + deriving (Eq) + +instance Show Symbol where + show (Symbol {..}) = symbolName ++ ": " ++ show symbolType + +showSymbol :: Symbol -> String +showSymbol (Symbol {..}) = + printf "%s: %s (defined at l.%d, c.%d)" + symbolName (show symbolType) symbolDefLine symbolDefCol + +symbolNameC :: Annotate Symbol ann -> Id +symbolNameC = symbolName . content + +symbolTypeC :: Annotate Symbol ann -> Type +symbolTypeC = symbolType . content + +typeOfA :: Annotate node TypeAnn -> Type +typeOfA = typeOf . annotation + +-- | Make symbol from it's name and type +(#) :: Id -> Type -> Symbol +name # tp = Symbol { + symbolName = name, + symbolType = tp, + symbolDefLine = 0, + symbolDefCol = 0 } + +-- | Supported data types +data Type = + TInteger + | TString + | TBool + | TVoid + | TUser Id -- ^ user defined type + | TAny -- ^ any value (dynamic typing) + | TArray Integer Type -- ^ array of some type + | TRecord [(Id, Type)] -- ^ record + | TField Int Type -- ^ record field: field index and type + | TFunction [Type] Type -- ^ formal arguments types and return type + deriving (Eq) + +instance Show Type where + show TInteger = "integer" + show TString = "string" + show TBool = "boolean" + show TVoid = "void" + show (TUser s) = s + show TAny = "any" + show (TArray sz t) = printf "array [%d] of %s" sz (show t) + show (TRecord pairs) = "record " ++ intercalate ", " (map s pairs) ++ " end" + where + s (i,t) = i ++ ": " ++ show t + show (TField _ t) = "record field of type " ++ show t + show (TFunction args TVoid) = + "procedure (" ++ intercalate ", " (map show args) ++ ")" + show (TFunction args res) = + "function (" ++ intercalate ", " (map show args) ++ "): " ++ show res + +-- | Assignment LHS value: variable or array item +data LValue a = + LVariable Id + | LArray Id (Expression :~ a) + | LField Id Id + deriving (Eq) + +instance Show (LValue a) where + show (LVariable n) = n + show (LArray a i) = printf "%s[%s]" a (show i) + show (LField r f) = r ++ "." ++ f + +-- | Program statements +data Statement a = + Assign (LValue :~ a) (Expression :~ a) -- ^ lvalue := expression; + | Procedure Id [Expression :~ a] -- ^ procedureName(arguments); + | Return (Expression :~ a) -- ^ return expression; + | Break -- ^ break (for loop) + | Continue -- ^ contnune (for loop) + | Exit -- ^ exit (procedure or program) + | IfThenElse (Expression :~ a) [Statement :~ a] [Statement :~ a] -- ^ if expression then ... else ... + | For Id (Expression :~ a) (Expression :~ a) [Statement :~ a] -- ^ for i := start to end do ... + deriving (Eq) + +instance Show (Statement a) where + show (Assign lvalue expr) = show lvalue ++ " := " ++ show expr ++ ";" + show (Procedure name args) = name ++ "(" ++ intercalate ", " (map show args) ++ ");" + show Break = "break;" + show Continue = "continue;" + show Exit = "exit;" + show (Return e) = "return " ++ show e ++ ";" + show (IfThenElse c a b) = "if " ++ show c ++ " then " ++ show a ++ "else" ++ show b ++ ";" + show (For name start end body) = "for " ++ name ++ " := " ++ show start ++ " to " ++ show end ++ show body + +-- | Literal values +data Lit = + LInteger Integer + | LString String + | LBool Bool + deriving (Eq) + +instance Show Lit where + show (LInteger i) = show i + show (LString s) = s + show (LBool b) = show b + +-- | Expressions +data Expression a = + Variable Id -- ^ named variable value + | ArrayItem Id (Expression :~ a) -- ^ array item + | RecordField Id Id -- ^ record field + | Literal Lit -- ^ literal value + | Call Id [Expression :~ a] -- ^ functionName(arguments) + | Op BinOp (Expression :~ a) (Expression :~ a) -- ^ binary operation (x+y etc) + deriving (Eq) + +instance Show (Expression a) where + show (Variable x) = x + show (ArrayItem name ix) = printf "%s[%s]" name (show ix) + show (RecordField name field) = name ++ "." ++ field + show (Literal x) = show x + show (Call name args) = name ++ "(" ++ intercalate ", " (map show args) ++ ")" + show (Op op x y) = "(" ++ show x ++ " " ++ show op ++ " " ++ show y ++ ")" + +-- | Supported binary operations +data BinOp = + Add + | Sub + | Mul + | Div + | Mod + | Pow + | IsGT + | IsLT + | IsEQ + | IsNE + deriving (Eq) + +instance Show BinOp where + show Add = "+" + show Sub = "-" + show Mul = "*" + show Div = "/" + show Mod = "%" + show Pow = "^" + show IsGT = ">" + show IsLT = "<" + show IsEQ = "=" + show IsNE = "!=" + +-- | Compiler error +data TError = TError { + errLine :: Int, + errColumn :: Int, + errContext :: Context, + errMessage :: String } + deriving (Eq) + +instance Show TError where + show (TError {..}) = + printf "[l.%d, c.%d] (in %s): %s" errLine errColumn (show errContext) errMessage + +instance Error TError where + noMsg = TError 0 0 Unknown "Unknown error" + strMsg s = TError 0 0 Unknown s + +-- | Compiler context (where we are?) +data Context = + Unknown -- ^ unknown context (== internal error) + | Outside -- ^ Outside program body or functions + | ProgramBody -- ^ In the program body + | ForLoop Id Int -- ^ In the for loop (started on nth instruction, with named counter) + | InFunction Id Type -- ^ In the named function (returning named type) + deriving (Eq) + +instance Show Context where + show Unknown = "unknown context" + show Outside = "outside program body" + show ProgramBody = "program body" + show (ForLoop i _) = "for loop with counter: " ++ i + show (InFunction name TVoid) = "procedure " ++ name + show (InFunction name tp) = printf "function %s(): %s" name (show tp) + +-- | Context ID, for labels and variable names generation +contextId :: Context -> String +contextId Unknown = "unknown" +contextId Outside = "main" +contextId ProgramBody = "main" +contextId (ForLoop i n) = "for_" ++ i ++ "_at_" ++ show n +contextId (InFunction name _) = name + +-- | Type checker state +data CheckState = CheckState { + userTypes :: M.Map Id Type, + userConsts :: [(Id, Expression :~ TypeAnn)], + symbolTable :: SymbolTable, + contexts :: [Context], + ckLine :: Int, + ckColumn :: Int } + deriving (Eq, Show) + +-- | Code generator state +data CodeGenState = CGState { + constants :: [(Id, Lit)], -- + variables :: [Id], -- ^ declared variables (not used currently) + currentContext :: [Context], -- ^ current contexts stack + quoteMode :: Bool, -- ^ quote (word declaration) mode + generated :: Code } -- ^ already generated code + deriving (Eq, Show) + +-- | Starting code generator state +emptyGState :: CodeGenState +emptyGState = CGState { + constants = [], + variables = [], + currentContext = [], + quoteMode = False, + generated = Code [M.empty] [] } + +newtype Generate a = Generate {runGenerate :: ErrorT TError (State CodeGenState) a} + deriving (Monad, MonadState CodeGenState, MonadError TError) + +newtype Check a = Check {runCheck :: ErrorT TError (State CheckState) a} + deriving (Monad, MonadError TError, MonadState CheckState) + +class (Monad m) => Checker m where + enterContext :: Context -> m () + dropContext :: m () + failCheck :: String -> m a + +inContext :: (Checker m) => Context -> m a -> m a +inContext cxt actions = do + enterContext cxt + x <- actions + dropContext + return x + diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,13 @@ +GHC=ghc -fwarn-unused-imports -fwarn-incomplete-patterns --make + +all: spc + +spc: spc.hs Language/Pascal/*.hs + $(GHC) $< + +install: + cabal install --global + +clean: + find . -name \*.hi -delete + find . -name \*.o -delete diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hello.pas b/hello.pas new file mode 100644 --- /dev/null +++ b/hello.pas @@ -0,0 +1,69 @@ +program Hello; + +const + one = 1; + maxIters = 19 + one; + +type + MyRecord = + record + int: integer; + str: string; + z: integer; + end; + + MyArray = array [5] of integer; + +var + i, j: integer; + z: integer; + n: integer; + arr: MyArray; + rec: MyRecord; + +function odd(x: integer): boolean; +begin + return (x%2 = 1); +end; + +procedure hello(a: integer); +begin + writeln("Hello!"); + write(a); + if a = 11 + then exit; + if odd(a) + then writeln(" is odd.") + else writeln(" is even."); +end; + +procedure test_laziness(x: integer, y: integer); +begin + write("Test: "); + writeln(x); +end; + +begin + z := 1; + arr[z] := 25; + arr[4] := z; + writeln(arr); + rec.int := 1/0; + rec.z := 7; + rec.str := "test"; + test_laziness(rec.z - 1, rec.int); + j := 3 + z*2; + write("Enter number: "); + n := readln(); + for i := j*2 to n do + begin + if i = 14 + then continue; + hello(i); + if i = 12 + then writeln("Dozen."); + if i = maxIters + then break; + end; +end. + diff --git a/simple-pascal.cabal b/simple-pascal.cabal new file mode 100644 --- /dev/null +++ b/simple-pascal.cabal @@ -0,0 +1,36 @@ +Name: simple-pascal +Version: 0.1 +Cabal-Version: >= 1.6 +License: BSD3 +License-File: LICENSE +Author: Ilya V. Portnov +Maintainer: portnov84@rambler.ru +Synopsis: Simplified Pascal language to SSVM compiler +Category: Languages, Compilers/Interpreters +Build-Type: Simple +Description: This package provides a compiler for simplified variant of Pascal language. + That language includes conditional statements, for loops, procedures and + functions. But it does not support complex data types (only integer, string + and boolean are supported currently). + This compiler outputs bytecode which may be run by SSVM (see simple-stacked-vm + package). + +Extra-source-files: hello.pas Makefile + +library + Exposed-Modules: Language.Pascal.Types + Language.Pascal.Parser + Language.Pascal.TypeCheck + Language.Pascal.CodeGen + Language.Pascal.Builtin + + Build-Depends: base >= 3 && <= 5, containers, + mtl > 1, filepath, parsec >= 3, + simple-stacked-vm + + ghc-options: -fwarn-unused-imports + +executable spc + Main-is: spc.hs + + diff --git a/spc.hs b/spc.hs new file mode 100644 --- /dev/null +++ b/spc.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RecordWildCards #-} +import Control.Monad (when) +import System.Environment +import System.FilePath +import System.Console.GetOpt +import System.IO + +import Language.SSVM.Types +import Language.SSVM.Binary +import Language.SSVM.Interpreter + +import Language.Pascal.TypeCheck +import Language.Pascal.CodeGen + +data Flag = + Mode Mode + | Output FilePath + | HelpFlag + deriving (Eq, Show) + +data Mode = + Compile + | Assembler + | Interpret + deriving (Eq, Show) + +data Options = + Help + | Run { + mode :: Mode, + inputFile :: FilePath, + outputFile :: Maybe FilePath } + deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Run { + mode = Compile, + inputFile = "-", + outputFile = Nothing } + +options :: [OptDescr Flag] +options = [ + Option "c" ["compile"] (NoArg $ Mode Compile) "compile source code to bytecode", + Option "i" ["interpret"] (NoArg $ Mode Interpret) "compile and interpred compiled bytecode", + Option "S" [] (NoArg $ Mode Assembler) "dump SSVM assembler code", + Option "o" ["output"] (ReqArg Output "FILE") "set output file name", + Option "h" ["help"] (NoArg HelpFlag) "show this help and exit" ] + +usage :: String +usage = usageInfo header options + where + header = "Usage: spc [MODE] [-o OUTPUT] FILE.pas" + +flags2options :: [Flag] -> Options +flags2options = foldl go defaultOptions + where + go acc (Mode m) = acc {mode = m} + go acc (Output path) = acc {outputFile = Just path} + go _ HelpFlag = Help + +parseCmdLine :: [String] -> Either String Options +parseCmdLine args = + case getOpt Permute options args of + (flags, [], []) | HelpFlag `elem` flags -> Right Help + | otherwise -> Left "No input file" + (flags, [file], []) -> Right (flags2options flags) {inputFile = file} + (_, (_:_:_), []) -> Left "More than one input file" + (_, _, errs) -> Left $ unlines errs ++ usage + +main = do + args <- getArgs + case parseCmdLine args of + Left err -> error err + Right Help -> putStrLn usage + Right (Run {..}) -> do + let dst = case outputFile of + Nothing -> replaceExtension inputFile ".bytecode" + Just x -> x + prog <- checkSource inputFile + let codeRev = runCodeGen (generate prog) + code = codeRev {cCode = reverse (cCode codeRev)} + case mode of + Compile -> dumpCode dst code + Assembler -> putStrLn $ showCode code + Interpret -> do + term <- hIsTerminalDevice stdout + when term $ + hSetBuffering stdout NoBuffering + runVM (interpret code) +