62 |
62 |
63 |
63 |
64 renderCFiles :: Map.Map String PascalUnit -> IO () |
64 renderCFiles :: Map.Map String PascalUnit -> IO () |
65 renderCFiles units = do |
65 renderCFiles units = do |
66 let u = Map.toList units |
66 let u = Map.toList units |
67 let ns = Map.map toNamespace units |
67 let nss = Map.map (toNamespace nss) units |
68 mapM_ (toCFiles ns) u |
68 mapM_ (toCFiles nss) u |
69 where |
69 where |
70 toNamespace :: PascalUnit -> [Record] |
70 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
71 toNamespace = concatMap tv2id . extractTVs |
71 toNamespace nss (System tvs) = |
72 |
72 currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] BTUnknown nss) |
73 extractTVs (System tv) = tv |
73 toNamespace _ (Program {}) = [] |
74 extractTVs (Program {}) = [] |
74 toNamespace nss (Unit _ interface _ _ _) = |
75 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
75 currentScope $ execState (interface2C interface) (RenderState [] BTUnknown nss) |
76 |
76 |
77 tv2id :: TypeVarDeclaration -> [Record] |
|
78 tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i BTUnknown) $ i : ids |
|
79 tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, BTUnknown))] |
|
80 tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i BTUnknown) ids |
|
81 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown] |
|
82 tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown] |
|
83 fi i t = (map toLower i, (i, t)) |
|
84 |
|
85 |
77 |
86 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
78 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
87 toCFiles _ (_, System _) = return () |
79 toCFiles _ (_, System _) = return () |
88 toCFiles ns p@(fn, pu) = do |
80 toCFiles ns p@(fn, pu) = do |
|
81 hPutStrLn stdout $ show $ Map.lookup "pas2cSystem" ns |
89 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
82 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
90 toCFiles' p |
83 toCFiles' p |
91 where |
84 where |
92 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
85 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
93 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
86 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
147 modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
140 modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
148 return $ text i |
141 return $ text i |
149 id2C False (Identifier i t) = do |
142 id2C False (Identifier i t) = do |
150 let i' = map toLower i |
143 let i' = map toLower i |
151 v <- gets $ find (\(a, _) -> a == i') . currentScope |
144 v <- gets $ find (\(a, _) -> a == i') . currentScope |
152 --ns <- gets currentScope |
145 ns <- gets currentScope |
153 modify (\s -> s{lastType = t}) |
146 modify (\s -> s{lastType = t}) |
154 if isNothing v then |
147 if isNothing v then |
155 error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns |
148 error $ "Not defined: '" ++ i' ++ "'\n" ++ show ns |
156 else |
149 else |
157 return . text . fst . snd . fromJust $ v |
150 return . text . fst . snd . fromJust $ v |
158 |
151 |
159 id2CTyped :: BaseType -> Identifier -> State RenderState Doc |
152 id2CTyped :: BaseType -> Identifier -> State RenderState Doc |
160 id2CTyped BTUnknown i = do |
153 id2CTyped BTUnknown i = do |
169 v <- gets $ find (\(a, _) -> a == i') . currentScope |
162 v <- gets $ find (\(a, _) -> a == i') . currentScope |
170 if isJust v then return . snd . snd $ fromJust v else return $ f i' |
163 if isJust v then return . snd . snd $ fromJust v else return $ f i' |
171 where |
164 where |
172 f "integer" = BTInt |
165 f "integer" = BTInt |
173 f "pointer" = BTPointerTo BTVoid |
166 f "pointer" = BTPointerTo BTVoid |
174 f _ = error $ show st |
167 f "boolean" = BTBool |
|
168 f _ = error $ "Unknown system type: " ++ show st |
175 resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t |
169 resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t |
176 resolveType (RecordType tv mtvs) = do |
170 resolveType (RecordType tv mtvs) = do |
177 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
171 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
178 return . BTRecord . concat $ tvs |
172 return . BTRecord . concat $ tvs |
179 where |
173 where |
181 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
175 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
182 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
176 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
183 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
177 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
184 resolveType (FunctionType _ _) = return BTFunction |
178 resolveType (FunctionType _ _) = return BTFunction |
185 resolveType (DeriveType _) = return BTInt |
179 resolveType (DeriveType _) = return BTInt |
|
180 resolveType (String _) = return BTString |
186 --resolveType UnknownType = return BTUnknown |
181 --resolveType UnknownType = return BTUnknown |
187 resolveType a = error $ "resolveType: " ++ show a |
182 resolveType a = error $ "resolveType: " ++ show a |
188 |
183 |
189 |
184 |
190 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
185 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
214 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
209 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
215 |
210 |
216 tvar2C _ td@(TypeDeclaration i' t) = do |
211 tvar2C _ td@(TypeDeclaration i' t) = do |
217 tp <- type2C t |
212 tp <- type2C t |
218 tb <- resolveType t |
213 tb <- resolveType t |
|
214 error $ show (td, tb) |
219 i <- id2CTyped tb i' |
215 i <- id2CTyped tb i' |
220 return $ text "type" <+> i <+> tp <> text ";" |
216 return $ text "type" <+> i <+> tp <> text ";" |
221 |
217 |
222 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
218 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
223 t' <- type2C t |
219 t' <- type2C t |