--- a/tools/PascalParser.hs Fri Nov 04 14:10:27 2011 +0300
+++ b/tools/PascalParser.hs Sat Nov 05 09:37:17 2011 +0300
@@ -14,7 +14,6 @@
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
@@ -23,16 +22,19 @@
deriving Show
data TypesAndVars = TypesAndVars [TypeVarDeclaration]
deriving Show
-data TypeVarDeclaration = TypeDeclaration TypeDecl
- | ConstDeclaration String
- | VarDeclaration Bool String
+data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
+ | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe Expression)
| FunctionDeclaration Identifier Identifier (Maybe Phrase)
deriving Show
data TypeDecl = SimpleType Identifier
| RangeType Range
+ | Sequence [Identifier]
| ArrayDecl Range TypeDecl
+ | RecordType [TypeVarDeclaration]
+ | UnknownType
deriving Show
-data Range = Range Identifier
+data Range = Range Identifier
+ | RangeFromTo Expression Expression
deriving Show
data Initialize = Initialize String
deriving Show
@@ -51,12 +53,15 @@
| 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
@@ -79,7 +84,7 @@
, "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
@@ -87,7 +92,18 @@
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
@@ -136,12 +152,13 @@
, [Infix (char '.' >> return RecordField) AssocLeft]
]
-
-varsDecl endsWithSemi = do
- vs <- many (try (aVarDecl >> semi pas) >> comments)
- when (not endsWithSemi) $ aVarDecl >> return ()
+varsDecl1 = varsParser many1
+varsDecl = varsParser many
+varsParser m endsWithSemi = do
+ vs <- m (aVarDecl >>= \i -> semi pas >> comments >> return i)
+ v <- if not endsWithSemi then liftM (\a -> [a]) aVarDecl else return []
comments
- return $ VarDeclaration False $ show vs
+ return $ vs ++ v
where
aVarDecl = do
when (not endsWithSemi) $
@@ -151,22 +168,32 @@
, try $ string "out"
]
comments
- ids <- (commaSep1 pas) $ (iD <?> "variable declaration")
- char ':'
+ ids <- try $ do
+ i <- (commaSep1 pas) $ (iD <?> "variable declaration")
+ char ':'
+ return i
+ comments
+ t <- typeDecl <?> "variable type declaration"
comments
- t <- typeDecl
- comments
- return (ids, t)
+ 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
@@ -176,11 +203,13 @@
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
@@ -195,16 +224,44 @@
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
+ e1 <- expression
+ string ".."
+ e2 <- expression
+ return $ RangeFromTo e1 e2
-typeVarDeclaration isImpl = choice [
+typeVarDeclaration isImpl = (liftM concat . many . choice) [
varSection,
constSection,
+ typeSection,
funcDecl,
procDecl
]
@@ -212,7 +269,7 @@
varSection = do
try $ string "var"
comments
- v <- varsDecl True
+ v <- varsDecl1 True
comments
return v
@@ -222,6 +279,13 @@
c <- constsDecl
comments
return c
+
+ typeSection = do
+ try $ string "type"
+ comments
+ t <- typesDecl
+ comments
+ return t
procDecl = do
string "procedure"
@@ -236,13 +300,13 @@
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"
@@ -260,12 +324,12 @@
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"
@@ -282,7 +346,7 @@
comments
u <- uses
comments
- tv <- many (typeVarDeclaration False)
+ tv <- typeVarDeclaration False
comments
return $ Interface u (TypesAndVars tv)
@@ -291,7 +355,7 @@
comments
u <- uses
comments
- tv <- many (typeVarDeclaration True)
+ tv <- typeVarDeclaration True
string "end."
comments
return $ Implementation u (TypesAndVars tv)
@@ -302,6 +366,9 @@
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"
@@ -451,9 +518,9 @@
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"
--- a/tools/pas2c.hs Fri Nov 04 14:10:27 2011 +0300
+++ b/tools/pas2c.hs Sat Nov 05 09:37:17 2011 +0300
@@ -3,6 +3,7 @@
import PascalParser
import Text.PrettyPrint.HughesPJ
import Data.Maybe
+import Data.Char
pascal2C :: PascalUnit -> Doc
@@ -36,7 +37,7 @@
where
elsePart | isNothing mphrase2 = empty
| otherwise = text "else" $$ (braces . nest 4 . phrase2C) (fromJust mphrase2)
-phrase2C (Assignment (Identifier name) expr) = text name <> text " = " <> expr2C expr <> semi
+phrase2C (Assignment ref expr) = ref2C ref <> text " = " <> expr2C expr <> semi
phrase2C (WhileCycle expr phrase) = text "while" <> parens (expr2C expr) $$ nest 4 (phrase2C phrase)
phrase2C (SwitchCase expr cases mphrase) = text "switch" <> parens (expr2C expr) <> text "of" $$ (nest 4 . vcat . map case2C) cases
where
@@ -50,14 +51,26 @@
-}
phrase2C _ = empty
+ref2C :: Reference -> Doc
+ref2C (ArrayElement (Identifier name) expr) = text name <> brackets (expr2C expr)
+ref2C (SimpleReference (Identifier name)) = text name
+ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2
+ref2C (Dereference ref) = parens $ text "*" <> ref2C ref
expr2C :: Expression -> Doc
expr2C (Expression s) = text s
-expr2C (FunCall (Identifier name) params) = text name <> parens (hsep . punctuate (char ',') . map expr2C $ params)
+expr2C (FunCall ref params) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params)
expr2C (BinOp op expr1 expr2) = (expr2C expr1) <+> op2C op <+> (expr2C expr2)
-{- | FunCall Identifier [Expression]
+expr2C (NumberLiteral s) = text s
+expr2C (HexNumber s) = text "0x" <> (text . map toLower $ s)
+expr2C (StringLiteral s) = doubleQuotes $ text s
+expr2C (Address ref) = text "&" <> ref2C ref
+expr2C (Reference ref) = ref2C ref
+
+{-
| PrefixOp String Expression
- | BinOp String Expression Expression
+ | PostfixOp String Expression
+ | CharCode String
-}
expr2C _ = empty
@@ -66,6 +79,7 @@
op2C "div" = text "/"
op2C "mod" = text "%"
op2C "<>" = text "!="
+op2C "=" = text "=="
op2C a = text a
maybeVoid "" = "void"