246 id2C IOInsert (Identifier i t) = do |
246 id2C IOInsert (Identifier i t) = do |
247 ns <- gets currentScope |
247 ns <- gets currentScope |
248 tom <- gets (Set.member n . toMangle) |
248 tom <- gets (Set.member n . toMangle) |
249 cu <- gets currentUnit |
249 cu <- gets currentUnit |
250 let (i', t') = case (t, tom) of |
250 let (i', t') = case (t, tom) of |
251 (BTFunction p _, True) -> (cu ++ i ++ ('_' : show p), t) |
251 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t) |
252 (BTFunction _ _, _) -> (cu ++ i, t) |
252 (BTFunction _ _ _, _) -> (cu ++ i, t) |
253 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
253 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
254 _ -> (i, t) |
254 _ -> (i, t) |
255 modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t')] (currentScope s), lastIdentifier = n}) |
255 modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t')] (currentScope s), lastIdentifier = n}) |
256 return $ text i' |
256 return $ text i' |
257 where |
257 where |
266 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
266 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
267 else |
267 else |
268 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
268 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
269 modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
269 modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
270 where |
270 where |
271 checkParam (_, BTFunction p _) = p == params |
271 checkParam (_, BTFunction _ p _) = p == params |
272 checkParam _ = False |
272 checkParam _ = False |
273 id2C IODeferred (Identifier i t) = do |
273 id2C IODeferred (Identifier i t) = do |
274 let i' = map toLower i |
274 let i' = map toLower i |
275 v <- gets $ Map.lookup i' . currentScope |
275 v <- gets $ Map.lookup i' . currentScope |
276 if (isNothing v) then |
276 if (isNothing v) then |
328 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
328 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
329 resolveType (ArrayDecl (Just i) t) = do |
329 resolveType (ArrayDecl (Just i) t) = do |
330 t' <- resolveType t |
330 t' <- resolveType t |
331 return $ BTArray i BTInt t' |
331 return $ BTArray i BTInt t' |
332 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t |
332 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t |
333 resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t |
333 resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t |
334 resolveType (DeriveType (InitHexNumber _)) = return BTInt |
334 resolveType (DeriveType (InitHexNumber _)) = return BTInt |
335 resolveType (DeriveType (InitNumber _)) = return BTInt |
335 resolveType (DeriveType (InitNumber _)) = return BTInt |
336 resolveType (DeriveType (InitFloat _)) = return BTFloat |
336 resolveType (DeriveType (InitFloat _)) = return BTFloat |
337 resolveType (DeriveType (InitString _)) = return BTString |
337 resolveType (DeriveType (InitString _)) = return BTString |
338 resolveType (DeriveType (InitBinOp {})) = return BTInt |
338 resolveType (DeriveType (InitBinOp {})) = return BTInt |
394 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
394 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
395 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
395 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
396 t <- type2C returnType |
396 t <- type2C returnType |
397 t'<- gets lastType |
397 t'<- gets lastType |
398 p <- withState' id $ functionParams2C params |
398 p <- withState' id $ functionParams2C params |
399 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
399 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name |
400 if hasPassByReference params then |
400 if hasVars then |
401 return [funWithVarsToDefine n params $+$ t empty <+> text (n ++ "__vars") <> parens p] |
401 return [funWithVarsToDefine n params $+$ t empty <+> text (n ++ "__vars") <> parens p] |
402 else |
402 else |
403 return [t empty <+> text n <> parens p] |
403 return [t empty <+> text n <> parens p] |
|
404 where |
|
405 hasVars = hasPassByReference params |
404 |
406 |
405 |
407 |
406 fun2C True rv (FunctionDeclaration name@(Identifier i _) returnType params (Just (tvars, phrase))) = do |
408 fun2C True rv (FunctionDeclaration name@(Identifier i _) returnType params (Just (tvars, phrase))) = do |
407 let res = docToLower $ text rv <> text "_result" |
409 let res = docToLower $ text rv <> text "_result" |
408 t <- type2C returnType |
410 t <- type2C returnType |
409 t'<- gets lastType |
411 t'<- gets lastType |
410 |
412 |
411 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
413 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
412 |
414 |
413 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
415 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name |
414 |
416 |
415 let isVoid = case returnType of |
417 let isVoid = case returnType of |
416 VoidType -> True |
418 VoidType -> True |
417 _ -> False |
419 _ -> False |
418 |
420 |
422 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
424 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
423 return (p, ph) |
425 return (p, ph) |
424 |
426 |
425 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
427 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
426 |
428 |
427 return [(if notDeclared && hasPassByReference params then funWithVarsToDefine n params else empty) $+$ |
429 return [(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ |
428 t empty <+> text (if hasPassByReference params then n ++ "__vars" else n) <> parens p |
430 t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p |
429 $+$ |
431 $+$ |
430 text "{" |
432 text "{" |
431 $+$ |
433 $+$ |
432 nest 4 phrasesBlock |
434 nest 4 phrasesBlock |
433 $+$ |
435 $+$ |
434 text "}"] |
436 text "}"] |
435 where |
437 where |
436 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
438 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
437 phrase2C' p = phrase2C p |
439 phrase2C' p = phrase2C p |
438 un [a] b = a : b |
440 un [a] b = a : b |
|
441 hasVars = hasPassByReference params |
439 |
442 |
440 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
443 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
441 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
444 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
442 |
445 |
443 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
446 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
500 |
503 |
501 initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc |
504 initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc |
502 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
505 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
503 initExpr2C a = initExpr2C' a |
506 initExpr2C a = initExpr2C' a |
504 initExpr2C' InitNull = return $ text "NULL" |
507 initExpr2C' InitNull = return $ text "NULL" |
505 initExpr2C' (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C' expr) |
508 initExpr2C' (InitAddress expr) = do |
|
509 ie <- initExpr2C' expr |
|
510 lt <- gets lastType |
|
511 case lt of |
|
512 BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars" |
|
513 _ -> return $ text "&" <> ie |
506 initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) |
514 initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) |
507 initExpr2C' (InitBinOp op expr1 expr2) = do |
515 initExpr2C' (InitBinOp op expr1 expr2) = do |
508 e1 <- initExpr2C' expr1 |
516 e1 <- initExpr2C' expr1 |
509 e2 <- initExpr2C' expr2 |
517 e2 <- initExpr2C' expr2 |
510 return $ parens $ e1 <+> text (op2C op) <+> e2 |
518 return $ parens $ e1 <+> text (op2C op) <+> e2 |
747 e1 <- expr2C expr1 |
755 e1 <- expr2C expr1 |
748 t1 <- gets lastType |
756 t1 <- gets lastType |
749 e2 <- expr2C expr2 |
757 e2 <- expr2C expr2 |
750 t2 <- gets lastType |
758 t2 <- gets lastType |
751 case (op2C op, t1, t2) of |
759 case (op2C op, t1, t2) of |
752 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction 2 BTString)) |
760 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString)) |
753 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction 2 BTString)) |
761 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString)) |
754 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction 2 BTString)) |
762 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString)) |
755 ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction 2 BTString)) |
763 ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString)) |
756 ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction 2 BTBool)) |
764 ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool)) |
757 ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction 2 BTBool)) |
765 ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool)) |
758 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction 2 BTBool)) |
766 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool)) |
759 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
767 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
760 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
768 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
761 (_, BTRecord t1 _, BTRecord t2 _) -> do |
769 (_, BTRecord t1 _, BTRecord t2 _) -> do |
762 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] |
770 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] |
763 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
771 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
839 expr2C (BuiltInFunCall params ref) = do |
847 expr2C (BuiltInFunCall params ref) = do |
840 r <- ref2C ref |
848 r <- ref2C ref |
841 t <- gets lastType |
849 t <- gets lastType |
842 ps <- mapM expr2C params |
850 ps <- mapM expr2C params |
843 case t of |
851 case t of |
844 BTFunction _ t' -> do |
852 BTFunction _ _ t' -> do |
845 modify (\s -> s{lastType = t'}) |
853 modify (\s -> s{lastType = t'}) |
846 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
854 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
847 return $ |
855 return $ |
848 r <> parens (hsep . punctuate (char ',') $ ps) |
856 r <> parens (hsep . punctuate (char ',') $ ps) |
849 expr2C a = error $ "Don't know how to render " ++ show a |
857 expr2C a = error $ "Don't know how to render " ++ show a |
851 ref2CF :: Reference -> State RenderState Doc |
859 ref2CF :: Reference -> State RenderState Doc |
852 ref2CF (SimpleReference name) = do |
860 ref2CF (SimpleReference name) = do |
853 i <- id2C IOLookup name |
861 i <- id2C IOLookup name |
854 t <- gets lastType |
862 t <- gets lastType |
855 case t of |
863 case t of |
856 BTFunction _ rt -> do |
864 BTFunction _ _ rt -> do |
857 modify(\s -> s{lastType = rt}) |
865 modify(\s -> s{lastType = rt}) |
858 return $ i <> parens empty |
866 return $ i <> parens empty |
859 _ -> return $ i |
867 _ -> return $ i |
860 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do |
868 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do |
861 i <- ref2C r |
869 i <- ref2C r |
862 t <- gets lastType |
870 t <- gets lastType |
863 case t of |
871 case t of |
864 BTFunction _ rt -> do |
872 BTFunction _ _ rt -> do |
865 modify(\s -> s{lastType = rt}) |
873 modify(\s -> s{lastType = rt}) |
866 return $ i <> parens empty |
874 return $ i <> parens empty |
867 _ -> return $ i |
875 _ -> return $ i |
868 ref2CF r = ref2C r |
876 ref2CF r = ref2C r |
869 |
877 |
919 return $ (parens $ text "*" <> r) |
927 return $ (parens $ text "*" <> r) |
920 ref2C f@(FunCall params ref) = do |
928 ref2C f@(FunCall params ref) = do |
921 r <- fref2C ref |
929 r <- fref2C ref |
922 t <- gets lastType |
930 t <- gets lastType |
923 case t of |
931 case t of |
924 BTFunction _ t' -> do |
932 BTFunction _ _ t' -> do |
925 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
933 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
926 modify (\s -> s{lastType = t'}) |
934 modify (\s -> s{lastType = t'}) |
927 return $ r <> ps |
935 return $ r <> ps |
928 _ -> case (ref, params) of |
936 _ -> case (ref, params) of |
929 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
937 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
932 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
940 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
933 fref2C a = ref2C a |
941 fref2C a = ref2C a |
934 |
942 |
935 ref2C (Address ref) = do |
943 ref2C (Address ref) = do |
936 r <- ref2C ref |
944 r <- ref2C ref |
937 return $ text "&" <> parens r |
945 lt <- gets lastType |
|
946 case lt of |
|
947 BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars") |
|
948 _ -> return $ text "&" <> parens r |
938 ref2C (TypeCast t'@(Identifier i _) expr) = do |
949 ref2C (TypeCast t'@(Identifier i _) expr) = do |
939 lt <- expr2C expr >> gets lastType |
950 lt <- expr2C expr >> gets lastType |
940 case (map toLower i, lt) of |
951 case (map toLower i, lt) of |
941 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
952 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
942 ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) |
953 ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) |