Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
--- a/hedgewars/uLand.pas Sun Feb 05 15:55:15 2012 +0100
+++ b/hedgewars/uLand.pas Sun Feb 05 23:24:43 2012 +0400
@@ -30,7 +30,7 @@
implementation
uses uConsole, uStore, uRandom, uLandObjects, uIO, uLandTexture, sysutils,
- uVariables, uUtils, uCommands, Adler32, uDebug, uLandPainted, uTextures,
+ uVariables, uUtils, uCommands, adler32, uDebug, uLandPainted, uTextures,
uLandGenMaze, uLandOutline;
--- a/tools/PascalParser.hs Sun Feb 05 15:55:15 2012 +0100
+++ b/tools/PascalParser.hs Sun Feb 05 23:24:43 2012 +0400
@@ -113,7 +113,7 @@
comments
e <- initExpression
comments
- return $ VarDeclaration False ([i], fromMaybe UnknownType t) (Just e)
+ return $ VarDeclaration False ([i], fromMaybe (DeriveType e) t) (Just e)
typeDecl = choice [
char '^' >> typeDecl >>= return . PointerTo
--- a/tools/PascalUnitSyntaxTree.hs Sun Feb 05 15:55:15 2012 +0100
+++ b/tools/PascalUnitSyntaxTree.hs Sun Feb 05 23:24:43 2012 +0400
@@ -1,7 +1,7 @@
module PascalUnitSyntaxTree where
---import Data.Traversable
import Data.Maybe
+import Data.Char
data PascalUnit =
Program Identifier Implementation Phrase
@@ -30,6 +30,7 @@
| String Integer
| Set TypeDecl
| FunctionType TypeDecl [TypeVarDeclaration]
+ | DeriveType InitExpression
| UnknownType
deriving Show
data Range = Range Identifier
@@ -108,17 +109,19 @@
deriving Show
+{--
type2BaseType :: TypeDecl -> BaseType
-type2BaseType (SimpleType (Identifier s _)) = f s
+type2BaseType st@(SimpleType (Identifier s _)) = f (map toLower s)
where
f "longint" = BTInt
f "integer" = BTInt
f "word" = BTInt
f "pointer" = BTPointerTo BTVoid
- f _ = BTUnknown
+ f _ = error $ show st
type2BaseType (Sequence ids) = BTEnum $ map (\(Identifier i _) -> i) ids
type2BaseType (RecordType tv mtvs) = BTRecord $ concatMap f (concat $ tv : fromMaybe [] mtvs)
where
f (VarDeclaration _ (ids, td) _) = map (\(Identifier i _) -> (i, type2BaseType td)) ids
-type2BaseType _ = BTUnknown
-
\ No newline at end of file
+type2BaseType (PointerTo t) = BTPointerTo $ type2BaseType t
+type2BaseType a = error $ show a
+--}
--- a/tools/pas2c.hs Sun Feb 05 15:55:15 2012 +0100
+++ b/tools/pas2c.hs Sun Feb 05 23:24:43 2012 +0400
@@ -75,9 +75,9 @@
extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv
tv2id :: TypeVarDeclaration -> [Record]
- tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i (type2BaseType t)) $ i : ids
- tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, type2BaseType t))]
- tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i (type2BaseType t)) ids
+ tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i BTUnknown) $ i : ids
+ tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, BTUnknown))]
+ tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i BTUnknown) ids
tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown]
tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown]
fi i t = (map toLower i, (i, t))
@@ -157,8 +157,35 @@
return . text . fst . snd . fromJust $ v
id2CTyped :: BaseType -> Identifier -> State RenderState Doc
-id2CTyped BTUnknown i = error $ show i
+id2CTyped BTUnknown i = do
+ ns <- gets currentScope
+ error $ show i ++ "\n" ++ show ns
id2CTyped bt (Identifier i _) = id2C True (Identifier i bt)
+
+
+resolveType :: TypeDecl -> State RenderState BaseType
+resolveType st@(SimpleType (Identifier i _)) = do
+ let i' = map toLower i
+ v <- gets $ find (\(a, _) -> a == i') . currentScope
+ if isJust v then return . snd . snd $ fromJust v else return $ f i'
+ where
+ f "integer" = BTInt
+ f "pointer" = BTPointerTo BTVoid
+ f _ = error $ show st
+resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
+resolveType (RecordType tv mtvs) = do
+ tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
+ return . BTRecord . concat $ tvs
+ where
+ f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
+ f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
+resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t
+resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t
+resolveType (FunctionType _ _) = return BTFunction
+resolveType (DeriveType _) = return BTInt
+--resolveType UnknownType = return BTUnknown
+resolveType a = error $ "resolveType: " ++ show a
+
tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc
tvar2C _ (FunctionDeclaration name returnType params Nothing) = do
@@ -188,12 +215,14 @@
tvar2C _ td@(TypeDeclaration i' t) = do
tp <- type2C t
- i <- id2CTyped (type2BaseType t) i'
+ tb <- resolveType t
+ i <- id2CTyped tb i'
return $ text "type" <+> i <+> tp <> text ";"
tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
t' <- type2C t
- i <- mapM (id2CTyped (type2BaseType t)) ids
+ tb <- resolveType t
+ i <- mapM (id2CTyped tb) ids
ie <- initExpr mInitExpr
return $ if isConst then text "const" else empty
<+> t'
@@ -238,6 +267,7 @@
type2C (ArrayDecl r t) = return $ text "<<array type>>"
type2C (Set t) = return $ text "<<set>>"
type2C (FunctionType returnType params) = return $ text "<<function>>"
+type2C (DeriveType _) = return $ text "<<type derived from constant literal>>"
phrase2C :: Phrase -> State RenderState Doc
phrase2C (Phrases p) = do