--- a/tools/pas2c.hs Mon Aug 06 10:18:57 2012 -0400
+++ b/tools/pas2c.hs Mon Aug 06 23:30:58 2012 +0400
@@ -17,24 +17,32 @@
import Data.List (find)
import Numeric
-import PascalParser
+import PascalParser(pascalUnit)
import PascalUnitSyntaxTree
data InsertOption =
IOInsert
+ | IOInsertWithType Doc
| IOLookup
| IOLookupLast
| IOLookupFunction Int
| IODeferred
-type Record = (String, BaseType)
+data Record = Record
+ {
+ lcaseId :: String,
+ baseType :: BaseType,
+ typeDecl :: Doc
+ }
+ deriving Show
type Records = Map.Map String [Record]
data RenderState = RenderState
{
currentScope :: Records,
lastIdentifier :: String,
lastType :: BaseType,
+ lastIdTypeDecl :: Doc,
stringConsts :: [(String, String)],
uniqCounter :: Int,
toMangle :: Set.Set String,
@@ -43,7 +51,9 @@
namespaces :: Map.Map String Records
}
-emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" ""
+rec2Records = map (\(a, b) -> Record a b empty)
+
+emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" ""
getUniq :: State RenderState Int
getUniq = do
@@ -161,12 +171,12 @@
nss <- gets namespaces
withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
-withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc
+withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
withRecordNamespace _ [] = error "withRecordNamespace: empty record"
withRecordNamespace prefix recs = withState' f
where
f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
- records = Map.fromList $ map (\(a, b) -> (map toLower a, [(prefix ++ a, b)])) recs
+ records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
un [a] b = a : b
toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO ()
@@ -261,8 +271,11 @@
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
+setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
+
id2C :: InsertOption -> Identifier -> State RenderState Doc
-id2C IOInsert (Identifier i t) = do
+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
@@ -271,7 +284,7 @@
(BTFunction _ _ _, _) -> (cu ++ i, t)
(BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
_ -> (i, t)
- modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t')] (currentScope s), lastIdentifier = n})
+ modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
return $ text i'
where
n = map toLower i
@@ -286,9 +299,9 @@
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
- modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
+ modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
where
- checkParam (_, BTFunction _ p _) = p == params
+ checkParam (Record _ (BTFunction _ p _) _) = p == params
checkParam _ = False
id2C IODeferred (Identifier i t) = do
let i' = map toLower i
@@ -296,7 +309,7 @@
if (isNothing v) then
modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
else
- let vv = head $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
+ 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
@@ -306,30 +319,34 @@
if isNothing v then
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
else
- let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
+ let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped t (Identifier i _) = do
+id2CTyped = id2CTyped2 Nothing
+
+id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped2 md t (Identifier i _) = do
tb <- resolveType t
case (t, tb) of
(_, BTUnknown) -> do
error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
(SimpleType {}, BTRecord _ r) -> do
ts <- type2C t
- id2C IOInsert (Identifier i (BTRecord (render $ ts empty) r))
+ id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
(_, BTRecord _ r) -> do
ts <- type2C t
- id2C IOInsert (Identifier i (BTRecord i r))
- _ -> id2C IOInsert (Identifier i tb)
-
+ id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
+ _ -> case md of
+ Nothing -> id2C IOInsert (Identifier i tb)
+ Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
resolveType :: TypeDecl -> State RenderState BaseType
resolveType st@(SimpleType (Identifier i _)) = do
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
- if isJust v then return . snd . head $ fromJust v else return $ f i'
+ if isJust v then return . baseType . head $ fromJust v else return $ f i'
where
f "integer" = BTInt
f "pointer" = BTPointerTo BTVoid
@@ -372,7 +389,7 @@
resolve s (BTUnresolved t) = do
v <- gets $ Map.lookup t . currentScope
if isJust v then
- resolve s . snd . head . fromJust $ v
+ resolve s . baseType . head . fromJust $ v
else
error $ "Unknown type " ++ show t ++ "\n" ++ s
resolve _ t = return t
@@ -438,7 +455,7 @@
VoidType -> True
_ -> False
- (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st
+ (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st
, currentFunctionResult = if isVoid then [] else render res}) $ do
p <- functionParams2C params
ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
@@ -480,7 +497,7 @@
tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
t' <- liftM ((empty <+>) . ) $ type2C t
- liftM (map(\i -> t' i)) $ mapM (id2CTyped (VarParamType t)) ids
+ liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
t' <- liftM (((if isConst then text "static const" else if externVar
@@ -515,7 +532,7 @@
(_, _) -> return result
- _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped t) ids
+ _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
where
initExpr Nothing = return $ empty
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
@@ -780,20 +797,26 @@
r <- ref2C ref
t <- gets lastType
case t of
- (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
+ (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
a -> do
error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
phrase2C (ForCycle i' e1' e2' p up) = do
i <- id2C IOLookup i'
+ iType <- gets lastIdTypeDecl
e1 <- expr2C e1'
e2 <- expr2C e2'
- ph <- phrase2C (wrapPhrase p)
- cmp <- return $ if up == True then "<=" else ">="
- inc <- return $ if up == True then "++" else "--"
- return $
- text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> parens e1, i <+> text cmp <+> parens e2, text inc <> i])
+ let inc = if up then "inc" else "dec"
+ let add = if up then "+ 1" else "- 1"
+ ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
+ return . braces $
+ i <+> text "=" <+> e1 <> semi
$$
- ph
+ iType <+> i <> text "__end__" <+> text "=" <+> e2 <+> text add <> semi
+ $$
+ text "do" <+> ph <+>
+ text "while" <> parens (i <+> text "!=" <+> i <> text "__end__") <> semi
+ where
+ appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
phrase2C (RepeatCycle e' p') = do
e <- expr2C e'
p <- phrase2C (Phrases p')
@@ -992,7 +1015,7 @@
r1 <- ref2C ref1
t <- fromPointer (show ref1) =<< gets lastType
r2 <- case t of
- BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2
+ BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
BTUnit -> error "What??"
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
return $
@@ -1002,7 +1025,7 @@
t <- gets lastType
case t of
BTRecord _ rs -> do
- r2 <- withRecordNamespace "" rs $ ref2C ref2
+ r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
return $ r1 <> text "." <> r2
BTUnit -> withLastIdNamespace $ ref2C ref2
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf