sheepy-clone: comparison tools/PascalParser.hs

equal deleted inserted replaced

-:f1b4f37dba22
+:627b5752733a
 data PascalUnit =
 Program Identifier Implementation
 | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
 deriving Show
 data Interface = Interface Uses TypesAndVars
 deriving Show
 data Implementation = Implementation Uses TypesAndVars
 deriving Show
 data Identifier = Identifier String
 deriving Show
 data TypesAndVars = TypesAndVars [TypeVarDeclaration]
 deriving Show
-data TypeVarDeclaration = TypeDeclaration TypeDecl
+data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
-| ConstDeclaration String
+| VarDeclaration Bool ([Identifier], TypeDecl) (Maybe Expression)
-| VarDeclaration Bool String
 | FunctionDeclaration Identifier Identifier (Maybe Phrase)
 deriving Show
 data TypeDecl = SimpleType Identifier
 | RangeType Range
+| Sequence [Identifier]
 | ArrayDecl Range TypeDecl
-deriving Show
+| RecordType [TypeVarDeclaration]
-data Range = Range Identifier
+| UnknownType
+deriving Show
+data Range = Range Identifier
+| RangeFromTo Expression Expression
 deriving Show
 data Initialize = Initialize String
 deriving Show
 data Finalize = Finalize String
 deriving Show
 | Phrases [Phrase]
 | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase)
 | Assignment Reference Expression
 deriving Show
 data Expression = Expression String
-| FunCall Identifier [Expression]
+| FunCall Reference [Expression]
 | PrefixOp String Expression
 | PostfixOp String Expression
 | BinOp String Expression Expression
 | StringLiteral String
+| CharCode String
 | NumberLiteral String
+| HexNumber String
+| Address Reference
 | Reference Reference
 deriving Show
 data Reference = ArrayElement Identifier Expression
 | SimpleReference Identifier
 | RecordField Reference Reference
 "begin", "end", "program", "unit", "interface"
 , "implementation", "and", "or", "xor", "shl"
 , "shr", "while", "do", "repeat", "until", "case", "of"
 , "type", "var", "const", "out", "array"
 , "procedure", "function", "with", "for", "to"
-, "downto", "div", "mod"
+, "downto", "div", "mod", "record", "set"
 ]
 , reservedOpNames= []
 , caseSensitive  = False
 }
 pas = patch $ makeTokenParser pascalLanguageDef
 where
-patch tp = tp {stringLiteral = between (char '\'') (char '\'') (many $ noneOf "'")}
+patch tp = tp {stringLiteral = sl}
+sl = do
+(char '\'')
+s <- (many $ noneOf "'")
+(char '\'')
+ss <- many $ do
+(char '\'')
+s' <- (many $ noneOf "'")
+(char '\'')
+return $ '\'' : s'
+comments
+return $ concat (s:ss)
 comments = do
 spaces
 skipMany $ do
 comment
 table = [
 [Postfix (char '^' >> return Dereference)]
 , [Infix (char '.' >> return RecordField) AssocLeft]
 ]
+varsDecl1 = varsParser many1
-varsDecl endsWithSemi = do
+varsDecl = varsParser many
-vs <- many (try (aVarDecl >> semi pas) >> comments)
+varsParser m endsWithSemi = do
-when (not endsWithSemi) $ aVarDecl >> return ()
+vs <- m (aVarDecl >>= \i -> semi pas >> comments >> return i)
-comments
+v <- if not endsWithSemi then liftM (\a -> [a]) aVarDecl else return []
-return $ VarDeclaration False $ show vs
+comments
+return $ vs ++ v
 where
 aVarDecl = do
 when (not endsWithSemi) $
 optional $ choice [
 try $ string "var"
 , try $ string "const"
 , try $ string "out"
 ]
 comments
-ids <- (commaSep1 pas) $ (iD <?> "variable declaration")
+ids <- try $ do
-char ':'
+i <- (commaSep1 pas) $ (iD <?> "variable declaration")
-comments
+char ':'
-t <- typeDecl
+return i
 comments
-return (ids, t)
+t <- typeDecl <?> "variable type declaration"
+comments
+init <- option Nothing $ do
+char '='
+comments
+e <- expression
+comments
+char ';'
+comments
+return (Just e)
+return $ VarDeclaration False (ids, t) init
 constsDecl = do
