--- a/tools/PascalBasics.hs Wed Jun 27 13:47:42 2012 -0400
+++ b/tools/PascalBasics.hs Wed Jun 27 22:53:26 2012 +0400
@@ -9,7 +9,7 @@
import Data.Char
builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
-
+
pascalLanguageDef
= emptyDef
{ commentStart = "(*"
@@ -27,8 +27,8 @@
, "downto", "div", "mod", "record", "set", "nil"
, "cdecl", "external", "if", "then", "else"
] -- ++ builtin
- , reservedOpNames= []
- , caseSensitive = False
+ , reservedOpNames= []
+ , caseSensitive = False
}
preprocessorSwitch :: Stream s m Char => ParsecT s u m String
@@ -36,11 +36,11 @@
try $ string "{$"
s <- manyTill (noneOf "\n") $ char '}'
return s
-
+
caseInsensitiveString s = do
mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
return s
-
+
pas = patch $ makeTokenParser pascalLanguageDef
where
patch tp = tp {stringLiteral = stringL}
@@ -50,7 +50,7 @@
, (try $ string "(*") >> manyTill anyChar (try $ string "*)")
, (try $ string "//") >> manyTill anyChar (try newline)
]
-
+
comments = do
spaces
skipMany $ do
@@ -66,5 +66,5 @@
s' <- (many $ noneOf "'")
(char '\'')
return $ '\'' : s'
- comments
+ comments
return $ concat (s:ss)
--- a/tools/PascalParser.hs Wed Jun 27 13:47:42 2012 -0400
+++ b/tools/PascalParser.hs Wed Jun 27 22:53:26 2012 +0400
@@ -14,7 +14,7 @@
import PascalBasics
import PascalUnitSyntaxTree
-
+
knownTypes = ["shortstring", "ansistring", "char", "byte"]
pascalUnit = do
@@ -27,7 +27,7 @@
i <- liftM (flip Identifier BTUnknown) (identifier pas)
comments
return i
-
+
unit = do
string "unit" >> comments
name <- iD
@@ -38,7 +38,7 @@
comments
return $ Unit name int impl Nothing Nothing
-
+
reference = buildExpressionParser table term <?> "reference"
where
term = comments >> choice [
@@ -48,9 +48,9 @@
, liftM SimpleReference iD >>= postfixes
] <?> "simple reference"
- table = [
+ table = [
]
-
+
postfixes r = many postfix >>= return . foldl (flip ($)) r
postfix = choice [
parens pas (option [] parameters) >>= return . FunCall
@@ -64,9 +64,8 @@
e <- parens pas expression
comments
return $ TypeCast (Identifier t BTUnknown) e
-
-
-varsDecl1 = varsParser sepEndBy1
+
+varsDecl1 = varsParser sepEndBy1
varsDecl = varsParser sepEndBy
varsParser m endsWithSemi = do
vs <- m (aVarDecl endsWithSemi) (semi pas)
@@ -115,7 +114,7 @@
e <- initExpression
comments
return $ VarDeclaration (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
-
+
typeDecl = choice [
char '^' >> typeDecl >>= return . PointerTo
, try (string "shortstring") >> return (String 255)
@@ -211,7 +210,6 @@
comments
return $ TypeDeclaration i t
-
rangeDecl = choice [
try $ rangeft
, iD >>= return . Range
@@ -221,8 +219,8 @@
e1 <- initExpression
string ".."
e2 <- initExpression
- return $ RangeFromTo e1 e2
-
+ return $ RangeFromTo e1 e2
+
typeVarDeclaration isImpl = (liftM concat . many . choice) [
varSection,
constSection,
@@ -251,7 +249,7 @@
t <- typesDecl <?> "type declaration"
comments
return t
-
+
operatorDecl = do
try $ string "operator"
comments
@@ -276,7 +274,7 @@
return Nothing
return $ [OperatorDeclaration i rid ret vs b]
-
+
funcDecl = do
fp <- try (string "function") <|> try (string "procedure")
comments
@@ -300,7 +298,7 @@
else
return Nothing
return $ [FunctionDeclaration i ret vs b]
-
+
functionDecorator = choice [
try $ string "inline;"
, try $ caseInsensitiveString "cdecl;"
@@ -309,8 +307,8 @@
, try $ string "varargs;"
, try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
] >> comments
-
-
+
+
program = do
string "program"
comments
@@ -396,15 +394,15 @@
]
]
strOrChar [a] = CharCode . show . ord $ a
- strOrChar a = StringLiteral 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
@@ -459,7 +457,7 @@
comments
o <- phrase
return $ foldr WithBlock o rs
-
+
repeatCycle = do
try $ string "repeat" >> space
comments
@@ -488,7 +486,7 @@
p <- phrase
comments
return $ ForCycle i e1 e2 p
-
+
switchCase = do
try $ string "case"
comments
@@ -515,14 +513,14 @@
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
@@ -559,7 +557,7 @@
, itypeCast
, iD >>= return . InitReference
]
-
+
recField = do
i <- iD
spaces
@@ -569,7 +567,7 @@
spaces
return (i ,e)
- table = [
+ table = [
[
Prefix (char '-' >> return (InitPrefixOp "-"))
]
@@ -603,7 +601,7 @@
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
--- a/tools/PascalPreprocessor.hs Wed Jun 27 13:47:42 2012 -0400
+++ b/tools/PascalPreprocessor.hs Wed Jun 27 22:53:26 2012 +0400
@@ -19,7 +19,7 @@
("FPC", "")
, ("PAS2C", "")
]
-
+
preprocess :: String -> IO String
preprocess fn = do
r <- runParserT (preprocessFile fn) (initDefines, [True]) "" ""
@@ -28,17 +28,17 @@
hPutStrLn stderr (show a)
return ""
(Right a) -> return a
-
+
where
preprocessFile fn = do
f <- liftIO (readFile fn)
setInput f
preprocessor
-
+
preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String
-
+
preprocessor = chainr codeBlock (return (++)) ""
-
+
codeBlock = do
s <- choice [
switch
@@ -55,7 +55,7 @@
c <- letter <|> oneOf "_"
s <- many (alphaNum <|> oneOf "_")
return $ c:s
-
+
switch = do
try $ string "{$"
s <- choice [
@@ -68,7 +68,7 @@
, unknown
]
return s
-
+
include = do
try $ string "INCLUDE"
spaces
@@ -85,26 +85,26 @@
ifdef = do
s <- try (string "IFDEF") <|> try (string "IFNDEF")
let f = if s == "IFNDEF" then not else id
-
+
spaces
d <- identifier
spaces
char '}'
-
+
updateState $ \(m, b) ->
(m, (f $ d `Map.member` m) : b)
-
+
return ""
if' = do
s <- try (string "IF" >> notFollowedBy alphaNum)
-
+
manyTill anyChar (char '}')
--char '}'
-
+
updateState $ \(m, b) ->
(m, False : b)
-
+
return ""
elseSwitch = do
@@ -118,7 +118,7 @@
define = do
try $ string "DEFINE"
spaces
- i <- identifier
+ i <- identifier
d <- ((string ":=" >> return ())<|> spaces) >> many (noneOf "}")
char '}'
updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
@@ -126,7 +126,7 @@
replace s = do
(m, _) <- getState
return $ Map.findWithDefault s s m
-
+
unknown = do
fn <- many1 $ noneOf "}\n"
char '}'
--- a/tools/pas2c.hs Wed Jun 27 13:47:42 2012 -0400
+++ b/tools/pas2c.hs Wed Jun 27 22:53:26 2012 +0400
@@ -21,7 +21,7 @@
import PascalUnitSyntaxTree
-data InsertOption =
+data InsertOption =
IOInsert
| IOLookup
| IOLookupLast
@@ -30,7 +30,7 @@
type Record = (String, BaseType)
type Records = Map.Map String [Record]
-data RenderState = RenderState
+data RenderState = RenderState
{
currentScope :: Records,
lastIdentifier :: String,
@@ -42,7 +42,7 @@
currentFunctionResult :: String,
namespaces :: Map.Map String Records
}
-
+
emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" ""
getUniq :: State RenderState Int
@@ -50,7 +50,7 @@
i <- gets uniqCounter
modify(\s -> s{uniqCounter = uniqCounter s + 1})
return i
-
+
addStringConst :: String -> State RenderState Doc
addStringConst str = do
strs <- gets stringConsts
@@ -65,7 +65,7 @@
let sn = "__str" ++ show i
modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
return $ text sn
-
+
escapeStr :: String -> String
escapeStr = foldr escapeChar []
@@ -77,9 +77,9 @@
strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
renderStringConsts :: State RenderState Doc
-renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
+renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
$ gets stringConsts
-
+
docToLower :: Doc -> Doc
docToLower = text . map toLower . render
@@ -97,8 +97,8 @@
processed <- gets $ Map.member fileName
unless processed $ do
print ("Preprocessing '" ++ fileName ++ ".pas'... ")
- fc' <- liftIO
- $ tryJust (guard . isDoesNotExistError)
+ fc' <- liftIO
+ $ tryJust (guard . isDoesNotExistError)
$ preprocess (fileName ++ ".pas")
case fc' of
(Left a) -> do
@@ -127,14 +127,14 @@
mapM_ (toCFiles nss) u
where
toNamespace :: Map.Map String Records -> PascalUnit -> Records
- toNamespace nss (System tvs) =
+ toNamespace nss (System tvs) =
currentScope $ execState f (emptyState nss)
where
f = do
checkDuplicateFunDecls tvs
- mapM_ (tvar2C True) tvs
+ mapM_ (tvar2C True) tvs
toNamespace _ (Program {}) = Map.empty
- toNamespace nss (Unit (Identifier i _) interface _ _ _) =
+ toNamespace nss (Unit (Identifier i _) interface _ _ _) =
currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"}
@@ -188,22 +188,22 @@
pascal2C :: PascalUnit -> State RenderState Doc
pascal2C (Unit _ interface implementation init fin) =
liftM2 ($+$) (interface2C interface) (implementation2C implementation)
-
+
pascal2C (Program _ implementation mainFunction) = do
impl <- implementation2C implementation
- [main] <- tvar2C True
+ [main] <- tvar2C True
(FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
return $ impl $+$ main
-
-
+
+
interface2C :: Interface -> State RenderState Doc
interface2C (Interface uses tvars) = do
u <- uses2C uses
tv <- typesAndVars2C True tvars
r <- renderStringConsts
return (u $+$ r $+$ tv)
-
+
implementation2C :: Implementation -> State RenderState Doc
implementation2C (Implementation uses tvars) = do
u <- uses2C uses
@@ -261,10 +261,10 @@
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
lt <- gets lastType
- if isNothing v then
+ if isNothing v then
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
- else
- let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
+ else
+ let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
where
checkParam (_, BTFunction p _) = p == params
@@ -282,16 +282,16 @@
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
lt <- gets lastType
- if isNothing v then
+ if isNothing v then
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
- else
+ else
let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
-
-
+
+
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
id2CTyped t (Identifier i _) = do
tb <- resolveType t
- case (t, tb) of
+ case (t, tb) of
(_, BTUnknown) -> do
error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
(SimpleType {}, BTRecord _ r) -> do
@@ -301,7 +301,7 @@
ts <- type2C t
id2C IOInsert (Identifier i (BTRecord i r))
_ -> id2C IOInsert (Identifier i tb)
-
+
resolveType :: TypeDecl -> State RenderState BaseType
@@ -327,7 +327,7 @@
f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
resolveType (ArrayDecl (Just i) t) = do
t' <- resolveType t
- return $ BTArray i BTInt t'
+ return $ BTArray i BTInt t'
resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t
resolveType (DeriveType (InitHexNumber _)) = return BTInt
@@ -344,7 +344,7 @@
resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
resolveType (RangeType _) = return $ BTVoid
resolveType (Set t) = liftM BTSet $ resolveType t
-
+
resolve :: String -> BaseType -> State RenderState BaseType
resolve s (BTUnresolved t) = do
@@ -360,7 +360,7 @@
fromPointer s t = do
error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
-
+
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
numberOfDeclarations :: [TypeVarDeclaration] -> Int
@@ -371,35 +371,35 @@
fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do
- t <- type2C returnType
+ t <- type2C returnType
t'<- gets lastType
p <- withState' id $ functionParams2C params
n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name
return [t empty <+> n <> parens p]
-
+
fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
let res = docToLower $ text rv <> text "_result"
t <- type2C returnType
t'<- gets lastType
n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name
-
+
let isVoid = case returnType of
VoidType -> True
_ -> False
-
+
(p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st
, currentFunctionResult = if isVoid then [] else render res}) $ do
p <- functionParams2C params
ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
return (p, ph)
-
+
let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
-
- return [
+
+ return [
t empty <+> n <> parens p
$+$
- text "{"
- $+$
+ text "{"
+ $+$
nest 4 phrasesBlock
$+$
text "}"]
@@ -407,7 +407,7 @@
phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
phrase2C' p = phrase2C p
un [a] b = a : b
-
+
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
@@ -418,7 +418,7 @@
i <- id2CTyped t i'
tp <- type2C t
return [text "typedef" <+> tp i]
-
+
tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t
ie <- initExpr mInitExpr
@@ -436,18 +436,18 @@
where
initExpr Nothing = return $ empty
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
-
+
tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do
r <- op2CTyped op (extractTypes params)
fun2C f i (FunctionDeclaration r ret params body)
-
+
op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
op2CTyped op t = do
t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
bt <- gets lastType
return $ Identifier (t' ++ "_op_" ++ opStr) bt
- where
+ where
opStr = case op of
"+" -> "add"
"-" -> "sub"
@@ -458,7 +458,7 @@
">" -> "gt"
"<>" -> "neq"
_ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
-
+
extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
extractTypes = concatMap f
where
@@ -500,7 +500,7 @@
initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
initExpr2C' (InitSet []) = return $ text "0"
initExpr2C' (InitSet a) = return $ text "<<set>>"
-initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
+initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
case e of
(Identifier "LongInt" _) -> int (-2^31)
(Identifier "SmallInt" _) -> int (-2^15)
@@ -515,7 +515,7 @@
initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
-initExpr2C' b@(BuiltInFunction _ _) = error $ show b
+initExpr2C' b@(BuiltInFunction _ _) = error $ show b
initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
@@ -610,7 +610,7 @@
e <- expr2C expr
p1 <- (phrase2C . wrapPhrase) phrase1
el <- elsePart
- return $
+ return $
text "if" <> parens e $+$ p1 $+$ el
where
elsePart | isNothing mphrase2 = return $ empty
@@ -634,7 +634,7 @@
e <- expr2C expr
return $ r <+> text "=" <+> e <> semi
_ -> error $ "Assignment to string from " ++ show lt
- (BTArray _ _ _, _) -> phrase2C $
+ (BTArray _ _ _, _) -> phrase2C $
ProcCall (FunCall
[
Reference $ Address ref
@@ -654,22 +654,22 @@
e <- expr2C expr
cs <- mapM case2C cases
d <- dflt
- return $
+ return $
text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
where
case2C :: ([InitExpression], Phrase) -> State RenderState Doc
case2C (e, p) = do
ies <- mapM range2C e
ph <- phrase2C p
- return $
+ return $
vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
dflt | isNothing mphrase = return []
| otherwise = do
ph <- mapM phrase2C $ fromJust mphrase
return [text "default:" <+> nest 4 (vcat ph)]
-
+
phrase2C wb@(WithBlock ref p) = do
- r <- ref2C ref
+ r <- ref2C ref
t <- gets lastType
case t of
(BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
@@ -680,7 +680,7 @@
e1 <- expr2C e1'
e2 <- expr2C e2'
ph <- phrase2C (wrapPhrase p)
- return $
+ return $
text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i])
$$
ph
@@ -732,7 +732,7 @@
-- aw, "LongInt" here is hwengine-specific hack
i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
ref2C $ FunCall [expr1, expr2] (SimpleReference i)
- ("in", _, _) ->
+ ("in", _, _) ->
case expr2 of
SetExpression set -> do
ids <- mapM (id2C IOLookup) set
@@ -804,14 +804,14 @@
BTArray {} -> return $ text "length_ar" <> parens e'
_ -> error $ "length() called on " ++ show lt
expr2C (BuiltInFunCall params ref) = do
- r <- ref2C ref
+ r <- ref2C ref
t <- gets lastType
ps <- mapM expr2C params
case t of
BTFunction _ t' -> do
modify (\s -> s{lastType = t'})
_ -> error $ "BuiltInFunCall lastType: " ++ show t
- return $
+ return $
r <> parens (hsep . punctuate (char ',') $ ps)
expr2C a = error $ "Don't know how to render " ++ show a
@@ -844,7 +844,7 @@
-- conversion routines
ref2C ae@(ArrayElement [expr] ref) = do
e <- expr2C expr
- r <- ref2C ref
+ r <- ref2C ref
t <- gets lastType
case t of
(BTArray _ _ t') -> modify (\st -> st{lastType = t'})
@@ -862,13 +862,13 @@
_ -> return $ r <> brackets e
ref2C (SimpleReference name) = id2C IOLookup name
ref2C rf@(RecordField (Dereference ref1) ref2) = do
- r1 <- ref2C ref1
+ r1 <- ref2C ref1
t <- fromPointer (show ref1) =<< gets lastType
r2 <- case t of
BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2
BTUnit -> error "What??"
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
- return $
+ return $
r1 <> text "->" <> r2
ref2C rf@(RecordField ref1 ref2) = do
r1 <- ref2C ref1
@@ -898,7 +898,7 @@
where
fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
fref2C a = ref2C a
-
+
ref2C (Address ref) = do
r <- ref2C ref
return $ text "&" <> parens r
@@ -909,7 +909,7 @@
("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
(a, _) -> do
e <- expr2C expr
- t <- id2C IOLookup t'
+ t <- id2C IOLookup t'
return . parens $ parens t <> e
ref2C (RefExpression expr) = expr2C expr