tools/pas2c.hs
changeset 7333 520a16a14747
parent 7329 92b6d8ae99e4
child 7335 3c6f08af7dac
--- a/tools/pas2c.hs	Sat Jun 30 00:34:51 2012 +0400
+++ b/tools/pas2c.hs	Sat Jun 30 01:09:31 2012 +0400
@@ -248,8 +248,8 @@
     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)
+            (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})
@@ -268,7 +268,7 @@
         let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
             modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
     where
-        checkParam (_, BTFunction p _) = p == params
+        checkParam (_, BTFunction _ p _) = p == params
         checkParam _ = False
 id2C IODeferred (Identifier i t) = do
     let i' = map toLower i
@@ -330,7 +330,7 @@
     t' <- resolveType t
     return $ BTArray i BTInt t'
 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
-resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t
+resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t
 resolveType (DeriveType (InitHexNumber _)) = return BTInt
 resolveType (DeriveType (InitNumber _)) = return BTInt
 resolveType (DeriveType (InitFloat _)) = return BTFloat
@@ -396,11 +396,13 @@
     t <- type2C returnType
     t'<- gets lastType
     p <- withState' id $ functionParams2C params
-    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name
-    if hasPassByReference params then
+    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
+    if hasVars then
         return [funWithVarsToDefine n params $+$ t empty <+> text (n ++ "__vars") <> parens p]
         else
         return [t empty <+> text n <> parens p]
+    where
+        hasVars = hasPassByReference params
 
 
 fun2C True rv (FunctionDeclaration name@(Identifier i _) returnType params (Just (tvars, phrase))) = do
@@ -410,7 +412,7 @@
 
     notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
 
-    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name
+    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
 
     let isVoid = case returnType of
             VoidType -> True
@@ -424,8 +426,8 @@
 
     let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
 
-    return [(if notDeclared && hasPassByReference params then funWithVarsToDefine n params else empty) $+$
-        t empty <+> text (if hasPassByReference params then n ++ "__vars" else n) <> parens p
+    return [(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+        t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
         $+$
         text "{"
         $+$
@@ -436,6 +438,7 @@
     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 _ tv _ = error $ "fun2C: I don't render " ++ show tv
@@ -502,7 +505,12 @@
 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
 initExpr2C a = initExpr2C' a
 initExpr2C' InitNull = return $ text "NULL"
-initExpr2C' (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C' expr)
+initExpr2C' (InitAddress expr) = do
+    ie <- initExpr2C' expr
+    lt <- gets lastType
+    case lt of
+        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
@@ -749,13 +757,13 @@
     e2 <- expr2C expr2
     t2 <- gets lastType
     case (op2C op, t1, t2) of
-        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction 2 BTString))
-        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction 2 BTString))
-        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction 2 BTString))
-        ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction 2 BTString))
-        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction 2 BTBool))
-        ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction 2 BTBool))
-        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction 2 BTBool))
+        ("+", 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))
         ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
         ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
         (_, BTRecord t1 _, BTRecord t2 _) -> do
@@ -841,7 +849,7 @@
     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 $
@@ -853,7 +861,7 @@
     i <- id2C IOLookup name
     t <- gets lastType
     case t of
-         BTFunction _ rt -> do
+         BTFunction _ _ rt -> do
              modify(\s -> s{lastType = rt})
              return $ i <> parens empty
          _ -> return $ i
@@ -861,7 +869,7 @@
     i <- ref2C r
     t <- gets lastType
     case t of
-         BTFunction _ rt -> do
+         BTFunction _ _ rt -> do
              modify(\s -> s{lastType = rt})
              return $ i <> parens empty
          _ -> return $ i
@@ -921,7 +929,7 @@
     r <- fref2C ref
     t <- gets lastType
     case t of
-        BTFunction _ t' -> do
+        BTFunction _ _ t' -> do
             ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
             modify (\s -> s{lastType = t'})
             return $ r <> ps
@@ -934,7 +942,10 @@
 
 ref2C (Address ref) = do
     r <- ref2C ref
-    return $ text "&" <> parens r
+    lt <- gets lastType
+    case lt of
+        BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")
+        _ -> return $ text "&" <> parens r
 ref2C (TypeCast t'@(Identifier i _) expr) = do
     lt <- expr2C expr >> gets lastType
     case (map toLower i, lt) of