# HG changeset patch
# User unc0rr
# Date 1334170041 -14400
# Node ID 34d3bc7bd8b180ddfb14a1c47d780b8e868814c6
# Parent  f44042ba755c4666d32a0e5e7eee4b0fb621cc78
Support operators declarations

diff -r f44042ba755c -r 34d3bc7bd8b1 tools/pas2c.hs
--- a/tools/pas2c.hs	Wed Apr 11 22:46:59 2012 +0400
+++ b/tools/pas2c.hs	Wed Apr 11 22:47:21 2012 +0400
@@ -270,23 +270,23 @@
     
 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
 
-tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc]
-tvar2C _ (FunctionDeclaration name returnType params Nothing) = do
+fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
+fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do
     t <- type2C returnType 
     t'<- gets lastType
     p <- withState' id $ functionParams2C params
     n <- id2C IOInsert $ setBaseType (BTFunction t') name
     return [t empty <+> n <> parens p]
     
-tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
+fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
+    let res = docToLower $ text rv <> text "_result"
     t <- type2C returnType
     t'<- gets lastType
     n <- id2C IOInsert $ setBaseType (BTFunction t') name
-    (p, ph) <- withState' (\st -> st{currentScope = (lastIdentifier st, (lastIdentifier st ++ "_result", t')) : currentScope st}) $ do
+    (p, ph) <- withState' (\st -> st{currentScope = (map toLower rv, (render res, t')) : currentScope st}) $ do
         p <- functionParams2C params
         ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
         return (p, ph)
-    let res = docToLower $ n <> text "_result"
     let phrasesBlock = case returnType of
             VoidType -> ph
             _ -> t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
@@ -302,8 +302,12 @@
     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
     phrase2C' p = phrase2C p
     
-tvar2C 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]
+tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) =
+    fun2C b name f
 tvar2C _ td@(TypeDeclaration i' t) = do
     i <- id2CTyped t i'
     tp <- type2C t
@@ -317,10 +321,35 @@
     initExpr Nothing = return $ empty
     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
     
-tvar2C f (OperatorDeclaration op i ret params body) = 
-    tvar2C f (FunctionDeclaration i ret params body)
+tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do
+    r <- op2CTyped op (extractTypes params)
+    fun2C f i (FunctionDeclaration r 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
+    bt <- gets lastType
+    return $ case bt of
+         BTRecord {} -> Identifier (t' ++ "_op_" ++ opStr) bt
+         _ -> Identifier t' bt
+    where 
+    opStr = case op of
+                    "+" -> "add"
+                    "-" -> "sub"
+                    "*" -> "mul"
+                    "/" -> "div"
+                    "=" -> "eq"
+                    "<" -> "lt"
+                    ">" -> "gt"
+                    _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
+    
+extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
+extractTypes = concatMap f
+    where
+        f (VarDeclaration _ (ids, t) _) = replicate (length ids) t
+        f a = error $ "extractTypes: can't extract from " ++ show a
+
 initExpr2C :: InitExpression -> State RenderState Doc
 initExpr2C InitNull = return $ text "NULL"
 initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr)