hedgewars: comparison tools/pas2c.hs

equal deleted inserted replaced

-:3633928a3188
+:59da15acb2f2
 renderCFiles :: Map.Map String PascalUnit -> IO ()
 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]
 toNamespace nss (System tvs) =
 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss)
 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
 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]
 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
 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
 n = map toLower i
 id2C IOLookup (Identifier i t) = do
 let i' = map toLower i
 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
 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
 ns <- gets currentScope
 case tb of
 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
 resolveType st@(SimpleType (Identifier i _)) = do
 let i' = map toLower i
 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
 resolveType (DeriveType _) = return BTUnknown
 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
 where
 f (BTUnresolved s) = do
 if isJust v then
 f . snd . snd . fromJust $ v
 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
 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do
 t <- type2C returnType
 type2C' VoidType = return $ text "void"
 type2C' (String l) = return $ text $ "string" ++ show l
 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
 mapM_ (id2C IOInsert) ids
 return $ text "<<sequence type>>"
 ph <- phrase2C p
 return $
 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'
 e1 <- expr2C e1'
 e2 <- expr2C e2'
 (BTArray _ t') -> modify (\st -> st{lastType = t'})
 (BTString) -> modify (\st -> st{lastType = BTChar})
 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
 r1 <- ref2C ref1
 t <- gets lastType

changeset 6843	59da15acb2f2
parent 6838	b1a0e7a52c04
child 6845	3cbfc35f6c2e