84 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
84 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
85 withLastIdNamespace f = do |
85 withLastIdNamespace f = do |
86 li <- gets lastIdentifier |
86 li <- gets lastIdentifier |
87 nss <- gets namespaces |
87 nss <- gets namespaces |
88 st <- gets id |
88 st <- gets id |
|
89 error $ show $ Map.keys nss |
89 return $ evalState f st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)} |
90 return $ evalState f st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)} |
90 |
91 |
91 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
92 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
92 toCFiles _ (_, System _) = return () |
93 toCFiles _ (_, System _) = return () |
93 toCFiles ns p@(fn, pu) = do |
94 toCFiles ns p@(fn, pu) = do |
176 id2CTyped t (Identifier i _) = do |
177 id2CTyped t (Identifier i _) = do |
177 tb <- resolveType t |
178 tb <- resolveType t |
178 case tb of |
179 case tb of |
179 BTUnknown -> do |
180 BTUnknown -> do |
180 ns <- gets currentScope |
181 ns <- gets currentScope |
181 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show ns |
182 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " -- ++ show ns |
182 _ -> id2C IOInsert (Identifier i tb) |
183 _ -> id2C IOInsert (Identifier i tb) |
183 |
184 |
184 |
185 |
185 resolveType :: TypeDecl -> State RenderState BaseType |
186 resolveType :: TypeDecl -> State RenderState BaseType |
186 resolveType st@(SimpleType (Identifier i _)) = do |
187 resolveType st@(SimpleType (Identifier i _)) = do |
195 f "char" = BTChar |
196 f "char" = BTChar |
196 f "string" = BTString |
197 f "string" = BTString |
197 f _ = error $ "Unknown system type: " ++ show st |
198 f _ = error $ "Unknown system type: " ++ show st |
198 resolveType (PointerTo t) = return $ BTPointerTo BTUnknown -- can't resolveType for t here |
199 resolveType (PointerTo t) = return $ BTPointerTo BTUnknown -- can't resolveType for t here |
199 resolveType (RecordType tv mtvs) = do |
200 resolveType (RecordType tv mtvs) = do |
200 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
201 li <- gets lastIdentifier |
201 return . BTRecord . concat $ tvs |
202 tvs <- liftM concat $ mapM f (concat $ tv : fromMaybe [] mtvs) |
202 where |
203 modify (\s -> s{namespaces = Map.insert li tvs (namespaces s)}) |
203 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
204 return BTRecord |
204 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
205 where |
|
206 f :: TypeVarDeclaration -> State RenderState [Record] |
|
207 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM (\t -> (map toLower i, (i, t))) $ resolveType td) ids |
205 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
208 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
206 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
209 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
207 resolveType (FunctionType _ _) = return BTFunction |
210 resolveType (FunctionType t _) = liftM BTFunction $ resolveType t |
208 resolveType (DeriveType _) = return BTInt |
211 resolveType (DeriveType _) = return BTInt |
209 resolveType (String _) = return BTString |
212 resolveType (String _) = return BTString |
|
213 resolveType VoidType = return BTVoid |
210 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
214 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
211 resolveType (RangeType _) = return $ BTInt |
215 resolveType (RangeType _) = return $ BTInt |
212 resolveType (Set t) = liftM BTSet $ resolveType t |
216 resolveType (Set t) = liftM BTSet $ resolveType t |
213 --resolveType UnknownType = return BTUnknown |
217 --resolveType UnknownType = return BTUnknown |
214 resolveType a = error $ "resolveType: " ++ show a |
218 resolveType a = error $ "resolveType: " ++ show a |
392 r1 <> text "->" <> r2 |
396 r1 <> text "->" <> r2 |
393 ref2C rf@(RecordField ref1 ref2) = do |
397 ref2C rf@(RecordField ref1 ref2) = do |
394 r1 <- ref2C ref1 |
398 r1 <- ref2C ref1 |
395 t <- gets lastType |
399 t <- gets lastType |
396 r2 <- case t of |
400 r2 <- case t of |
397 r@(BTRecord _) -> error $ show r |
401 BTRecord -> withLastIdNamespace $ ref2C ref2 |
398 r@(BTUnit) -> withLastIdNamespace $ ref2C ref2 |
402 BTUnit -> withLastIdNamespace $ ref2C ref2 |
399 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
403 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
400 return $ |
404 return $ |
401 r1 <> text "." <> r2 |
405 r1 <> text "." <> r2 |
402 ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref |
406 ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref |
403 ref2C (FunCall params ref) = do |
407 ref2C (FunCall params ref) = do |
|
408 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
404 r <- ref2C ref |
409 r <- ref2C ref |
405 ps <- mapM expr2C params |
410 t <- gets lastType |
406 return $ |
411 case t of |
407 r <> parens (hsep . punctuate (char ',') $ ps) |
412 BTFunction t -> do |
|
413 modify (\s -> s{lastType = t}) |
|
414 return $ r <> ps |
|
415 _ -> return $ parens r <> ps |
|
416 |
408 ref2C (Address ref) = do |
417 ref2C (Address ref) = do |
409 r <- ref2C ref |
418 r <- ref2C ref |
410 return $ text "&" <> parens r |
419 return $ text "&" <> parens r |
411 ref2C (TypeCast t' expr) = do |
420 ref2C (TypeCast t' expr) = do |
412 t <- id2C IOLookup t' |
421 t <- id2C IOLookup t' |