-vs <- many (try (aConstDecl >> semi pas) >> comments)
+vs <- many (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
 comments
-return $ VarDeclaration True $ show vs
+return vs
 where
 aConstDecl = do
 comments
-ids <- iD <?> "const declaration"
+i <- iD <?> "const declaration"
 optional $ do
 char ':'
 comments
 t <- typeDecl
 return ()
 char '='
 comments
 e <- expression
 comments
-return (ids, e)
+return $ VarDeclaration False ([i], UnknownType) (Just e)
 typeDecl = choice [
 arrayDecl
+, recordDecl
 , rangeDecl >>= return . RangeType
+, seqenceDecl >>= return . Sequence
 , identifier pas >>= return . SimpleType . Identifier
 ] <?> "type declaration"
 where
 arrayDecl = do
 try $ string "array"
 comments
 string "of"
 comments
 t <- typeDecl
 return $ ArrayDecl r t
+recordDecl = do
+try $ string "record"
+comments
+vs <- varsDecl True
+string "end"
+return $ RecordType vs
+seqenceDecl = (parens pas) $ (commaSep pas) iD
+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 [
-iD >>= return . Range
+try $ rangeft
+, iD >>= return . Range
 ] <?> "range declaration"
+where
+rangeft = do
-typeVarDeclaration isImpl = choice [
+e1 <- expression
+string ".."
+e2 <- expression
+return $ RangeFromTo e1 e2
+typeVarDeclaration isImpl = (liftM concat . many . choice) [
 varSection,
 constSection,
+typeSection,
 funcDecl,
 procDecl
 ]
 where
 varSection = do
 try $ string "var"
 comments
-v <- varsDecl True
+v <- varsDecl1 True
 comments
 return v
 constSection = do
 try $ string "const"
 comments
 c <- constsDecl
 comments
 return c
+typeSection = do
+try $ string "type"
+comments
+t <- typesDecl
+comments
+return t
 procDecl = do
 string "procedure"
 comments
 i <- iD
 comments
 char ';'
 b <- if isImpl then
 do
 comments
-optional $ typeVarDeclaration isImpl
+optional $ typeVarDeclaration True
 comments
 liftM Just functionBody
 else
 return Nothing
 comments
-return $ FunctionDeclaration i (Identifier "") b
+return $ [FunctionDeclaration i (Identifier "") b]
 funcDecl = do
 string "function"
 comments
 i <- iD
 comments
 char ';'
 b <- if isImpl then
 do
 comments
-typeVarDeclaration isImpl
+optional $ typeVarDeclaration True
 comments
 liftM Just functionBody
 else
 return Nothing
-return $ FunctionDeclaration i ret Nothing
+return $ [FunctionDeclaration i ret Nothing]
 program = do
 string "program"
 comments
 name <- iD
 interface = do
 string "interface"
 comments
 u <- uses
 comments
-tv <- many (typeVarDeclaration False)
+tv <- typeVarDeclaration False
 comments
 return $ Interface u (TypesAndVars tv)
 implementation = do
 string "implementation"
 comments
 u <- uses
 comments
-tv <- many (typeVarDeclaration True)
+tv <- typeVarDeclaration True
 string "end."
 comments
 return $ Implementation u (TypesAndVars tv)
 expression = buildExpressionParser table term <?> "expression"
 where
 term = comments >> choice [
 parens pas $ expression
 , integer pas >>= return . NumberLiteral . show
 , stringLiteral pas >>= return . StringLiteral
+, char '#' >> many digit >>= return . CharCode
+, char '$' >> many hexDigit >>= return . HexNumber
+, char '@' >> reference >>= return . Address
 , try $ funCall
 , reference >>= return . Reference
 ] <?> "simple expression"
 table = [
 i <- iD
 p <- option [] $ (parens pas) parameters
 return $ ProcCall i p
 funCall = do
-i <- iD
+r <- reference
 p <- (parens pas) $ option [] parameters
-return $ FunCall i p
+return $ FunCall r p
 parameters = (commaSep pas) expression <?> "parameters"
 functionBody = do
 p <- phrasesBlock

changeset 6277	627b5752733a
parent 6275	f1b4f37dba22
child 6290	c6245ed6cbc0