--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalParser.hs Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,659 @@
+module PascalParser where
+
+import Text.Parsec
+import Text.Parsec.Char
+import Text.Parsec.Token
+import Text.Parsec.Language
+import Text.Parsec.Expr
+import Text.Parsec.Prim
+import Text.Parsec.Combinator
+import Text.Parsec.String
+import Control.Monad
+import Data.Maybe
+import Data.Char
+
+import PascalBasics
+import PascalUnitSyntaxTree
+
+knownTypes = ["shortstring", "ansistring", "char", "byte"]
+
+pascalUnit = do
+ comments
+ u <- choice [program, unit, systemUnit, redoUnit]
+ comments
+ return u
+
+iD = do
+ i <- liftM (flip Identifier BTUnknown) (identifier pas)
+ comments
+ return i
+
+unit = do
+ string "unit" >> comments
+ name <- iD
+ semi pas
+ comments
+ int <- interface
+ impl <- implementation
+ comments
+ return $ Unit name int impl Nothing Nothing
+
+
+reference = buildExpressionParser table term <?> "reference"
+ where
+ term = comments >> choice [
+ parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
+ , try $ typeCast >>= postfixes
+ , char '@' >> liftM Address reference >>= postfixes
+ , liftM SimpleReference iD >>= postfixes
+ ] <?> "simple reference"
+
+ table = [
+ ]
+
+ postfixes r = many postfix >>= return . foldl (flip ($)) r
+ postfix = choice [
+ parens pas (option [] parameters) >>= return . FunCall
+ , char '^' >> return Dereference
+ , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
+ , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
+ ]
+
+ typeCast = do
+ t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
+ e <- parens pas expression
+ comments
+ return $ TypeCast (Identifier t BTUnknown) e
+
+varsDecl1 = varsParser sepEndBy1
+varsDecl = varsParser sepEndBy
+varsParser m endsWithSemi = do
+ vs <- m (aVarDecl endsWithSemi) (semi pas)
+ return vs
+
+aVarDecl endsWithSemi = do
+ isVar <- liftM (== Just "var") $
+ if not endsWithSemi then
+ optionMaybe $ choice [
+ try $ string "var"
+ , try $ string "const"
+ , try $ string "out"
+ ]
+ else
+ return Nothing
+ comments
+ ids <- do
+ i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
+ char ':'
+ return i
+ comments
+ t <- typeDecl <?> "variable type declaration"
+ comments
+ init <- option Nothing $ do
+ char '='
+ comments
+ e <- initExpression
+ comments
+ return (Just e)
+ return $ VarDeclaration isVar False (ids, t) init
+
+
+constsDecl = do
+ vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
+ comments
+ return vs
+ where
+ aConstDecl = do
+ comments
+ i <- iD
+ t <- optionMaybe $ do
+ char ':'
+ comments
+ t <- typeDecl
+ comments
+ return t
+ char '='
+ comments
+ e <- initExpression
+ comments
+ return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
+
+typeDecl = choice [
+ char '^' >> typeDecl >>= return . PointerTo
+ , try (string "shortstring") >> return (String 255)
+ , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
+ , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
+ , arrayDecl
+ , recordDecl
+ , setDecl
+ , functionType
+ , sequenceDecl >>= return . Sequence
+ , try iD >>= return . SimpleType
+ , rangeDecl >>= return . RangeType
+ ] <?> "type declaration"
+ where
+ arrayDecl = do
+ try $ do
+ optional $ (try $ string "packed") >> comments
+ string "array"
+ comments
+ r <- option [] $ do
+ char '['
+ r <- commaSep pas rangeDecl
+ char ']'
+ comments
+ return r
+ string "of"
+ comments
+ t <- typeDecl
+ if null r then
+ return $ ArrayDecl Nothing t
+ else
+ return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
+ recordDecl = do
+ try $ do
+ optional $ (try $ string "packed") >> comments
+ string "record"
+ comments
+ vs <- varsDecl True
+ union <- optionMaybe $ do
+ string "case"
+ comments
+ iD
+ comments
+ string "of"
+ comments
+ many unionCase
+ string "end"
+ return $ RecordType vs union
+ setDecl = do
+ try $ string "set" >> space
+ comments
+ string "of"
+ comments
+ liftM Set typeDecl
+ unionCase = do
+ try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
+ char ':'
+ comments
+ u <- parens pas $ varsDecl True
+ char ';'
+ comments
+ return u
+ sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
+ functionType = do
+ fp <- try (string "function") <|> try (string "procedure")
+ comments
+ vs <- option [] $ parens pas $ varsDecl False
+ comments
+ ret <- if (fp == "function") then do
+ char ':'
+ comments
+ ret <- typeDecl
+ comments
+ return ret
+ else
+ return VoidType
+ optional $ try $ char ';' >> comments >> string "cdecl"
+ comments
+ return $ FunctionType ret vs
+
+typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
+ where
+ aTypeDecl = do
+ i <- try $ do
+ i <- iD <?> "type declaration"
+ comments
+ char '='
+ return i
+ comments
+ t <- typeDecl
+ comments
+ semi pas
+ comments
+ return $ TypeDeclaration i t
+
+rangeDecl = choice [
+ try $ rangeft
+ , iD >>= return . Range
+ ] <?> "range declaration"
+ where
+ rangeft = do
+ e1 <- initExpression
+ string ".."
+ e2 <- initExpression
+ return $ RangeFromTo e1 e2
+
+typeVarDeclaration isImpl = (liftM concat . many . choice) [
+ varSection,
+ constSection,
+ typeSection,
+ funcDecl,
+ operatorDecl
+ ]
+ where
+ varSection = do
+ try $ string "var"
+ comments
+ v <- varsDecl1 True <?> "variable declaration"
+ comments
+ return v
+
+ constSection = do
+ try $ string "const"
+ comments
+ c <- constsDecl <?> "const declaration"
+ comments
+ return c
+
+ typeSection = do
+ try $ string "type"
+ comments
+ t <- typesDecl <?> "type declaration"
+ comments
+ return t
+
+ operatorDecl = do
+ try $ string "operator"
+ comments
+ i <- manyTill anyChar space
+ comments
+ vs <- parens pas $ varsDecl False
+ comments
+ rid <- iD
+ comments
+ char ':'
+ comments
+ ret <- typeDecl
+ comments
+ return ret
+ char ';'
+ comments
+ forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
+ inline <- liftM (any (== "inline;")) $ many functionDecorator
+ b <- if isImpl && (not forward) then
+ liftM Just functionBody
+ else
+ return Nothing
+ return $ [OperatorDeclaration i rid inline ret vs b]
+
+
+ funcDecl = do
+ fp <- try (string "function") <|> try (string "procedure")
+ comments
+ i <- iD
+ vs <- option [] $ parens pas $ varsDecl False
+ comments
+ ret <- if (fp == "function") then do
+ char ':'
+ comments
+ ret <- typeDecl
+ comments
+ return ret
+ else
+ return VoidType
+ char ';'
+ comments
+ forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
+ inline <- liftM (any (== "inline;")) $ many functionDecorator
+ b <- if isImpl && (not forward) then
+ liftM Just functionBody
+ else
+ return Nothing
+ return $ [FunctionDeclaration i inline ret vs b]
+
+ functionDecorator = do
+ d <- choice [
+ try $ string "inline;"
+ , try $ caseInsensitiveString "cdecl;"
+ , try $ string "overload;"
+ , try $ string "export;"
+ , try $ string "varargs;"
+ , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
+ ]
+ comments
+ return d
+
+
+program = do
+ string "program"
+ comments
+ name <- iD
+ (char ';')
+ comments
+ comments
+ u <- uses
+ comments
+ tv <- typeVarDeclaration True
+ comments
+ p <- phrase
+ comments
+ char '.'
+ comments
+ return $ Program name (Implementation u (TypesAndVars tv)) p
+
+interface = do
+ string "interface"
+ comments
+ u <- uses
+ comments
+ tv <- typeVarDeclaration False
+ comments
+ return $ Interface u (TypesAndVars tv)
+
+implementation = do
+ string "implementation"
+ comments
+ u <- uses
+ comments
+ tv <- typeVarDeclaration True
+ string "end."
+ comments
+ return $ Implementation u (TypesAndVars tv)
+
+expression = do
+ buildExpressionParser table term <?> "expression"
+ where
+ term = comments >> choice [
+ builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
+ , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
+ , brackets pas (commaSep pas iD) >>= return . SetExpression
+ , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
+ , float pas >>= return . FloatLiteral . show
+ , try $ integer pas >>= return . NumberLiteral . show
+ , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
+ , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
+ , stringLiteral pas >>= return . strOrChar
+ , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
+ , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
+ , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h)
+ --, char '-' >> expression >>= return . PrefixOp "-"
+ , char '-' >> reference >>= return . PrefixOp "-" . Reference
+ , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"
+ , try $ string "nil" >> return Null
+ , reference >>= return . Reference
+ ] <?> "simple expression"
+
+ table = [
+ [ Prefix (try (string "not") >> return (PrefixOp "not"))
+ , Prefix (try (char '-') >> return (PrefixOp "-"))]
+ ,
+ [ Infix (char '*' >> return (BinOp "*")) AssocLeft
+ , Infix (char '/' >> return (BinOp "/")) AssocLeft
+ , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
+ , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
+ , Infix (try (string "in") >> return (BinOp "in")) AssocNone
+ , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
+ , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
+ , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
+ ]
+ , [ Infix (char '+' >> return (BinOp "+")) AssocLeft
+ , Infix (char '-' >> return (BinOp "-")) AssocLeft
+ , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
+ ]
+ , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
+ , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
+ , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
+ , Infix (char '<' >> return (BinOp "<")) AssocNone
+ , Infix (char '>' >> return (BinOp ">")) AssocNone
+ ]
+ {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
+ ]
+ , [
+ Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
+ ]-}
+ , [
+ Infix (char '=' >> return (BinOp "=")) AssocNone
+ ]
+ ]
+ strOrChar [a] = CharCode . show . ord $ a
+ strOrChar a = StringLiteral a
+
+phrasesBlock = do
+ try $ string "begin"
+ comments
+ p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
+ comments
+ return $ Phrases p
+
+phrase = do
+ o <- choice [
+ phrasesBlock
+ , ifBlock
+ , whileCycle
+ , repeatCycle
+ , switchCase
+ , withBlock
+ , forCycle
+ , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
+ , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
+ , procCall
+ , char ';' >> comments >> return NOP
+ ]
+ optional $ char ';'
+ comments
+ return o
+
+ifBlock = do
+ try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
+ comments
+ e <- expression
+ comments
+ string "then"
+ comments
+ o1 <- phrase
+ comments
+ o2 <- optionMaybe $ do
+ try $ string "else" >> space
+ comments
+ o <- option NOP phrase
+ comments
+ return o
+ return $ IfThenElse e o1 o2
+
+whileCycle = do
+ try $ string "while"
+ comments
+ e <- expression
+ comments
+ string "do"
+ comments
+ o <- phrase
+ return $ WhileCycle e o
+
+withBlock = do
+ try $ string "with" >> space
+ comments
+ rs <- (commaSep1 pas) reference
+ comments
+ string "do"
+ comments
+ o <- phrase
+ return $ foldr WithBlock o rs
+
+repeatCycle = do
+ try $ string "repeat" >> space
+ comments
+ o <- many phrase
+ string "until"
+ comments
+ e <- expression
+ comments
+ return $ RepeatCycle e o
+
+forCycle = do
+ try $ string "for" >> space
+ comments
+ i <- iD
+ comments
+ string ":="
+ comments
+ e1 <- expression
+ comments
+ up <- liftM (== Just "to") $
+ optionMaybe $ choice [
+ try $ string "to"
+ , try $ string "downto"
+ ]
+ --choice [string "to", string "downto"]
+ comments
+ e2 <- expression
+ comments
+ string "do"
+ comments
+ p <- phrase
+ comments
+ return $ ForCycle i e1 e2 p up
+
+switchCase = do
+ try $ string "case"
+ comments
+ e <- expression
+ comments
+ string "of"
+ comments
+ cs <- many1 aCase
+ o2 <- optionMaybe $ do
+ try $ string "else" >> notFollowedBy alphaNum
+ comments
+ o <- many phrase
+ comments
+ return o
+ string "end"
+ comments
+ return $ SwitchCase e cs o2
+ where
+ aCase = do
+ e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
+ comments
+ char ':'
+ comments
+ p <- phrase
+ comments
+ return (e, p)
+
+procCall = do
+ r <- reference
+ p <- option [] $ (parens pas) parameters
+ return $ ProcCall r p
+
+parameters = (commaSep pas) expression <?> "parameters"
+
+functionBody = do
+ tv <- typeVarDeclaration True
+ comments
+ p <- phrasesBlock
+ char ';'
+ comments
+ return (TypesAndVars tv, p)
+
+uses = liftM Uses (option [] u)
+ where
+ u = do
+ string "uses"
+ comments
+ u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
+ char ';'
+ comments
+ return u
+
+initExpression = buildExpressionParser table term <?> "initialization expression"
+ where
+ term = comments >> choice [
+ liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
+ , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
+ , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia)
+ , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
+ , parens pas initExpression
+ , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
+ , try $ float pas >>= return . InitFloat . show
+ , try $ integer pas >>= return . InitNumber . show
+ , stringLiteral pas >>= return . InitString
+ , char '#' >> many digit >>= \c -> comments >> return (InitChar c)
+ , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
+ , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
+ , try $ string "nil" >> return InitNull
+ , itypeCast
+ , iD >>= return . InitReference
+ ]
+
+ recField = do
+ i <- iD
+ spaces
+ char ':'
+ spaces
+ e <- initExpression
+ spaces
+ return (i ,e)
+
+ table = [
+ [
+ Prefix (char '-' >> return (InitPrefixOp "-"))
+ ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
+ ]
+ , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft
+ , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
+ , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
+ , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
+ , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+ , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
+ ]
+ , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft
+ , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
+ , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
+ ]
+ , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
+ , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
+ , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
+ , Infix (char '<' >> return (InitBinOp "<")) AssocNone
+ , Infix (char '>' >> return (InitBinOp ">")) AssocNone
+ , Infix (char '=' >> return (InitBinOp "=")) AssocNone
+ ]
+ {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+ , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
+ ]
+ , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
+ ]--}
+ --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
+ ]
+
+ itypeCast = do
+ t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
+ i <- parens pas initExpression
+ comments
+ return $ InitTypeCast (Identifier t BTUnknown) i
+
+builtInFunction e = do
+ name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
+ spaces
+ exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
+ spaces
+ return (name, exprs)
+
+systemUnit = do
+ string "system;"
+ comments
+ string "type"
+ comments
+ t <- typesDecl
+ string "var"
+ v <- varsDecl True
+ return $ System (t ++ v)
+
+redoUnit = do
+ string "redo;"
+ comments
+ string "type"
+ comments
+ t <- typesDecl
+ string "var"
+ v <- varsDecl True
+ return $ Redo (t ++ v)
+