sheepy-clone: comparison tools/pas2c/Pas2C.hs

equal deleted inserted replaced

-:0f6878b5395a
+:cd2a64a1f4aa
 pascal2C (Unit _ interface implementation _ _) =
 liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
 pascal2C (Program _ implementation mainFunction) = do
 impl <- implementation2C implementation
-[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)))
+[main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False 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
 pascal2C _ = error "pascal2C: pattern not matched"
 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
+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
 -- the third bool indicates whether include types or not
 id2C IOInsert i = id2C (IOInsertWithType empty) i
 id2C (IOInsertWithType d) (Identifier i t) = do
 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 _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t)
-(BTFunction _ _ _, _) -> (cu ++ i, t)
+(BTFunction _ e _ _, _) -> ((if e then id else (++) cu) 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'
 where
 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 (setLastIdValues vv) >> (return . text . lcaseId $ vv)
 where
-checkParam (Record _ (BTFunction _ p _) _) = (length p) == params
+checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params
 checkParam _ = False
 id2C IODeferred (Identifier i _) = do
 let i' = map toLower i
 v <- gets $ Map.lookup i' . currentScope
 if (isNothing v) then
 t' <- resolveType t
 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
+liftM (BTFunction False 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 True)
 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 _ overload returnType params Nothing) = do
+fun2C _ _ (FunctionDeclaration name _ overload external 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 False bts t') name
+n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external 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 overload returnType params (Just (tvars, phrase))) = do
+fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do
 let isVoid = case returnType of
 VoidType -> True
 _ -> False
 let res = docToLower $ text rv <> if isVoid then empty else text "_result"
 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
+n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external 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
+(p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False 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)
 return (p, ph)
 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
+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 _ (TypeDeclaration i' t) = do
 i <- id2CTyped t i'
 tp <- type2C 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 inline False ret params body)
+fun2C f i (FunctionDeclaration r inline False False ret params body)
 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
 op2CTyped op t = do
 t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t
 initExpr2C' InitNull = return $ text "NULL"
 initExpr2C' (InitAddress expr) = do
 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
 e1 <- expr2C expr1
 t1 <- gets lastType
 e2 <- expr2C expr2
 t2 <- gets lastType
 case (op2C op, t1, t2) of
-("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (BTFunction False [(False, t1), (False, t2)] BTString))
+("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString))
-("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (BTFunction False [(False, t1), (False, t2)] BTAString))
+("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2  BTAString))
-("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (BTFunction False [(False, t1), (False, t2)] BTBool))
+("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2  BTBool))
 (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop
 (_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop
-("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False [(False, t1), (False, t2)] BTString))
+("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2  BTString))
-("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False [(False, t1), (False, t2)] BTString))
+("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2  BTString))
-("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False [(False, t1), (False, t2)] BTString))
+("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2  BTString))
-("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False [(False, t1), (False, t2)] BTString))
+("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2  BTString))
-("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False [(False, t1), (False, t2)] BTBool))
+("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2  BTBool))
 -- for function/procedure comparision
 ("==", BTVoid, _) -> procCompare expr1 expr2 "=="
-("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "=="
+("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "=="
 ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="
-("!=", BTFunction _ _ _, _) -> procCompare expr1 expr2 "!="
+("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!="
-("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False [(False, t1), (False, t2)] BTBool))
+("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2  BTBool))
-("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False [(False, t1), (False, t2)] BTBool))
+("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 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)
 e2' <- return $ case (o, t1, t2) of
 ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2
 _ -> parens e2
 return $ e1' <+> o' <+> e2'
 where
+fff t1 t2 = BTFunction False False [(False, t1), (False, t2)]
 boolOps = ["==", "!=", "<", ">", "<=", ">="]
 procCompare expr1 expr2 op =
 case (expr1, expr2) of
 (Reference r1, Reference r2) -> do
 id1 <- ref2C r1
 expr2C (BuiltInFunCall params ref) = do
 r <- ref2C ref
 t <- gets lastType
 ps <- mapM expr2C params
 case t of
-BTFunction _ _ t' -> do
+BTFunction _ _ _ t' -> do
 modify (\s -> s{lastType = t'})
 _ -> error $ "BuiltInFunCall lastType: " ++ show t
 return $
 r <> parens (hsep . punctuate (char ',') $ ps)
 expr2C a = error $ "Don't know how to render " ++ show a
 ref2CF :: Reference -> Bool -> State RenderState Doc
 ref2CF (SimpleReference name) addParens = do
 i <- id2C IOLookup name
 t <- gets lastType
 case t of
-BTFunction _ _ rt -> do
+BTFunction _ _ _ rt -> do
 modify(\s -> s{lastType = rt})
 return $ if addParens then i <> parens empty else i --xymeng: removed parens
 _ -> return $ i
 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do
 i <- ref2C r
 t <- gets lastType
 case t of
-BTFunction _ _ rt -> do
+BTFunction _ _ _ rt -> do
 modify(\s -> s{lastType = rt})
 return $ if addParens then i <> parens empty else i
 _ -> return $ i
 ref2CF r _ = ref2C r
 return $ (parens $ text "*" <> r)
 ref2C f@(FunCall params ref) = do
 r <- fref2C ref
 t <- gets lastType
 case t of
-BTFunction _ bts t' -> do
+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
 _ -> 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
+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
+BTFunction True _ _ _ -> return $ text "&" <> parens r
 _ -> return $ text "&" <> parens r
 ref2C (TypeCast t'@(Identifier i _) expr) = do
 lt <- expr2C expr >> gets lastType
 case (map toLower i, lt) of
 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))

changeset 10129	cd2a64a1f4aa
parent 10127	7f29a65aa1e4
child 10131	4b4a043111f4