# HG changeset patch # User koda # Date 1352648680 -3600 # Node ID 00b1facf280577c345dd3ab35ed4df9889df64c3 # Parent 091293bc974f393a2a4d35af79c49b0e7e103eab merge xymeng pas2c diff -r 091293bc974f -r 00b1facf2805 tools/pas2c/Pas2C.hs --- a/tools/pas2c/Pas2C.hs Sun Nov 11 15:14:18 2012 +0100 +++ b/tools/pas2c/Pas2C.hs Sun Nov 11 16:44:40 2012 +0100 @@ -42,10 +42,12 @@ currentScope :: Records, lastIdentifier :: String, lastType :: BaseType, + isFunctionType :: Bool, -- set to true if the current function parameter is functiontype lastIdTypeDecl :: Doc, stringConsts :: [(String, String)], uniqCounter :: Int, toMangle :: Set.Set String, + enums :: [(String, [String])], -- store all declared enums currentUnit :: String, currentFunctionResult :: String, namespaces :: Map.Map String Records @@ -53,7 +55,7 @@ rec2Records = map (\(a, b) -> Record a b empty) -emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" "" +emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" "" getUniq :: State RenderState Int getUniq = do @@ -153,7 +155,6 @@ toNamespace nss (Unit (Identifier i _) interface _ _ _) = 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 @@ -189,13 +190,38 @@ 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 ++ "_"} - writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) - writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation + 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 initialState = emptyState ns render2C :: RenderState -> State RenderState Doc -> String - render2C a = render . ($+$ empty) . flip evalState a + render2C st p = + let (a, s) = 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 + where + decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar") + enum2strBlock en = + text "{" + $+$ + (nest 4 $ + text "switch(enumvar){" + $+$ + (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en) + $+$ + text "default: assert(0);" + $+$ + (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");") + $+$ + text "}" + ) + $+$ + text "}" usesFiles :: PascalUnit -> [String] usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses @@ -209,7 +235,8 @@ pascal2C (Program _ implementation mainFunction) = do impl <- implementation2C implementation - [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))) + [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False False (SimpleType $ Identifier "int" (BTInt True)) [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) + return $ impl $+$ main @@ -240,7 +267,7 @@ 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 -- the second bool indicates whether declare variable as extern or not @@ -279,7 +306,7 @@ 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 _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t) (BTFunction _ _ _, _) -> (cu ++ i, t) (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') _ -> (i, t) @@ -300,7 +327,7 @@ let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) where - checkParam (Record _ (BTFunction _ p _) _) = p == params + checkParam (Record _ (BTFunction _ p _) _) = (length p) == params checkParam _ = False id2C IODeferred (Identifier i t) = do let i' = map toLower i @@ -321,6 +348,7 @@ let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) + id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc id2CTyped = id2CTyped2 Nothing @@ -340,14 +368,29 @@ Nothing -> id2C IOInsert (Identifier i tb) Just ts -> id2C (IOInsertWithType ts) (Identifier i tb) - +typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)] +typeVarDecl2BaseType d = do + st <- get + result <- sequence $ concat $ map resolveType' d + put st -- restore state (not sure if necessary) + return result + where + resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)] + resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar) + resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration" + resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType) + resolveTypeHelper' st b = do + bt <- st + return (b, bt) + 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 . baseType . head $ fromJust v else return $ f i' where - f "integer" = BTInt + f "uinteger" = BTInt False + f "integer" = BTInt True f "pointer" = BTPointerTo BTVoid f "boolean" = BTBool f "float" = BTFloat @@ -364,16 +407,18 @@ 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' -resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t -resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t -resolveType (DeriveType (InitHexNumber _)) = return BTInt -resolveType (DeriveType (InitNumber _)) = return BTInt + return $ BTArray i (BTInt True) t' +resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t +resolveType (FunctionType t a) = do + bts <- typeVarDecl2BaseType a + liftM (BTFunction False bts) $ resolveType t +resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) +resolveType (DeriveType (InitNumber _)) = return (BTInt True) resolveType (DeriveType (InitFloat _)) = return BTFloat resolveType (DeriveType (InitString _)) = return BTString -resolveType (DeriveType (InitBinOp {})) = return BTInt +resolveType (DeriveType (InitBinOp {})) = return (BTInt True) resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType -resolveType (DeriveType (BuiltInFunction{})) = return BTInt +resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type resolveType (DeriveType _) = return BTUnknown resolveType (String _) = return BTString @@ -428,34 +473,34 @@ ps = zip ['a'..] (toIsVarList params) fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] -fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do +fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do t <- type2C returnType t'<- gets lastType + bts <- typeVarDecl2BaseType params 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 $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p] - else - return [decor <+> t empty <+> text n <> parens p] - where - hasVars = hasPassByReference params + n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name + 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 _) 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 - - n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name - +fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do let isVoid = case returnType of VoidType -> True _ -> False - (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st + let res = docToLower $ text rv <> if isVoid then empty else text "_result" + t <- type2C returnType + t' <- gets lastType + + bts <- typeVarDecl2BaseType params + cu <- gets currentUnit + notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope + + n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name + let resultId = if isVoid + then n -- void type doesn't have result, solving recursive procedure calls + else (render res) + + (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars bts t') else t') empty] $ currentScope st , currentFunctionResult = if isVoid then [] else render res}) $ do p <- functionParams2C params ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) @@ -463,12 +508,16 @@ 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 decor = if inline then text "inline" else empty + let inlineDecor = if inline then case notDeclared of + True -> text "static inline" + False -> text "inline" + else empty + overloadDecor = if overload then text "__attribute__((overloadable))" else empty return [ - define - $+$ + --define + -- $+$ --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ - decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p + inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p $+$ text "{" $+$ @@ -481,20 +530,25 @@ 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 -- the second bool indicates whether declare variable as extern or not -- the third bool indicates whether include types or not -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] -tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do +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 $ if includeType then [text "typedef" <+> tp i] else [] + 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}) + return res + _ -> return res tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do t' <- liftM ((empty <+>) . ) $ type2C t @@ -508,7 +562,7 @@ ie <- initExpr mInitExpr lt <- gets lastType case (isConst, lt, ids, mInitExpr) of - (True, BTInt, [i], Just _) -> do + (True, BTInt _, [i], Just _) -> do i' <- id2CTyped t i return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] (True, BTFloat, [i], Just e) -> do @@ -548,7 +602,7 @@ tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do r <- op2CTyped op (extractTypes params) - fun2C f i (FunctionDeclaration r inline ret params body) + fun2C f i (FunctionDeclaration r inline False ret params body) op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier @@ -583,14 +637,16 @@ ie <- initExpr2C' expr lt <- gets lastType case lt of - BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars" + BTFunction True _ _ -> return $ text "&" <> ie -- <> text "__vars" _ -> return $ text "&" <> ie initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) initExpr2C' (InitBinOp op expr1 expr2) = do e1 <- initExpr2C' expr1 e2 <- initExpr2C' expr2 return $ parens $ e1 <+> text (op2C op) <+> e2 -initExpr2C' (InitNumber s) = return $ text s +initExpr2C' (InitNumber s) = do + modify(\s -> s{lastType = (BTInt True)}) + return $ text s initExpr2C' (InitFloat s) = return $ text s initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) initExpr2C' (InitString [a]) = return . quotes $ text [a] @@ -606,7 +662,7 @@ t <- gets lastType case t of BTEnum s -> return . int $ length s - BTInt -> case i' of + BTInt _ -> case i' of "byte" -> return $ int 256 _ -> error $ "InitRange identifier: " ++ i' _ -> error $ "InitRange: " ++ show r @@ -716,7 +772,7 @@ ps <- mapM phrase2C p return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f -phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref +phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True phrase2C (ProcCall ref params) = error $ "ProcCall"{-do r <- ref2C ref ps <- mapM expr2C params @@ -815,7 +871,7 @@ $$ iType <+> iEnd <+> text "=" <+> e2 <> semi $$ - text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+> + text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi where appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] @@ -823,6 +879,7 @@ e <- expr2C e' p <- phrase2C (Phrases p') return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi + phrase2C NOP = return $ text ";" phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do @@ -851,19 +908,27 @@ e2 <- expr2C expr2 t2 <- gets lastType case (op2C op, t1, t2) of - ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString)) - ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString)) - ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString)) - ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString)) - ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool)) - ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool)) - ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool)) + ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False [(False, t1), (False, t2)] BTString)) + ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False [(False, t1), (False, t2)] BTString)) + ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False [(False, t1), (False, t2)] BTString)) + ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False [(False, t1), (False, t2)] BTString)) + ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False [(False, t1), (False, t2)] BTBool)) + + -- for function/procedure comparision + ("==", BTVoid, _) -> procCompare expr1 expr2 "==" + ("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "==" + + ("!=", BTVoid, _) -> procCompare expr1 expr2 "!=" + ("!=", BTFunction _ _ _, _) -> procCompare expr1 expr2 "!=" + + ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False [(False, t1), (False, t2)] BTBool)) + ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False [(False, t1), (False, t2)] BTBool)) ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 (_, BTRecord t1 _, BTRecord t2 _) -> do i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] ref2C $ FunCall [expr1, expr2] (SimpleReference i) - (_, BTRecord t1 _, BTInt) -> do + (_, BTRecord t1 _, BTInt _) -> do -- aw, "LongInt" here is hwengine-specific hack i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] ref2C $ FunCall [expr1, expr2] (SimpleReference i) @@ -882,16 +947,24 @@ "/(float)" -> text "/(float)" -- pascal returns real value _ -> text o e1' <- return $ case (o, t1, t2) of - ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1 + ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1 _ -> parens e1 e2' <- return $ case (o, t1, t2) of - ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2 + ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2 _ -> parens e2 return $ e1' <+> o' <+> e2' where boolOps = ["==", "!=", "<", ">", "<=", ">="] + procCompare expr1 expr2 op = + case (expr1, expr2) of + (Reference r1, Reference r2) -> do + id1 <- ref2C r1 + id2 <- ref2C r2 + return $ (parens id1) <+> text op <+> (parens id2) + (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2 + expr2C (NumberLiteral s) = do - modify(\s -> s{lastType = BTInt}) + modify(\s -> s{lastType = BTInt True}) return $ text s expr2C (FloatLiteral s) = return $ text s expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) @@ -903,7 +976,10 @@ escape a = [a]-} expr2C (StringLiteral s) = addStringConst s expr2C (PCharLiteral s) = return . doubleQuotes $ text s -expr2C (Reference ref) = ref2CF ref +expr2C (Reference ref) = do + isfunc <- gets isFunctionType + modify(\s -> s{isFunctionType = False}) -- reset + if isfunc then ref2CF ref False else ref2CF ref True expr2C (PrefixOp op expr) = do e <- expr2C expr lt <- gets lastType @@ -929,7 +1005,7 @@ lt <- gets lastType case lt of BTEnum a -> return $ int 0 - BTInt -> case e' of + BTInt _ -> case e' of "longint" -> return $ int (-2147483648) BTArray {} -> return $ int 0 _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt @@ -938,18 +1014,20 @@ lt <- gets lastType case lt of BTEnum a -> return . int $ length a - 1 - BTInt -> case e' of + BTInt _ -> case e' of "longint" -> return $ int (2147483647) 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 " - (int64_t)1") $ expr2C e +expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do + e'<- expr2C e + return $ text "(int)" <> parens e' <> text " - 1" expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do e' <- expr2C e lt <- gets lastType - modify (\s -> s{lastType = BTInt}) + modify (\s -> s{lastType = BTInt True}) case lt of BTString -> return $ text "fpcrtl_Length" <> parens e' BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' @@ -967,24 +1045,24 @@ r <> parens (hsep . punctuate (char ',') $ ps) expr2C a = error $ "Don't know how to render " ++ show a -ref2CF :: Reference -> State RenderState Doc -ref2CF (SimpleReference name) = do +ref2CF :: Reference -> Bool -> State RenderState Doc +ref2CF (SimpleReference name) addParens = do i <- id2C IOLookup name t <- gets lastType case t of BTFunction _ _ rt -> do modify(\s -> s{lastType = rt}) - return $ i <> parens empty --xymeng: removed parens + return $ if addParens then i <> parens empty else i --xymeng: removed parens _ -> return $ i -ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do +ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do i <- ref2C r t <- gets lastType case t of BTFunction _ _ rt -> do modify(\s -> s{lastType = rt}) - return $ i <> parens empty + return $ if addParens then i <> parens empty else i _ -> return $ i -ref2CF r = ref2C r +ref2CF r _ = ref2C r ref2C :: Reference -> State RenderState Doc -- rewrite into proper form @@ -1040,22 +1118,31 @@ r <- fref2C ref t <- gets lastType case t of - BTFunction _ _ t' -> do - ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params + BTFunction _ bts t' -> do + ps <- liftM (parens . hsep . punctuate (char ',')) $ + if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params + then + mapM expr2CHelper (zip params bts) + else mapM expr2C params modify (\s -> s{lastType = t'}) return $ r <> ps _ -> case (ref, params) of (SimpleReference i, [p]) -> ref2C $ TypeCast i p - _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t + _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t where fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name fref2C a = ref2C a + expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc + expr2CHelper (e, (_, BTFunction _ _ _)) = do + modify (\s -> s{isFunctionType = True}) + expr2C e + expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e ref2C (Address ref) = do r <- ref2C ref lt <- gets lastType case lt of - BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars") + BTFunction True _ _ -> return $ text "&" <> parens r _ -> return $ text "&" <> parens r ref2C (TypeCast t'@(Identifier i _) expr) = do lt <- expr2C expr >> gets lastType diff -r 091293bc974f -r 00b1facf2805 tools/pas2c/PascalBasics.hs --- a/tools/pas2c/PascalBasics.hs Sun Nov 11 15:14:18 2012 +0100 +++ b/tools/pas2c/PascalBasics.hs Sun Nov 11 16:44:40 2012 +0100 @@ -18,6 +18,7 @@ , nestedComments = False , identStart = letter <|> oneOf "_" , identLetter = alphaNum <|> oneOf "_" + , opLetter = letter , reservedNames = [ "begin", "end", "program", "unit", "interface" , "implementation", "and", "or", "xor", "shl" @@ -27,7 +28,6 @@ , "downto", "div", "mod", "record", "set", "nil" , "cdecl", "external", "if", "then", "else" ] -- ++ builtin - , reservedOpNames= [] , caseSensitive = False } diff -r 091293bc974f -r 00b1facf2805 tools/pas2c/PascalParser.hs --- a/tools/pas2c/PascalParser.hs Sun Nov 11 15:14:18 2012 +0100 +++ b/tools/pas2c/PascalParser.hs Sun Nov 11 16:44:40 2012 +0100 @@ -232,19 +232,30 @@ operatorDecl ] where + + fixInit v = concat $ map (\x -> case x of + VarDeclaration a b (ids, t) c -> + let typeId = (Identifier ((\(Identifier i _) -> i) (head ids) ++ "_tt") BTUnknown) in + let res = [TypeDeclaration typeId t, VarDeclaration a b (ids, (SimpleType typeId)) c] in + case t of + RecordType _ _ -> res -- create a separated type declaration + ArrayDecl _ _ -> res + _ -> [x] + _ -> error ("checkInit:\n" ++ (show v))) v + varSection = do try $ string "var" comments v <- varsDecl1 True "variable declaration" comments - return v + return $ fixInit v constSection = do try $ string "const" comments c <- constsDecl "const declaration" comments - return c + return $ fixInit c typeSection = do try $ string "type" @@ -295,12 +306,14 @@ char ';' comments forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments) - inline <- liftM (any (== "inline;")) $ many functionDecorator + decorators <- many functionDecorator + let inline = any (== "inline;") decorators + overload = any (== "overload;") decorators b <- if isImpl && (not forward) then liftM Just functionBody else return Nothing - return $ [FunctionDeclaration i inline ret vs b] + return $ [FunctionDeclaration i inline overload ret vs b] functionDecorator = do d <- choice [ @@ -375,9 +388,9 @@ ] "simple expression" table = [ - [ Prefix (try (string "not") >> return (PrefixOp "not")) + [ Prefix (reservedOp pas "not">> return (PrefixOp "not")) , Prefix (try (char '-') >> return (PrefixOp "-"))] - , + , [ Infix (char '*' >> return (BinOp "*")) AssocLeft , Infix (char '/' >> return (BinOp "/")) AssocLeft , Infix (try (string "div") >> return (BinOp "div")) AssocLeft diff -r 091293bc974f -r 00b1facf2805 tools/pas2c/PascalPreprocessor.hs --- a/tools/pas2c/PascalPreprocessor.hs Sun Nov 11 15:14:18 2012 +0100 +++ b/tools/pas2c/PascalPreprocessor.hs Sun Nov 11 16:44:40 2012 +0100 @@ -15,9 +15,12 @@ , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n" ] + initDefines = Map.fromList [ ("FPC", "") , ("PAS2C", "") +-- , ("WEBGL", "") +-- , ("AI_MAINTHREAD", "") , ("ENDIAN_LITTLE", "") , ("S3D_DISABLED", "") ] diff -r 091293bc974f -r 00b1facf2805 tools/pas2c/PascalUnitSyntaxTree.hs --- a/tools/pas2c/PascalUnitSyntaxTree.hs Sun Nov 11 15:14:18 2012 +0100 +++ b/tools/pas2c/PascalUnitSyntaxTree.hs Sun Nov 11 16:44:40 2012 +0100 @@ -19,7 +19,7 @@ deriving Show data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression) - | FunctionDeclaration Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) + | FunctionDeclaration Identifier Bool Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) deriving Show data TypeDecl = SimpleType Identifier @@ -103,12 +103,12 @@ data BaseType = BTUnknown | BTChar | BTString - | BTInt + | BTInt Bool -- second param indicates whether signed or not | BTBool | BTFloat | BTRecord String [(String, BaseType)] | BTArray Range BaseType BaseType - | BTFunction Bool Int BaseType + | BTFunction Bool [(Bool, BaseType)] BaseType -- (Bool, BaseType), Bool indiciates whether var or not | BTPointerTo BaseType | BTUnresolved String | BTSet BaseType