diff -r 8fadeefdd352 -r a0e152e68337 tools/pas2c.hs --- a/tools/pas2c.hs Mon Mar 26 17:56:15 2012 +0400 +++ b/tools/pas2c.hs Mon Mar 26 23:54:12 2012 +0400 @@ -80,14 +80,23 @@ toNamespace nss (Unit _ interface _ _ _) = currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss) - + +withState' :: (a -> a) -> State a b -> State a b +withState' f s = do + st <- gets id + return $ evalState s (f st) + withLastIdNamespace :: State RenderState Doc -> State RenderState Doc withLastIdNamespace f = do li <- gets lastIdentifier nss <- gets namespaces - st <- gets id - error $ show $ Map.keys nss - return $ evalState f st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)} + withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f + +withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc +withRecordNamespace recs = withState' f + where + f st = st{currentScope = records ++ currentScope st} + records = map (\(a, b) -> (map toLower a, (a, b))) recs toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () toCFiles _ (_, System _) = return () @@ -196,15 +205,14 @@ f "char" = BTChar f "string" = BTString f _ = error $ "Unknown system type: " ++ show st -resolveType (PointerTo t) = return $ BTPointerTo BTUnknown -- can't resolveType for t here +resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) +resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t resolveType (RecordType tv mtvs) = do - li <- gets lastIdentifier - tvs <- liftM concat $ mapM f (concat $ tv : fromMaybe [] mtvs) - modify (\s -> s{namespaces = Map.insert li tvs (namespaces s)}) - return BTRecord + tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) + return . BTRecord . concat $ tvs where - f :: TypeVarDeclaration -> State RenderState [Record] - f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM (\t -> (map toLower i, (i, t))) $ resolveType td) ids + 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 t _) = liftM BTFunction $ resolveType t @@ -227,8 +235,10 @@ tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do t <- type2C returnType - p <- liftM hcat $ mapM (tvar2C False) params - ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) + (p, ph) <- withState' id $ do + p <- liftM hcat $ mapM (tvar2C False) params + ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) + return (p, ph) n <- id2C IOInsert name return $ t <+> n <> parens p @@ -384,8 +394,12 @@ ref2C :: Reference -> State RenderState Doc -ref2C (ArrayElement exprs ref) = do +ref2C ae@(ArrayElement exprs ref) = do r <- ref2C ref + t <- gets lastType + case t of + (BTArray _ t') -> modify (\st -> st{lastType = t'}) + a -> error $ show a ++ "\n" ++ show ae es <- mapM expr2C exprs return $ r <> (brackets . hcat) (punctuate comma es) ref2C (SimpleReference name) = id2C IOLookup name @@ -398,12 +412,18 @@ r1 <- ref2C ref1 t <- gets lastType r2 <- case t of - BTRecord -> withLastIdNamespace $ ref2C ref2 + BTRecord rs -> withRecordNamespace rs $ ref2C ref2 BTUnit -> withLastIdNamespace $ ref2C ref2 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf return $ r1 <> text "." <> r2 -ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref +ref2C (Dereference ref) = do + r <- ref2C ref + t <- gets lastType + case t of + (BTPointerTo t') -> modify (\st -> st{lastType = t'}) + a -> error $ "Dereferencing from non-pointer type " ++ show a + return $ (parens $ text "*") <> r ref2C (FunCall params ref) = do ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params r <- ref2C ref