simple-pascal (empty) → 0.1
raw patch · 11 files changed
+1933/−0 lines, 11 filesdep +basedep +containersdep +filepathsetup-changed
Dependencies added: base, containers, filepath, mtl, parsec, simple-stacked-vm
Files
- LICENSE +165/−0
- Language/Pascal/Builtin.hs +60/−0
- Language/Pascal/CodeGen.hs +397/−0
- Language/Pascal/Parser.hs +300/−0
- Language/Pascal/TypeCheck.hs +480/−0
- Language/Pascal/Types.hs +321/−0
- Makefile +13/−0
- Setup.hs +2/−0
- hello.pas +69/−0
- simple-pascal.cabal +36/−0
- spc.hs +90/−0
+ 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/Pascal/Builtin.hs view
@@ -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+
+ Language/Pascal/CodeGen.hs view
@@ -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+
+ Language/Pascal/Parser.hs view
@@ -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
+ Language/Pascal/TypeCheck.hs view
@@ -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)+
+ Language/Pascal/Types.hs view
@@ -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+
+ Makefile view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hello.pas view
@@ -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.+
+ simple-pascal.cabal view
@@ -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++
+ spc.hs view
@@ -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)+