hedgewars: comparison tools/pas2c.hs

equal deleted inserted replaced

-:7ee319134713
+:bc7b1d228a2c
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 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,
 currentUnit :: String,
 currentFunctionResult :: String,
 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
 i <- gets uniqCounter
 modify(\s -> s{uniqCounter = uniqCounter s + 1})
 escapeStr :: String -> String
 escapeStr = foldr escapeChar []
 escapeChar :: Char -> ShowS
 escapeChar '"' s = "\\\"" ++ s
+escapeChar '\\' s = "\\\\" ++ s
 escapeChar a s = a : s
 strInit :: String -> Doc
 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 "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
 $ gets stringConsts
 docToLower :: Doc -> Doc
 docToLower = text . map toLower . render
 toNamespace nss (System tvs) =
 currentScope $ execState f (emptyState nss)
 where
 f = do
 checkDuplicateFunDecls tvs
-mapM_ (tvar2C True) tvs
+mapM_ (tvar2C True False True False) tvs
+toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
+currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
+where
+f = do
+checkDuplicateFunDecls tvs
+mapM_ (tvar2C True False True False) tvs
 toNamespace _ (Program {}) = Map.empty
 toNamespace nss (Unit (Identifier i _) interface _ _ _) =
-currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"}
+currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
 withState' f sf = do
 st <- liftM f get
 , 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 -> [(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 ()
 toCFiles _ (_, System _) = return ()
+toCFiles _ (_, Redo _) = return ()
 toCFiles ns p@(fn, pu) = do
 hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
 toCFiles' p
 where
-toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p
+toCFiles' (fn, p@(Program {})) = writeFile (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) initialState{currentUnit = map toLower i ++ "_"}
+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 ++ "_"}
 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
-writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation
+writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
 initialState = emptyState ns
 render2C :: RenderState -> State RenderState Doc -> String
 render2C a = render . ($+$ empty) . flip evalState a
 usesFiles :: PascalUnit -> [String]
-usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses
+usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
-usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2
+usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
 usesFiles (System {}) = []
+usesFiles (Redo {}) = []
 pascal2C :: PascalUnit -> State RenderState Doc
 pascal2C (Unit _ interface implementation init fin) =
-liftM2 ($+$) (interface2C interface) (implementation2C implementation)
+liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
 pascal2C (Program _ implementation mainFunction) = do
 impl <- implementation2C implementation
-[main] <- tvar2C True
+[main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
-(FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
 return $ impl $+$ main
+-- the second bool indicates whether do normal interface translation or generate variable declarations
-interface2C :: Interface -> State RenderState Doc
+-- that will be inserted into implementation files
-interface2C (Interface uses tvars) = do
+interface2C :: Interface -> Bool -> State RenderState Doc
+interface2C (Interface uses tvars) True = do
 u <- uses2C uses
-tv <- typesAndVars2C True tvars
+tv <- typesAndVars2C True True True tvars
 r <- renderStringConsts
 return (u $+$ r $+$ tv)
+interface2C (Interface uses tvars) False = do
+u <- uses2C uses
+tv <- typesAndVars2C True False False tvars
+r <- renderStringConsts
+return tv
 implementation2C :: Implementation -> State RenderState Doc
 implementation2C (Implementation uses tvars) = do
 u <- uses2C uses
-tv <- typesAndVars2C True tvars
+tv <- typesAndVars2C True False True tvars
 r <- renderStringConsts
 return (u $+$ r $+$ tv)
 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
 checkDuplicateFunDecls tvs =
 modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
 where
 initMap = Map.empty
 --initMap = Map.fromList [("reset", 2)]
-ins (FunctionDeclaration (Identifier i _) _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
+ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
 ins _ m = m
-typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc
+-- the second bool indicates whether declare variable as extern or not
-typesAndVars2C b (TypesAndVars ts) = do
+-- the third bool indicates whether include types or not
+typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
+typesAndVars2C b externVar includeType(TypesAndVars ts) = do
 checkDuplicateFunDecls ts
-liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts
+liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
 setBaseType :: BaseType -> Identifier -> Identifier
 setBaseType bt (Identifier i _) = Identifier i bt
 uses2C :: Uses -> State RenderState Doc
 uses2C uses@(Uses unitIds) = do
 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
+mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
 where
 injectNamespace (Identifier i _) = do
 getNS <- gets (flip Map.lookup . namespaces)
 uses2List :: Uses -> [String]
 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
 let (i', t') = case (t, tom) of
 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)
 (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
 id2C IOLookup i = id2CLookup head i
 id2C IOLookupLast i = id2CLookup last i
 id2C (IOLookupFunction params) (Identifier i t) = do
 let i' = map toLower i
 v <- gets $ Map.lookup i' . currentScope
 lt <- gets lastType
 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
-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
 v <- gets $ Map.lookup i' . currentScope
 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 _) = do
+id2CLookup f (Identifier i t) = do
 let i' = map toLower i
 v <- gets $ Map.lookup i' . currentScope
 lt <- gets lastType
 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 (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
-_ -> id2C IOInsert (Identifier i tb)
+_ -> 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
 f "boolean" = BTBool
 f "float" = BTFloat
 resolve :: String -> BaseType -> State RenderState BaseType
 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
 fromPointer :: String -> BaseType -> State RenderState BaseType
 fromPointer s (BTPointerTo t) = resolve s t
 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
+functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
 numberOfDeclarations :: [TypeVarDeclaration] -> Int
 numberOfDeclarations = sum . map cnt
 where
 cnt (VarDeclaration _ _ (ids, _) _) = length ids
 abc = hcat . punctuate comma . map (char . fst) $ ps
 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
 ps = zip ['a'..] (toIsVarList params)
 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
-fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do
+fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do
 t <- type2C returnType
 t'<- gets lastType
 p <- withState' id $ functionParams2C params
 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
+let decor = if inline then text "inline" else empty
 if hasVars then
-return [funWithVarsToDefine n params $+$ t empty <+> text (n ++ "__vars") <> parens p]
+return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]
 else
-return [t empty <+> text n <> parens p]
+return [decor <+> t empty <+> text n <> parens p]
 where
 hasVars = hasPassByReference params
-fun2C True rv (FunctionDeclaration name@(Identifier i _) returnType params (Just (tvars, phrase))) = do
+fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do
 let res = docToLower $ text rv <> text "_result"
 t <- type2C returnType
 t'<- gets lastType
 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
 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
+(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 tvars) (phrase2C' phrase)
+ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
 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
-return [(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+let decor = if inline then text "inline" else empty
-t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
+return [
+define
+$+$
+--(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
 $+$
 text "{"
 $+$
 nest 4 phrasesBlock
 $+$
 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
 phrase2C' p = phrase2C p
 un [a] b = a : b
 hasVars = hasPassByReference params
-fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
+fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name
 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
-tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc]
+-- the second bool indicates whether declare variable as extern or not
-tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) =
+-- the third bool indicates whether include types or not
-fun2C b name f
+-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
-tvar2C _ td@(TypeDeclaration i' t) = do
+tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
+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
 i <- id2CTyped t i'
 tp <- type2C t
-return [text "typedef" <+> tp i]
+return $ if includeType then [text "typedef" <+> tp i] else []
-tvar2C _ (VarDeclaration True _ (ids, t) Nothing) = do
+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 _ (VarDeclaration _ isConst (ids, t) mInitExpr) = do
+tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
-t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t
+t' <- liftM (((if isConst then text "static const" else if externVar
+then text "extern"
+else empty)
+<+>) . ) $ type2C t
 ie <- initExpr mInitExpr
 lt <- gets lastType
 case (isConst, lt, ids, mInitExpr) of
 (True, BTInt, [i], Just _) -> do
 i' <- id2CTyped t i
-return [text "enum" <> braces (i' <+> ie)]
+return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
 (True, BTFloat, [i], Just e) -> do
 i' <- id2CTyped t i
 ie <- initExpr2C e
-return [text "#define" <+> i' <+> parens ie <> text "\n"]
+return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
-_ -> liftM (map(\i -> t' i <+> ie)) $ 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
+case (r, ignoreInit) of
+(RangeInfinite, False) ->
+-- if the array is dynamic, add dimension info to it
+return $ [dimDecl] ++ result
+where
+arrayDimStr = show $ arrayDimension t
+arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
+dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp
+(_, _) -> return result
+_ -> 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)
+varDeclDecision True True varStr expStr = varStr <+> expStr
-tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do
+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
+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 _ _ -> error "Mixed dynamic array and static array are not supported."
+_ -> 0
+tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
 r <- op2CTyped op (extractTypes params)
-fun2C f i (FunctionDeclaration r ret params body)
+fun2C f i (FunctionDeclaration r inline 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
 opStr = case op of
 "+" -> "add"
 "-" -> "sub"
 "*" -> "mul"
 "/" -> "div"
+"/(float)" -> "div"
 "=" -> "eq"
 "<" -> "lt"
 ">" -> "gt"
 "<>" -> "neq"
 _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
 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' (RecordType tvs union) = do
-t <- withState' f $ mapM (tvar2C 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
 where
 f s = s{currentUnit = ""}
 unions = case union of
 Nothing -> return empty
 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) tvs
+t <- withState' f $ mapM (tvar2C False False True False) tvs
 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
 type2C' (RangeType r) = return (text "int" <+>)
 type2C' (Sequence ids) = do
 is <- mapM (id2C IOInsert . setBaseType bt) ids
 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
 type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
 type2C' (ArrayDecl (Just r) t) = do
 t' <- type2C t
 lt <- gets lastType
 ft <- case lt of
-BTFunction {} -> type2C (PointerTo t)
+-- BTFunction {} -> type2C (PointerTo t)
 _ -> return t'
 r' <- initExpr2C (InitRange r)
 return $ \i -> ft i <> brackets r'
 type2C' (Set t) = return (text "<<set>>" <+>)
 type2C' (FunctionType returnType params) = do
 return $ r <+> text "=" <+> e <> semi
 BTString -> do
 e <- expr2C expr
 return $ r <+> text "=" <+> e <> semi
 _ -> error $ "Assignment to string from " ++ show lt
-(BTArray _ _ _, _) -> phrase2C $
+(BTArray _ _ _, _) -> do
-ProcCall (FunCall
+case expr of
-[
+Reference er -> do
-Reference $ Address ref
+exprRef <- ref2C er
-, Reference $ Address $ RefExpression expr
+exprT <- gets lastType
-, Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
+case exprT of
-]
+BTArray RangeInfinite _ _ ->
-(SimpleReference (Identifier "memcpy" BTUnknown))
+return $ text "FIXME: assign a dynamic array to an array"
-) []
+BTArray _ _ _ -> phrase2C $
+ProcCall (FunCall
+[
+Reference $ ref
+, Reference $ RefExpression expr
+, Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
+]
+(SimpleReference (Identifier "memcpy" BTUnknown))
+) []
+_ -> return $ text "FIXME: assign a non-specific value to an array"
+_ -> return $ text "FIXME: dynamic array assignment 2"
 _ -> do
 e <- expr2C expr
 return $ r <+> text "=" <+> e <> semi
 phrase2C (WhileCycle expr phrase) = do
 e <- expr2C expr
 case2C (e, p) = do
 ies <- mapM range2C e
 ph <- phrase2C p
 return $
 vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
-dflt | isNothing mphrase = return []
+dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
 | otherwise = do
 ph <- mapM phrase2C $ fromJust mphrase
 return [text "default:" <+> nest 4 (vcat ph)]
 phrase2C wb@(WithBlock ref p) = do
 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) = do
+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)
+let inc = if up then "inc" else "dec"
-return $
+let add = if up then "+ 1" else "- 1"
-text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i])
+let iEnd = i <> text "__end__"
+ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
+return . braces $
+i <+> text "=" <+> e1 <> semi
 $$
-ph
+iType <+> iEnd <+> text "=" <+> e2 <> semi
+$$
+text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>
+text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
+where
+appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
 phrase2C (RepeatCycle e' p') = do
 e <- expr2C e'
 p <- phrase2C (Phrases p')
 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
 phrase2C NOP = return $ text ";"
 ref2C $ FunCall [expr1, expr2] (SimpleReference i)
 ("in", _, _) ->
 case expr2 of
 SetExpression set -> do
 ids <- mapM (id2C IOLookup) set
+modify(\s -> s{lastType = BTBool})
 return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
 _ -> error "'in' against not set expression"
 (o, _, _) | o `elem` boolOps -> do
 modify(\s -> s{lastType = BTBool})
 return $ parens e1 <+> text o <+> parens e2
-| otherwise -> return $ parens e1 <+> text o <+> parens e2
+| otherwise -> do
+o' <- return $ case o of
+"/(float)" -> text "/(float)" -- pascal returns real value
+_ -> text o
+e1' <- return $ case (o, t1, t2) of
+("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
+_ -> parens e1
+e2' <- return $ case (o, t1, t2) of
+("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
+_ -> parens e2
+return $ e1' <+> o' <+> e2'
 where
 boolOps = ["==", "!=", "<", ">", "<=", ">="]
 expr2C (NumberLiteral s) = do
 modify(\s -> s{lastType = BTInt})
 return $ text s
 lt <- gets lastType
 case lt of
 BTRecord t _ -> do
 i <- op2CTyped op [SimpleType (Identifier t undefined)]
 ref2C $ FunCall [expr] (SimpleReference i)
-_ -> return $ text (op2C op) <> e
+BTBool -> do
+o <- return $ case op of
+"not" -> text "!"
+_ -> text (op2C op)
+return $ o <> parens e
+_ -> return $ text (op2C op) <> parens e
 expr2C Null = return $ text "NULL"
 expr2C (CharCode a) = do
 modify(\s -> s{lastType = BTChar})
 return $ quotes $ text "\\x" <> text (showHex (read a) "")
 expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
 BTString -> return $ int 255
 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
 _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
 e' <- expr2C e
 lt <- gets lastType
 modify (\s -> s{lastType = BTInt})
 case lt of
-BTString -> return $ text "Length" <> parens e'
+BTString -> return $ text "fpcrtl_Length" <> parens e'
 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
 _ -> error $ "length() called on " ++ show lt
 expr2C (BuiltInFunCall params ref) = do
 r <- ref2C ref
 i <- id2C IOLookup name
 t <- gets lastType
 case t of
 BTFunction _ _ rt -> do
 modify(\s -> s{lastType = rt})
-return $ i <> parens empty
+return $ i <> parens empty --xymeng: removed parens
 _ -> return $ i
 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
 i <- ref2C r
 t <- gets lastType
 case t of
 ref2C (SimpleReference name) = id2C IOLookup name
 ref2C rf@(RecordField (Dereference ref1) ref2) = do
 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 $
 r1 <> text "->" <> r2
 ref2C rf@(RecordField ref1 ref2) = do
 r1 <- ref2C ref1
 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
 ref2C d@(Dereference ref) = do
 r <- ref2C ref
 op2C :: String -> String
 op2C "or" = "|"
 op2C "and" = "&"
-op2C "not" = "!"
+op2C "not" = "~"
 op2C "xor" = "^"
 op2C "div" = "/"
 op2C "mod" = "%"
 op2C "shl" = "<<"
 op2C "shr" = ">>"
 op2C "<>" = "!="
 op2C "=" = "=="
+op2C "/" = "/(float)"
 op2C a = a

changeset 7628	bc7b1d228a2c
parent 7529	058fcb451b37
child 7949	91511b219de7
child 8442	535a00ca0d35