--- a/tools/pas2c/Pas2C.hs Thu Feb 06 23:02:35 2014 +0400
+++ b/tools/pas2c/Pas2C.hs Fri Feb 07 00:46:49 2014 +0400
@@ -7,8 +7,6 @@
import Text.Parsec.Prim hiding (State)
import Control.Monad.State
import System.IO
-import System.Directory
-import Control.Monad.IO.Class
import PascalPreprocessor
import Control.Exception
import System.IO.Error
@@ -53,8 +51,10 @@
namespaces :: Map.Map String Records
}
+rec2Records :: [(String, BaseType)] -> [Record]
rec2Records = map (\(a, b) -> Record a b empty)
+emptyState :: Map.Map String Records -> RenderState
emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
getUniq :: State RenderState Int
@@ -102,22 +102,22 @@
renderCFiles s outputPath
where
printLn = liftIO . hPutStrLn stdout
- print = liftIO . hPutStr stdout
+ print' = liftIO . hPutStr stdout
initState = Map.empty
f :: String -> StateT (Map.Map String PascalUnit) IO ()
f fileName = do
processed <- gets $ Map.member fileName
unless processed $ do
- print ("Preprocessing '" ++ fileName ++ ".pas'... ")
+ print' ("Preprocessing '" ++ fileName ++ ".pas'... ")
fc' <- liftIO
$ tryJust (guard . isDoesNotExistError)
$ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
case fc' of
- (Left a) -> do
+ (Left _) -> do
modify (Map.insert fileName (System []))
printLn "doesn't exist"
(Right fc) -> do
- print "ok, parsing... "
+ print' "ok, parsing... "
let ptree = parse pascalUnit fileName fc
case ptree of
(Left a) -> do
@@ -159,16 +159,16 @@
withState' f sf = do
st <- liftM f get
let (a, s) = runState sf st
- modify(\st -> st{
+ modify(\st' -> st'{
lastType = lastType s
, uniqCounter = uniqCounter s
, stringConsts = stringConsts s
})
return a
+withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
withLastIdNamespace f = do
li <- gets lastIdentifier
- nss <- gets namespaces
withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
@@ -178,34 +178,36 @@
f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
un [a] b = a : b
+ un _ _ = error "withRecordNamespace un: pattern not matched"
toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
toCFiles _ _ (_, System _) = return ()
toCFiles _ _ (_, Redo _) = return ()
-toCFiles outputPath ns p@(fn, pu) = do
- hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
- toCFiles' p
+toCFiles outputPath ns pu@(fileName, _) = do
+ hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
+ toCFiles' pu
where
toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
- (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
+ (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
enumDecl = (renderEnum2Strs (enums s) False)
enumImpl = (renderEnum2Strs (enums s) True)
writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl
writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
+ toCFiles' _ = undefined -- just pleasing compiler to not warn us
initialState = emptyState ns
render2C :: RenderState -> State RenderState Doc -> String
render2C st p =
- let (a, s) = runState p st in
+ let (a, _) = runState p st in
render a
renderEnum2Strs :: [(String, [String])] -> Bool -> String
-renderEnum2Strs enums implement =
- render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums
+renderEnum2Strs enums' implement =
+ render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums'
where
- decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar")
+ decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar")
enum2strBlock en =
text "{"
$+$
@@ -230,7 +232,7 @@
usesFiles (Redo {}) = []
pascal2C :: PascalUnit -> State RenderState Doc
-pascal2C (Unit _ interface implementation init fin) =
+pascal2C (Unit _ interface implementation _ _) =
liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
pascal2C (Program _ implementation mainFunction) = do
@@ -239,6 +241,7 @@
return $ impl $+$ main
+pascal2C _ = error "pascal2C: pattern not matched"
-- the second bool indicates whether do normal interface translation or generate variable declarations
-- that will be inserted into implementation files
@@ -249,9 +252,9 @@
r <- renderStringConsts
return (u $+$ r $+$ tv)
interface2C (Interface uses tvars) False = do
- u <- uses2C uses
+ void $ uses2C uses
tv <- typesAndVars2C True False False tvars
- r <- renderStringConsts
+ void $ renderStringConsts
return tv
implementation2C :: Implementation -> State RenderState Doc
@@ -265,6 +268,7 @@
checkDuplicateFunDecls tvs =
modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
where
+ initMap :: Map.Map String Int
initMap = Map.empty
--initMap = Map.fromList [("reset", 2)]
ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
@@ -297,18 +301,18 @@
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
+setLastIdValues :: Record -> RenderState -> RenderState
setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
id2C :: InsertOption -> Identifier -> State RenderState Doc
id2C IOInsert i = id2C (IOInsertWithType empty) i
id2C (IOInsertWithType d) (Identifier i t) = do
- ns <- gets currentScope
tom <- gets (Set.member n . toMangle)
cu <- gets currentUnit
let (i', t') = case (t, tom) of
(BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t)
(BTFunction _ _ _, _) -> (cu ++ i, t)
- (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
+ (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'')
_ -> (i, t)
modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
return $ text i'
@@ -317,7 +321,7 @@
id2C IOLookup i = id2CLookup head i
id2C IOLookupLast i = id2CLookup last i
-id2C (IOLookupFunction params) (Identifier i t) = do
+id2C (IOLookupFunction params) (Identifier i _) = do
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
lt <- gets lastType
@@ -329,7 +333,7 @@
where
checkParam (Record _ (BTFunction _ p _) _) = (length p) == params
checkParam _ = False
-id2C IODeferred (Identifier i t) = do
+id2C IODeferred (Identifier i _) = do
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
if (isNothing v) then
@@ -338,7 +342,7 @@
let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
-id2CLookup f (Identifier i t) = do
+id2CLookup f (Identifier i _) = do
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
lt <- gets lastType
@@ -405,6 +409,7 @@
where
f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
+ f _ = error "resolveType f: pattern not matched"
resolveType (ArrayDecl (Just i) t) = do
t' <- resolveType t
return $ BTArray i (BTInt True) t'
@@ -444,6 +449,7 @@
error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
+functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
numberOfDeclarations :: [TypeVarDeclaration] -> Int
@@ -473,7 +479,7 @@
ps = zip ['a'..] (toIsVarList params)
fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
-fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do
+fun2C _ _ (FunctionDeclaration name _ overload returnType params Nothing) = do
t <- type2C returnType
t'<- gets lastType
bts <- typeVarDecl2BaseType params
@@ -482,7 +488,7 @@
let decor = if overload then text "__attribute__((overloadable))" else empty
return [t empty <+> decor <+> text n <> parens p]
-fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do
+fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload returnType params (Just (tvars, phrase))) = do
let isVoid = case returnType of
VoidType -> True
_ -> False
@@ -492,7 +498,7 @@
t' <- gets lastType
bts <- typeVarDecl2BaseType params
- cu <- gets currentUnit
+ --cu <- gets currentUnit
notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name
@@ -507,7 +513,7 @@
return (p, ph)
let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
- let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
+ --let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
let inlineDecor = if inline then case notDeclared of
True -> text "static inline"
False -> text "inline"
@@ -528,6 +534,7 @@
phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
phrase2C' p = phrase2C p
un [a] b = a : b
+ un _ _ = error "fun2C u: pattern not matched"
hasVars = hasPassByReference params
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
@@ -540,13 +547,13 @@
tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do
t <- fun2C b name f
if includeType then return t else return []
-tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
+tvar2C _ _ includeType _ (TypeDeclaration i' t) = do
i <- id2CTyped t i'
tp <- type2C t
let res = if includeType then [text "typedef" <+> tp i] else []
case t of
(Sequence ids) -> do
- modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s})
+ modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s})
return res
_ -> return res
@@ -567,15 +574,15 @@
return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
(True, BTFloat, [i], Just e) -> do
i' <- id2CTyped t i
- ie <- initExpr2C e
- return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
+ ie' <- initExpr2C e
+ return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else []
(_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
(_, BTArray r _ _, [i], _) -> do
i' <- id2CTyped t i
ie' <- return $ case (r, mInitExpr, ignoreInit) of
(RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
(_, _, _) -> ie
- result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
+ result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids
case (r, ignoreInit) of
(RangeInfinite, False) ->
-- if the array is dynamic, add dimension info to it
@@ -594,9 +601,10 @@
varDeclDecision True True varStr expStr = varStr <+> expStr
varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
varDeclDecision False False varStr expStr = varStr <+> expStr
- varDeclDecision True False varStr expStr = empty
+ varDeclDecision True False _ _ = empty
arrayDimension a = case a of
- ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
+ ArrayDecl Nothing t' -> let a' = arrayDimension t' in
+ if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a'
ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
_ -> 0
@@ -607,7 +615,7 @@
op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
op2CTyped op t = do
- t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
+ t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t
bt <- gets lastType
return $ Identifier (t' ++ "_op_" ++ opStr) bt
where
@@ -645,7 +653,7 @@
e2 <- initExpr2C' expr2
return $ parens $ e1 <+> text (op2C op) <+> e2
initExpr2C' (InitNumber s) = do
- modify(\s -> s{lastType = (BTInt True)})
+ modify(\st -> st{lastType = (BTInt True)})
return $ text s
initExpr2C' (InitFloat s) = return $ text s
initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
@@ -660,7 +668,7 @@
-- e <- initExpr2C $ InitRecord fields
-- return $ braces $ e
initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
- id2C IOLookup i
+ void $ id2C IOLookup i
t <- gets lastType
case t of
BTEnum s -> return . int $ length s
@@ -672,14 +680,14 @@
initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
initExpr2C' (InitSet []) = return $ text "0"
-initExpr2C' (InitSet a) = return $ text "<<set>>"
+initExpr2C' (InitSet _) = return $ text "<<set>>"
initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
case e of
(Identifier "LongInt" _) -> int (-2^31)
(Identifier "SmallInt" _) -> int (-2^15)
_ -> error $ "BuiltInFunction 'low': " ++ show e
initExpr2C' (BuiltInFunction "high" [e]) = do
- initExpr2C e
+ void $ initExpr2C e
t <- gets lastType
case t of
(BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
@@ -705,7 +713,7 @@
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
type2C :: TypeDecl -> State RenderState (Doc -> Doc)
-type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
+type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
type2C t = do
r <- type2C' t
rt <- resolveType t
@@ -721,11 +729,11 @@
BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
_ -> return $ \a -> i' <+> text "*" <+> a
- type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
+ type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t
type2C' (RecordType tvs union) = do
- t <- withState' f $ mapM (tvar2C False False True False) tvs
+ t' <- withState' f $ mapM (tvar2C False False True False) tvs
u <- unions
- return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
+ return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i
where
f s = s{currentUnit = ""}
unions = case union of
@@ -733,9 +741,9 @@
Just a -> do
structs <- mapM struct2C a
return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
- struct2C tvs = do
- t <- withState' f $ mapM (tvar2C False False True False) tvs
- return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
+ struct2C stvs = do
+ txts <- withState' f $ mapM (tvar2C False False True False) stvs
+ return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi
type2C' (RangeType r) = return (text "int" <+>)
type2C' (Sequence ids) = do
is <- mapM (id2C IOInsert . setBaseType bt) ids
@@ -768,6 +776,7 @@
t <- gets lastType
return (baseType2C (show r) t <+>)
type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
+ type2C' a = error $ "type2C: unknown type " ++ show a
phrase2C :: Phrase -> State RenderState Doc
phrase2C (Phrases p) = do
@@ -775,7 +784,7 @@
return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
-phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
+phrase2C (ProcCall _ _) = error $ "ProcCall"{-do
r <- ref2C ref
ps <- mapM expr2C params
return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
@@ -796,7 +805,7 @@
e <- ref2C r'
return $ r <+> text "=" <+> e <> semi
(BTString, _) -> do
- e <- expr2C expr
+ void $ expr2C expr
lt <- gets lastType
case lt of
-- assume pointer to char for simplicity
@@ -810,7 +819,7 @@
(BTArray _ _ _, _) -> do
case expr of
Reference er -> do
- exprRef <- ref2C er
+ void $ ref2C er
exprT <- gets lastType
case exprT of
BTArray RangeInfinite _ _ ->
@@ -904,7 +913,7 @@
expr2C :: Expression -> State RenderState Doc
expr2C (Expression s) = return $ text s
-expr2C b@(BinOp op expr1 expr2) = do
+expr2C (BinOp op expr1 expr2) = do
e1 <- expr2C expr1
t1 <- gets lastType
e2 <- expr2C expr2
@@ -1006,7 +1015,7 @@
e' <- liftM (map toLower . render) $ expr2C e
lt <- gets lastType
case lt of
- BTEnum a -> return $ int 0
+ BTEnum _-> return $ int 0
BTInt _ -> case e' of
"longint" -> return $ int (-2147483648)
BTArray {} -> return $ int 0
--- a/tools/pas2c/PascalBasics.hs Thu Feb 06 23:02:35 2014 +0400
+++ b/tools/pas2c/PascalBasics.hs Fri Feb 07 00:46:49 2014 +0400
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
module PascalBasics where
import Text.Parsec.Combinator
@@ -7,9 +7,19 @@
import Text.Parsec.Token
import Text.Parsec.Language
import Data.Char
+import Control.Monad
+import Data.Functor.Identity
+char' :: Char -> Parsec String u ()
+char' = void . char
+
+string' :: String -> Parsec String u ()
+string' = void . string
+
+builtin :: [String]
builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
+pascalLanguageDef :: GenLanguageDef String u Identity
pascalLanguageDef
= emptyDef
{ commentStart = "(*"
@@ -31,40 +41,45 @@
, caseSensitive = False
}
-preprocessorSwitch :: Stream s m Char => ParsecT s u m String
+preprocessorSwitch :: Stream String Identity Char => Parsec String u String
preprocessorSwitch = do
- try $ string "{$"
+ try $ string' "{$"
s <- manyTill (noneOf "\n") $ char '}'
return s
+caseInsensitiveString :: Stream String Identity Char => String -> Parsec String u String
caseInsensitiveString s = do
mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
return s
+pas :: GenTokenParser String u Identity
pas = patch $ makeTokenParser pascalLanguageDef
where
patch tp = tp {stringLiteral = stringL}
+comment :: Stream String Identity Char => Parsec String u String
comment = choice [
char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
, (try $ string "(*") >> manyTill anyChar (try $ string "*)")
, (try $ string "//") >> manyTill anyChar (try newline)
]
+comments :: Parsec String u ()
comments = do
spaces
skipMany $ do
- preprocessorSwitch <|> comment
+ void $ preprocessorSwitch <|> comment
spaces
+stringL :: Parsec String u String
stringL = do
- (char '\'')
+ char' '\''
s <- (many $ noneOf "'")
- (char '\'')
+ char' '\''
ss <- many $ do
- (char '\'')
+ char' '\''
s' <- (many $ noneOf "'")
- (char '\'')
+ char' '\''
return $ '\'' : s'
comments
return $ concat (s:ss)
--- a/tools/pas2c/PascalParser.hs Thu Feb 06 23:02:35 2014 +0400
+++ b/tools/pas2c/PascalParser.hs Fri Feb 07 00:46:49 2014 +0400
@@ -1,13 +1,11 @@
-module PascalParser where
+module PascalParser (
+ pascalUnit
+ )
+ 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
@@ -15,24 +13,28 @@
import PascalBasics
import PascalUnitSyntaxTree
+knownTypes :: [String]
knownTypes = ["shortstring", "ansistring", "char", "byte"]
+pascalUnit :: Parsec String u PascalUnit
pascalUnit = do
comments
u <- choice [program, unit, systemUnit, redoUnit]
comments
return u
+iD :: Parsec String u Identifier
iD = do
i <- identifier pas
comments
when (i == "not") $ unexpected "'not' used as an identifier"
return $ Identifier i BTUnknown
+unit :: Parsec String u PascalUnit
unit = do
- string "unit" >> comments
+ string' "unit" >> comments
name <- iD
- semi pas
+ void $ semi pas
comments
int <- interface
impl <- implementation
@@ -40,12 +42,13 @@
return $ Unit name int impl Nothing Nothing
+reference :: Parsec String u Reference
reference = buildExpressionParser table term <?> "reference"
where
term = comments >> choice [
parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
, try $ typeCast >>= postfixes
- , char '@' >> liftM Address reference >>= postfixes
+ , char' '@' >> liftM Address reference >>= postfixes
, liftM SimpleReference iD >>= postfixes
] <?> "simple reference"
@@ -55,9 +58,9 @@
postfixes r = many postfix >>= return . foldl (flip ($)) r
postfix = choice [
parens pas (option [] parameters) >>= return . FunCall
- , char '^' >> return Dereference
+ , char' '^' >> return Dereference
, (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
- , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
+ , (char' '.' >> notFollowedBy (char' '.')) >> liftM (flip RecordField) reference
]
typeCast = do
@@ -66,12 +69,23 @@
comments
return $ TypeCast (Identifier t BTUnknown) e
+varsDecl1, varsDecl :: Bool -> Parsec String u [TypeVarDeclaration]
varsDecl1 = varsParser sepEndBy1
varsDecl = varsParser sepEndBy
+
+varsParser ::
+ (Parsec String u TypeVarDeclaration
+ -> Parsec String u String
+ -> Parsec
+ String u [TypeVarDeclaration])
+ -> Bool
+ -> Parsec
+ String u [TypeVarDeclaration]
varsParser m endsWithSemi = do
vs <- m (aVarDecl endsWithSemi) (semi pas)
return vs
+aVarDecl :: Bool -> Parsec String u TypeVarDeclaration
aVarDecl endsWithSemi = do
isVar <- liftM (== Just "var") $
if not endsWithSemi then
@@ -85,20 +99,20 @@
comments
ids <- do
i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
- char ':'
+ char' ':'
return i
comments
t <- typeDecl <?> "variable type declaration"
comments
- init <- option Nothing $ do
- char '='
+ initialization <- option Nothing $ do
+ char' '='
comments
e <- initExpression
comments
return (Just e)
- return $ VarDeclaration isVar False (ids, t) init
+ return $ VarDeclaration isVar False (ids, t) initialization
-
+constsDecl :: Parsec String u [TypeVarDeclaration]
constsDecl = do
vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
comments
@@ -108,22 +122,23 @@
comments
i <- iD
t <- optionMaybe $ do
- char ':'
+ char' ':'
comments
t <- typeDecl
comments
return t
- char '='
+ char' '='
comments
e <- initExpression
comments
return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
+typeDecl :: Parsec String u TypeDecl
typeDecl = choice [
- char '^' >> typeDecl >>= return . PointerTo
- , try (string "shortstring") >> return String
- , try (string "string") >> optionMaybe (brackets pas $ integer pas) >> return String
- , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >> return String
+ char' '^' >> typeDecl >>= return . PointerTo
+ , try (string' "shortstring") >> return String
+ , try (string' "string") >> optionMaybe (brackets pas $ integer pas) >> return String
+ , try (string' "ansistring") >> optionMaybe (brackets pas $ integer pas) >> return String
, arrayDecl
, recordDecl
, setDecl
@@ -135,16 +150,16 @@
where
arrayDecl = do
try $ do
- optional $ (try $ string "packed") >> comments
- string "array"
+ optional $ (try $ string' "packed") >> comments
+ string' "array"
comments
r <- option [] $ do
- char '['
+ char' '['
r <- commaSep pas rangeDecl
- char ']'
+ char' ']'
comments
return r
- string "of"
+ string' "of"
comments
t <- typeDecl
if null r then
@@ -153,67 +168,69 @@
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"
+ optional $ (try $ string' "packed") >> comments
+ string' "record"
comments
vs <- varsDecl True
union <- optionMaybe $ do
- string "case"
+ string' "case"
comments
- iD
+ void $ iD
comments
- string "of"
+ string' "of"
comments
many unionCase
- string "end"
+ string' "end"
return $ RecordType vs union
setDecl = do
- try $ string "set" >> space
+ try $ string' "set" >> void space
comments
- string "of"
+ string' "of"
comments
liftM Set typeDecl
unionCase = do
- try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
- char ':'
+ void $ try $ commaSep pas $ (void $ iD) <|> (void $ integer pas)
+ char' ':'
comments
u <- parens pas $ varsDecl True
- char ';'
+ char' ';'
comments
return u
- sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
+ 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 ':'
+ char' ':'
comments
ret <- typeDecl
comments
return ret
else
return VoidType
- optional $ try $ char ';' >> comments >> string "cdecl"
+ optional $ try $ char' ';' >> comments >> string' "cdecl"
comments
return $ FunctionType ret vs
+typesDecl :: Parsec String u [TypeVarDeclaration]
typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
where
aTypeDecl = do
i <- try $ do
i <- iD <?> "type declaration"
comments
- char '='
+ char' '='
return i
comments
t <- typeDecl
comments
- semi pas
+ void $ semi pas
comments
return $ TypeDeclaration i t
+rangeDecl :: Parsec String u Range
rangeDecl = choice [
try $ rangeft
, iD >>= return . Range
@@ -221,10 +238,11 @@
where
rangeft = do
e1 <- initExpression
- string ".."
+ string' ".."
e2 <- initExpression
return $ RangeFromTo e1 e2
+typeVarDeclaration :: Bool -> Parsec String u [TypeVarDeclaration]
typeVarDeclaration isImpl = (liftM concat . many . choice) [
varSection,
constSection,
@@ -245,28 +263,28 @@
_ -> error ("checkInit:\n" ++ (show v))) v
varSection = do
- try $ string "var"
+ try $ string' "var"
comments
v <- varsDecl1 True <?> "variable declaration"
comments
return $ fixInit v
constSection = do
- try $ string "const"
+ try $ string' "const"
comments
c <- constsDecl <?> "const declaration"
comments
return $ fixInit c
typeSection = do
- try $ string "type"
+ try $ string' "type"
comments
t <- typesDecl <?> "type declaration"
comments
return t
operatorDecl = do
- try $ string "operator"
+ try $ string' "operator"
comments
i <- manyTill anyChar space
comments
@@ -274,14 +292,15 @@
comments
rid <- iD
comments
- char ':'
+ char' ':'
comments
ret <- typeDecl
comments
- return ret
- char ';'
+ -- return ret
+ -- ^^^^^^^^^^ wth was this???
+ char' ';'
comments
- forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
+ forward <- liftM isJust $ optionMaybe (try (string' "forward;") >> comments)
inline <- liftM (any (== "inline;")) $ many functionDecorator
b <- if isImpl && (not forward) then
liftM Just functionBody
@@ -297,14 +316,14 @@
vs <- option [] $ parens pas $ varsDecl False
comments
ret <- if (fp == "function") then do
- char ':'
+ char' ':'
comments
ret <- typeDecl
comments
return ret
else
return VoidType
- char ';'
+ char' ';'
comments
forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
decorators <- many functionDecorator
@@ -323,17 +342,18 @@
, try $ string "overload;"
, try $ string "export;"
, try $ string "varargs;"
- , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
+ , try (string' "external") >> comments >> iD >> optional (string' "name" >> comments >> stringLiteral pas) >> string' ";" >> return "external"
]
comments
return d
+program :: Parsec String u PascalUnit
program = do
- string "program"
+ string' "program"
comments
name <- iD
- (char ';')
+ (char' ';')
comments
comments
u <- uses
@@ -342,12 +362,13 @@
comments
p <- phrase
comments
- char '.'
+ char' '.'
comments
return $ Program name (Implementation u (TypesAndVars tv)) p
+interface :: Parsec String u Interface
interface = do
- string "interface"
+ string' "interface"
comments
u <- uses
comments
@@ -355,84 +376,88 @@
comments
return $ Interface u (TypesAndVars tv)
+implementation :: Parsec String u Implementation
implementation = do
- string "implementation"
+ string' "implementation"
comments
u <- uses
comments
tv <- typeVarDeclaration True
- string "end."
+ string' "end."
comments
return $ Implementation u (TypesAndVars tv)
+expression :: Parsec String u Expression
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)
+ , 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
+ , 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
+ , 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
+ , 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 (reservedOp pas "not">> return (PrefixOp "not"))
- , Prefix (try (char '-') >> return (PrefixOp "-"))]
+ , 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' "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 (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' "<>") >> 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' "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 (try $ string' "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string' "xor" >> return (BinOp "xor")) AssocLeft
]-}
, [
- Infix (char '=' >> return (BinOp "=")) AssocNone
+ Infix (char' '=' >> return (BinOp "=")) AssocNone
]
]
strOrChar [a] = CharCode . show . ord $ a
strOrChar a = StringLiteral a
+phrasesBlock :: Parsec String u Phrase
phrasesBlock = do
- try $ string "begin"
+ try $ string' "begin"
comments
- p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
+ p <- manyTill phrase (try $ string' "end" >> notFollowedBy alphaNum)
comments
return $ Phrases p
+phrase :: Parsec String u Phrase
phrase = do
o <- choice [
phrasesBlock
@@ -442,68 +467,73 @@
, switchCase
, withBlock
, forCycle
- , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
+ , (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
+ , char' ';' >> comments >> return NOP
]
- optional $ char ';'
+ optional $ char' ';'
comments
return o
+ifBlock :: Parsec String u Phrase
ifBlock = do
try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
comments
e <- expression
comments
- string "then"
+ string' "then"
comments
o1 <- phrase
comments
o2 <- optionMaybe $ do
- try $ string "else" >> space
+ try $ string' "else" >> void space
comments
o <- option NOP phrase
comments
return o
return $ IfThenElse e o1 o2
+whileCycle :: Parsec String u Phrase
whileCycle = do
- try $ string "while"
+ try $ string' "while"
comments
e <- expression
comments
- string "do"
+ string' "do"
comments
o <- phrase
return $ WhileCycle e o
+withBlock :: Parsec String u Phrase
withBlock = do
- try $ string "with" >> space
+ try $ string' "with" >> void space
comments
rs <- (commaSep1 pas) reference
comments
- string "do"
+ string' "do"
comments
o <- phrase
return $ foldr WithBlock o rs
+repeatCycle :: Parsec String u Phrase
repeatCycle = do
- try $ string "repeat" >> space
+ try $ string' "repeat" >> void space
comments
o <- many phrase
- string "until"
+ string' "until"
comments
e <- expression
comments
return $ RepeatCycle e o
+forCycle :: Parsec String u Phrase
forCycle = do
- try $ string "for" >> space
+ try $ string' "for" >> void space
comments
i <- iD
comments
- string ":="
+ string' ":="
comments
e1 <- expression
comments
@@ -512,84 +542,90 @@
try $ string "to"
, try $ string "downto"
]
- --choice [string "to", string "downto"]
+ --choice [string' "to", string' "downto"]
comments
e2 <- expression
comments
- string "do"
+ string' "do"
comments
p <- phrase
comments
return $ ForCycle i e1 e2 p up
+switchCase :: Parsec String u Phrase
switchCase = do
- try $ string "case"
+ try $ string' "case"
comments
e <- expression
comments
- string "of"
+ string' "of"
comments
cs <- many1 aCase
o2 <- optionMaybe $ do
- try $ string "else" >> notFollowedBy alphaNum
+ try $ string' "else" >> notFollowedBy alphaNum
comments
o <- many phrase
comments
return o
- string "end"
+ string' "end"
comments
return $ SwitchCase e cs o2
where
aCase = do
e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
comments
- char ':'
+ char' ':'
comments
p <- phrase
comments
return (e, p)
+procCall :: Parsec String u Phrase
procCall = do
r <- reference
p <- option [] $ (parens pas) parameters
return $ ProcCall r p
+parameters :: Parsec String u [Expression]
parameters = (commaSep pas) expression <?> "parameters"
+functionBody :: Parsec String u (TypesAndVars, Phrase)
functionBody = do
tv <- typeVarDeclaration True
comments
p <- phrasesBlock
- char ';'
+ char' ';'
comments
return (TypesAndVars tv, p)
+uses :: Parsec String u Uses
uses = liftM Uses (option [] u)
where
u = do
- string "uses"
+ string' "uses"
comments
- u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
- char ';'
+ ulist <- (iD >>= \i -> comments >> return i) `sepBy1` (char' ',' >> comments)
+ char' ';'
comments
- return u
+ return ulist
+initExpression :: Parsec String u InitExpression
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 ((notRecord $ head ia) && (null $ tail ia)) mzero >> return (InitArray ia)
- , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
+ , try $ parens pas (sepEndBy recField (char' ';' >> comments)) >>= return . InitRecord
, parens pas initExpression
- , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
+ , 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
+ , 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
]
@@ -600,7 +636,7 @@
recField = do
i <- iD
spaces
- char ':'
+ char' ':'
spaces
e <- initExpression
spaces
@@ -608,37 +644,37 @@
table = [
[
- Prefix (char '-' >> return (InitPrefixOp "-"))
- ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
+ 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' "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 (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' "<>") >> 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' "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
+ , [ Infix (try $ string' "shl" >> return (InitBinOp "shl")) AssocNone
+ , Infix (try $ string' "shr" >> return (InitBinOp "shr")) AssocNone
]--}
- --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
+ --, [Prefix (try (string' "not") >> return (InitPrefixOp "not"))]
]
itypeCast = do
@@ -647,6 +683,7 @@
comments
return $ InitTypeCast (Identifier t BTUnknown) i
+builtInFunction :: Parsec String u a -> Parsec String u (String, [a])
builtInFunction e = do
name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
spaces
@@ -654,23 +691,25 @@
spaces
return (name, exprs)
+systemUnit :: Parsec String u PascalUnit
systemUnit = do
- string "system;"
+ string' "system;"
comments
- string "type"
+ string' "type"
comments
t <- typesDecl
- string "var"
+ string' "var"
v <- varsDecl True
return $ System (t ++ v)
+redoUnit :: Parsec String u PascalUnit
redoUnit = do
- string "redo;"
+ string' "redo;"
comments
- string "type"
+ string' "type"
comments
t <- typesDecl
- string "var"
+ string' "var"
v <- varsDecl True
return $ Redo (t ++ v)
--- a/tools/pas2c/PascalPreprocessor.hs Thu Feb 06 23:02:35 2014 +0400
+++ b/tools/pas2c/PascalPreprocessor.hs Fri Feb 07 00:46:49 2014 +0400
@@ -7,10 +7,16 @@
import System.IO
import qualified Data.Map as Map
import Control.Exception(catch, IOException)
-import Data.Char
-import Prelude hiding (catch)
+import Prelude
+
+char' :: Char -> ParsecT String u IO ()
+char' = void . char
+
+string' :: String -> ParsecT String u IO ()
+string' = void . string
-- comments are removed
+comment :: ParsecT String u IO String
comment = choice [
char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""
, (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""
@@ -27,8 +33,8 @@
(Right a) -> return a
where
- preprocessFile fn = do
- f <- liftIO (readFile fn)
+ preprocessFile fn' = do
+ f <- liftIO (readFile fn')
setInput f
preprocessor
@@ -54,7 +60,7 @@
return $ c:s
switch = do
- try $ string "{$"
+ try $ string' "{$"
s <- choice [
include
, ifdef
@@ -67,14 +73,14 @@
return s
include = do
- try $ string "INCLUDE"
+ try $ string' "INCLUDE"
spaces
- (char '"')
- fn <- many1 $ noneOf "\"\n"
- char '"'
+ (char' '"')
+ ifn <- many1 $ noneOf "\"\n"
+ char' '"'
spaces
- char '}'
- f <- liftIO (readFile (inputPath ++ fn) `catch` (\(exc :: IOException) -> readFile (alternateInputPath ++ fn) `catch` (\(_ :: IOException) -> error ("File not found: " ++ fn))))
+ char' '}'
+ f <- liftIO (readFile (inputPath ++ ifn) `catch` (\(_ :: IOException) -> readFile (alternateInputPath ++ ifn) `catch` (\(_ :: IOException) -> error ("File not found: " ++ fn))))
c <- getInput
setInput $ f ++ c
return ""
@@ -86,7 +92,7 @@
spaces
d <- identifier
spaces
- char '}'
+ char' '}'
updateState $ \(m, b) ->
(m, (f $ d `Map.member` m) : b)
@@ -94,9 +100,9 @@
return ""
if' = do
- s <- try (string "IF" >> notFollowedBy alphaNum)
+ try (string' "IF" >> notFollowedBy alphaNum)
- manyTill anyChar (char '}')
+ void $ manyTill anyChar (char' '}')
--char '}'
updateState $ \(m, b) ->
@@ -105,19 +111,19 @@
return ""
elseSwitch = do
- try $ string "ELSE}"
+ try $ string' "ELSE}"
updateState $ \(m, b:bs) -> (m, (not b):bs)
return ""
endIf = do
- try $ string "ENDIF}"
- updateState $ \(m, b:bs) -> (m, bs)
+ try $ string' "ENDIF}"
+ updateState $ \(m, _:bs) -> (m, bs)
return ""
define = do
- try $ string "DEFINE"
+ try $ string' "DEFINE"
spaces
i <- identifier
d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")
- char '}'
+ char' '}'
updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
return ""
replace s = do
@@ -125,6 +131,6 @@
return $ Map.findWithDefault s s m
unknown = do
- fn <- many1 $ noneOf "}\n"
- char '}'
- return $ "{$" ++ fn ++ "}"
+ un <- many1 $ noneOf "}\n"
+ char' '}'
+ return $ "{$" ++ un ++ "}"
--- a/tools/pas2c/PascalUnitSyntaxTree.hs Thu Feb 06 23:02:35 2014 +0400
+++ b/tools/pas2c/PascalUnitSyntaxTree.hs Fri Feb 07 00:46:49 2014 +0400
@@ -1,8 +1,5 @@
module PascalUnitSyntaxTree where
-import Data.Maybe
-import Data.Char
-
data PascalUnit =
Program Identifier Implementation Phrase
| Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)