Finally fix the bug with pointer declarations polluting namespace with bad records
--- a/hedgewars/pas2cSystem.pas Mon Apr 02 00:32:17 2012 +0200
+++ b/hedgewars/pas2cSystem.pas Mon Apr 02 16:14:29 2012 +0400
@@ -60,12 +60,12 @@
trunc, round : function : integer;
Abs, Sqr : function : integer;
- StrPas, FormatDateTime, copy, delete, str : function : shortstring;
+ StrPas, FormatDateTime, copy, delete, str, pos : function : shortstring;
- assign, rewrite, reset, flush : procedure;
+ assign, rewrite, reset, flush, BlockWrite, close : procedure;
IOResult : function : integer;
exit, break, halt : procedure;
- TextFile : Handle;
+ TextFile, file : Handle;
Sqrt, ArcTan2, pi, cos, sin : function : float;
@@ -86,6 +86,6 @@
glcolor4ub, gl_texture_wrap_s, gltexparameteri,
gl_texture_wrap_t, gl_texture_min_filter,
gl_linear, gl_texture_mag_filter, glgentextures,
- gldeletetextures : procedure;
+ gldeletetextures, glreadpixels : procedure;
TThreadId : function : integer;
--- a/hedgewars/uMisc.pas Mon Apr 02 00:32:17 2012 +0200
+++ b/hedgewars/uMisc.pas Mon Apr 02 16:14:29 2012 +0400
@@ -170,7 +170,7 @@
end;
procedure initModule;
-const SDL_PIXELFORMAT_ABGR8888 = ((1 shl 31) or (6 shl 24) or (7 shl 20) or (6 shl 16) or (32 shl 8) or 4);
+const SDL_PIXELFORMAT_ABGR8888 = (1 shl 31) or (6 shl 24) or (7 shl 20) or (6 shl 16) or (32 shl 8) or 4;
begin
conversionFormat:= SDL_AllocFormat(SDL_PIXELFORMAT_ABGR8888);
end;
--- a/tools/PascalUnitSyntaxTree.hs Mon Apr 02 00:32:17 2012 +0200
+++ b/tools/PascalUnitSyntaxTree.hs Mon Apr 02 16:14:29 2012 +0400
@@ -32,7 +32,6 @@
| FunctionType TypeDecl [TypeVarDeclaration]
| DeriveType InitExpression
| VoidType
- | UnknownType
deriving Show
data Range = Range Identifier
| RangeFromTo InitExpression InitExpression
--- a/tools/pas2c.hs Mon Apr 02 00:32:17 2012 +0200
+++ b/tools/pas2c.hs Mon Apr 02 16:14:29 2012 +0400
@@ -76,6 +76,8 @@
renderCFiles units = do
let u = Map.toList units
let nss = Map.map (toNamespace nss) units
+ hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss)
+ writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
mapM_ (toCFiles nss) u
where
toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record]
@@ -158,7 +160,7 @@
where
injectNamespace (Identifier i _) = do
getNS <- gets (flip Map.lookup . namespaces)
- let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i))
+ let f = flip (foldl (flip (:))) (fromMaybe [] (getNS i))
modify (\s -> s{currentScope = f $ currentScope s})
uses2List :: Uses -> [String]
@@ -167,6 +169,12 @@
id2C :: InsertOption -> Identifier -> State RenderState Doc
id2C IOInsert (Identifier i t) = do
+ ns <- gets currentScope
+{-- case t of
+ BTUnknown -> do
+ ns <- gets currentScope
+ error $ "id2C IOInsert: type BTUnknown for " ++ show i ++ "\nnamespace: " ++ show (take 100 ns)
+ _ -> do --}
modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n})
return $ text i
where
@@ -176,15 +184,13 @@
v <- gets $ find (\(a, _) -> a == i') . currentScope
ns <- gets currentScope
if isNothing v then
- error $ "Not defined: '" ++ i' ++ "'\n" -- ++ show ns
+ error $ "Not defined: '" ++ i' ++ "'\n" ++ show (take 100 ns)
else
let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
id2C IODeferred (Identifier i t) = do
let i' = map toLower i
v <- gets $ find (\(a, _) -> a == i') . currentScope
if (isNothing v) then
- do
- modify (\s -> s{currentScope = (i', (i, t)) : currentScope s})
return $ text i
else
return . text . fst . snd . fromJust $ v
@@ -197,7 +203,8 @@
BTUnknown -> do
ns <- gets currentScope
error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show (take 100 ns)
- _ -> id2C IOInsert (Identifier i tb)
+ _ -> return ()
+ id2C IOInsert (Identifier i tb)
resolveType :: TypeDecl -> State RenderState BaseType
@@ -236,11 +243,9 @@
resolveType (String _) = return BTString
resolveType VoidType = return BTVoid
resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
-resolveType (RangeType _) = return $ BTUnknown
+resolveType (RangeType _) = return $ BTVoid
resolveType (Set t) = liftM BTSet $ resolveType t
---resolveType UnknownType = return BTUnknown
-resolveType a = error $ "resolveType: " ++ show a
-
+
fromPointer :: BaseType -> State RenderState BaseType
fromPointer (BTPointerTo t) = f t
@@ -252,7 +257,9 @@
else
error $ "Unknown type " ++ show t
f t = return t
-fromPointer t = error $ "Dereferencing from non-pointer type " ++ show t
+fromPointer t = do
+ ns <- gets currentScope
+ error $ "Dereferencing from non-pointer type " ++ show t ++ "\n\n" ++ show (take 100 ns)
tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc
@@ -337,7 +344,7 @@
type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i
type2C' (PointerTo t) = liftM (<> text "*") $ type2C t
type2C' (RecordType tvs union) = do
- t <- mapM (tvar2C False) tvs
+ t <- withState' id $ mapM (tvar2C False) tvs
return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}"
type2C' (RangeType r) = return $ text "<<range type>>"
type2C' (Sequence ids) = do
@@ -389,7 +396,8 @@
text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;")
phrase2C (WithBlock ref p) = do
r <- ref2C ref
- ph <- phrase2C $ wrapPhrase p
+ (BTRecord rs) <- gets lastType
+ ph <- withRecordNamespace rs $ phrase2C $ wrapPhrase p
return $ text "namespace" <> parens r $$ ph
phrase2C (ForCycle i' e1' e2' p) = do
i <- id2C IOLookup i'
@@ -446,9 +454,14 @@
a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns)
return $ r <> (brackets . hcat) (punctuate comma es)
ref2C (SimpleReference name) = id2C IOLookup name
-ref2C (RecordField (Dereference ref1) ref2) = do
+ref2C rf@(RecordField (Dereference ref1) ref2) = do
r1 <- ref2C ref1
- r2 <- ref2C ref2
+ t <- fromPointer =<< gets lastType
+ ns <- gets currentScope
+ r2 <- case t of
+ BTRecord rs -> withRecordNamespace rs $ ref2C ref2
+ BTUnit -> withLastIdNamespace $ ref2C ref2
+ a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns)
return $
r1 <> text "->" <> r2
ref2C rf@(RecordField ref1 ref2) = do