100 pas2C fn inputPath outputPath alternateInputPath symbols = do |
100 pas2C fn inputPath outputPath alternateInputPath symbols = do |
101 s <- flip execStateT initState $ f fn |
101 s <- flip execStateT initState $ f fn |
102 renderCFiles s outputPath |
102 renderCFiles s outputPath |
103 where |
103 where |
104 printLn = liftIO . hPutStrLn stdout |
104 printLn = liftIO . hPutStrLn stdout |
105 print = liftIO . hPutStr stdout |
105 print' = liftIO . hPutStr stdout |
106 initState = Map.empty |
106 initState = Map.empty |
107 f :: String -> StateT (Map.Map String PascalUnit) IO () |
107 f :: String -> StateT (Map.Map String PascalUnit) IO () |
108 f fileName = do |
108 f fileName = do |
109 processed <- gets $ Map.member fileName |
109 processed <- gets $ Map.member fileName |
110 unless processed $ do |
110 unless processed $ do |
111 print ("Preprocessing '" ++ fileName ++ ".pas'... ") |
111 print' ("Preprocessing '" ++ fileName ++ ".pas'... ") |
112 fc' <- liftIO |
112 fc' <- liftIO |
113 $ tryJust (guard . isDoesNotExistError) |
113 $ tryJust (guard . isDoesNotExistError) |
114 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols |
114 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols |
115 case fc' of |
115 case fc' of |
116 (Left a) -> do |
116 (Left _) -> do |
117 modify (Map.insert fileName (System [])) |
117 modify (Map.insert fileName (System [])) |
118 printLn "doesn't exist" |
118 printLn "doesn't exist" |
119 (Right fc) -> do |
119 (Right fc) -> do |
120 print "ok, parsing... " |
120 print' "ok, parsing... " |
121 let ptree = parse pascalUnit fileName fc |
121 let ptree = parse pascalUnit fileName fc |
122 case ptree of |
122 case ptree of |
123 (Left a) -> do |
123 (Left a) -> do |
124 liftIO $ writeFile (outputPath ++ "preprocess.out") fc |
124 liftIO $ writeFile (outputPath ++ "preprocess.out") fc |
125 printLn $ show a ++ "\nsee preprocess.out for preprocessed source" |
125 printLn $ show a ++ "\nsee preprocess.out for preprocessed source" |
157 |
157 |
158 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
158 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
159 withState' f sf = do |
159 withState' f sf = do |
160 st <- liftM f get |
160 st <- liftM f get |
161 let (a, s) = runState sf st |
161 let (a, s) = runState sf st |
162 modify(\st -> st{ |
162 modify(\st' -> st'{ |
163 lastType = lastType s |
163 lastType = lastType s |
164 , uniqCounter = uniqCounter s |
164 , uniqCounter = uniqCounter s |
165 , stringConsts = stringConsts s |
165 , stringConsts = stringConsts s |
166 }) |
166 }) |
167 return a |
167 return a |
168 |
168 |
|
169 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
169 withLastIdNamespace f = do |
170 withLastIdNamespace f = do |
170 li <- gets lastIdentifier |
171 li <- gets lastIdentifier |
171 nss <- gets namespaces |
|
172 withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f |
172 withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f |
173 |
173 |
174 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc |
174 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc |
175 withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
175 withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
176 withRecordNamespace prefix recs = withState' f |
176 withRecordNamespace prefix recs = withState' f |
177 where |
177 where |
178 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} |
178 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} |
179 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs |
179 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs |
180 un [a] b = a : b |
180 un [a] b = a : b |
|
181 un _ _ = error "withRecordNamespace un: pattern not matched" |
181 |
182 |
182 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO () |
183 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO () |
183 toCFiles _ _ (_, System _) = return () |
184 toCFiles _ _ (_, System _) = return () |
184 toCFiles _ _ (_, Redo _) = return () |
185 toCFiles _ _ (_, Redo _) = return () |
185 toCFiles outputPath ns p@(fn, pu) = do |
186 toCFiles outputPath ns pu@(fileName, _) = do |
186 hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." |
187 hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..." |
187 toCFiles' p |
188 toCFiles' pu |
188 where |
189 where |
189 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
190 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
190 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
191 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
191 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
192 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
192 (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
193 (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
193 enumDecl = (renderEnum2Strs (enums s) False) |
194 enumDecl = (renderEnum2Strs (enums s) False) |
194 enumImpl = (renderEnum2Strs (enums s) True) |
195 enumImpl = (renderEnum2Strs (enums s) True) |
195 writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl |
196 writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl |
196 writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl |
197 writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl |
|
198 toCFiles' _ = undefined -- just pleasing compiler to not warn us |
197 initialState = emptyState ns |
199 initialState = emptyState ns |
198 |
200 |
199 render2C :: RenderState -> State RenderState Doc -> String |
201 render2C :: RenderState -> State RenderState Doc -> String |
200 render2C st p = |
202 render2C st p = |
201 let (a, s) = runState p st in |
203 let (a, _) = runState p st in |
202 render a |
204 render a |
203 |
205 |
204 renderEnum2Strs :: [(String, [String])] -> Bool -> String |
206 renderEnum2Strs :: [(String, [String])] -> Bool -> String |
205 renderEnum2Strs enums implement = |
207 renderEnum2Strs enums' implement = |
206 render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums |
208 render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums' |
207 where |
209 where |
208 decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar") |
210 decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar") |
209 enum2strBlock en = |
211 enum2strBlock en = |
210 text "{" |
212 text "{" |
211 $+$ |
213 $+$ |
212 (nest 4 $ |
214 (nest 4 $ |
213 text "switch(enumvar){" |
215 text "switch(enumvar){" |
228 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 |
230 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 |
229 usesFiles (System {}) = [] |
231 usesFiles (System {}) = [] |
230 usesFiles (Redo {}) = [] |
232 usesFiles (Redo {}) = [] |
231 |
233 |
232 pascal2C :: PascalUnit -> State RenderState Doc |
234 pascal2C :: PascalUnit -> State RenderState Doc |
233 pascal2C (Unit _ interface implementation init fin) = |
235 pascal2C (Unit _ interface implementation _ _) = |
234 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
236 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
235 |
237 |
236 pascal2C (Program _ implementation mainFunction) = do |
238 pascal2C (Program _ implementation mainFunction) = do |
237 impl <- implementation2C implementation |
239 impl <- implementation2C implementation |
238 [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False False (SimpleType $ Identifier "int" (BTInt True)) [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) |
240 [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" (BTInt True)) False False (SimpleType $ Identifier "int" (BTInt True)) [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) |
239 |
241 |
240 return $ impl $+$ main |
242 return $ impl $+$ main |
241 |
243 |
|
244 pascal2C _ = error "pascal2C: pattern not matched" |
242 |
245 |
243 -- the second bool indicates whether do normal interface translation or generate variable declarations |
246 -- the second bool indicates whether do normal interface translation or generate variable declarations |
244 -- that will be inserted into implementation files |
247 -- that will be inserted into implementation files |
245 interface2C :: Interface -> Bool -> State RenderState Doc |
248 interface2C :: Interface -> Bool -> State RenderState Doc |
246 interface2C (Interface uses tvars) True = do |
249 interface2C (Interface uses tvars) True = do |
247 u <- uses2C uses |
250 u <- uses2C uses |
248 tv <- typesAndVars2C True True True tvars |
251 tv <- typesAndVars2C True True True tvars |
249 r <- renderStringConsts |
252 r <- renderStringConsts |
250 return (u $+$ r $+$ tv) |
253 return (u $+$ r $+$ tv) |
251 interface2C (Interface uses tvars) False = do |
254 interface2C (Interface uses tvars) False = do |
252 u <- uses2C uses |
255 void $ uses2C uses |
253 tv <- typesAndVars2C True False False tvars |
256 tv <- typesAndVars2C True False False tvars |
254 r <- renderStringConsts |
257 void $ renderStringConsts |
255 return tv |
258 return tv |
256 |
259 |
257 implementation2C :: Implementation -> State RenderState Doc |
260 implementation2C :: Implementation -> State RenderState Doc |
258 implementation2C (Implementation uses tvars) = do |
261 implementation2C (Implementation uses tvars) = do |
259 u <- uses2C uses |
262 u <- uses2C uses |
295 |
299 |
296 uses2List :: Uses -> [String] |
300 uses2List :: Uses -> [String] |
297 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
301 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
298 |
302 |
299 |
303 |
|
304 setLastIdValues :: Record -> RenderState -> RenderState |
300 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) |
305 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) |
301 |
306 |
302 id2C :: InsertOption -> Identifier -> State RenderState Doc |
307 id2C :: InsertOption -> Identifier -> State RenderState Doc |
303 id2C IOInsert i = id2C (IOInsertWithType empty) i |
308 id2C IOInsert i = id2C (IOInsertWithType empty) i |
304 id2C (IOInsertWithType d) (Identifier i t) = do |
309 id2C (IOInsertWithType d) (Identifier i t) = do |
305 ns <- gets currentScope |
|
306 tom <- gets (Set.member n . toMangle) |
310 tom <- gets (Set.member n . toMangle) |
307 cu <- gets currentUnit |
311 cu <- gets currentUnit |
308 let (i', t') = case (t, tom) of |
312 let (i', t') = case (t, tom) of |
309 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t) |
313 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t) |
310 (BTFunction _ _ _, _) -> (cu ++ i, t) |
314 (BTFunction _ _ _, _) -> (cu ++ i, t) |
311 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
315 (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'') |
312 _ -> (i, t) |
316 _ -> (i, t) |
313 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) |
317 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) |
314 return $ text i' |
318 return $ text i' |
315 where |
319 where |
316 n = map toLower i |
320 n = map toLower i |
317 |
321 |
318 id2C IOLookup i = id2CLookup head i |
322 id2C IOLookup i = id2CLookup head i |
319 id2C IOLookupLast i = id2CLookup last i |
323 id2C IOLookupLast i = id2CLookup last i |
320 id2C (IOLookupFunction params) (Identifier i t) = do |
324 id2C (IOLookupFunction params) (Identifier i _) = do |
321 let i' = map toLower i |
325 let i' = map toLower i |
322 v <- gets $ Map.lookup i' . currentScope |
326 v <- gets $ Map.lookup i' . currentScope |
323 lt <- gets lastType |
327 lt <- gets lastType |
324 if isNothing v then |
328 if isNothing v then |
325 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
329 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
327 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
331 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
328 modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
332 modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
329 where |
333 where |
330 checkParam (Record _ (BTFunction _ p _) _) = (length p) == params |
334 checkParam (Record _ (BTFunction _ p _) _) = (length p) == params |
331 checkParam _ = False |
335 checkParam _ = False |
332 id2C IODeferred (Identifier i t) = do |
336 id2C IODeferred (Identifier i _) = do |
333 let i' = map toLower i |
337 let i' = map toLower i |
334 v <- gets $ Map.lookup i' . currentScope |
338 v <- gets $ Map.lookup i' . currentScope |
335 if (isNothing v) then |
339 if (isNothing v) then |
336 modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) |
340 modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) |
337 else |
341 else |
338 let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
342 let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
339 |
343 |
340 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
344 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
341 id2CLookup f (Identifier i t) = do |
345 id2CLookup f (Identifier i _) = do |
342 let i' = map toLower i |
346 let i' = map toLower i |
343 v <- gets $ Map.lookup i' . currentScope |
347 v <- gets $ Map.lookup i' . currentScope |
344 lt <- gets lastType |
348 lt <- gets lastType |
345 if isNothing v then |
349 if isNothing v then |
346 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
350 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
403 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
407 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
404 return . BTRecord "" . concat $ tvs |
408 return . BTRecord "" . concat $ tvs |
405 where |
409 where |
406 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
410 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
407 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
411 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
|
412 f _ = error "resolveType f: pattern not matched" |
408 resolveType (ArrayDecl (Just i) t) = do |
413 resolveType (ArrayDecl (Just i) t) = do |
409 t' <- resolveType t |
414 t' <- resolveType t |
410 return $ BTArray i (BTInt True) t' |
415 return $ BTArray i (BTInt True) t' |
411 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t |
416 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t |
412 resolveType (FunctionType t a) = do |
417 resolveType (FunctionType t a) = do |
471 abc = hcat . punctuate comma . map (char . fst) $ ps |
477 abc = hcat . punctuate comma . map (char . fst) $ ps |
472 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps |
478 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps |
473 ps = zip ['a'..] (toIsVarList params) |
479 ps = zip ['a'..] (toIsVarList params) |
474 |
480 |
475 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
481 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
476 fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do |
482 fun2C _ _ (FunctionDeclaration name _ overload returnType params Nothing) = do |
477 t <- type2C returnType |
483 t <- type2C returnType |
478 t'<- gets lastType |
484 t'<- gets lastType |
479 bts <- typeVarDecl2BaseType params |
485 bts <- typeVarDecl2BaseType params |
480 p <- withState' id $ functionParams2C params |
486 p <- withState' id $ functionParams2C params |
481 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name |
487 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name |
482 let decor = if overload then text "__attribute__((overloadable))" else empty |
488 let decor = if overload then text "__attribute__((overloadable))" else empty |
483 return [t empty <+> decor <+> text n <> parens p] |
489 return [t empty <+> decor <+> text n <> parens p] |
484 |
490 |
485 fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do |
491 fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload returnType params (Just (tvars, phrase))) = do |
486 let isVoid = case returnType of |
492 let isVoid = case returnType of |
487 VoidType -> True |
493 VoidType -> True |
488 _ -> False |
494 _ -> False |
489 |
495 |
490 let res = docToLower $ text rv <> if isVoid then empty else text "_result" |
496 let res = docToLower $ text rv <> if isVoid then empty else text "_result" |
491 t <- type2C returnType |
497 t <- type2C returnType |
492 t' <- gets lastType |
498 t' <- gets lastType |
493 |
499 |
494 bts <- typeVarDecl2BaseType params |
500 bts <- typeVarDecl2BaseType params |
495 cu <- gets currentUnit |
501 --cu <- gets currentUnit |
496 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
502 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
497 |
503 |
498 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name |
504 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name |
499 let resultId = if isVoid |
505 let resultId = if isVoid |
500 then n -- void type doesn't have result, solving recursive procedure calls |
506 then n -- void type doesn't have result, solving recursive procedure calls |
538 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
545 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
539 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
546 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
540 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do |
547 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do |
541 t <- fun2C b name f |
548 t <- fun2C b name f |
542 if includeType then return t else return [] |
549 if includeType then return t else return [] |
543 tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do |
550 tvar2C _ _ includeType _ (TypeDeclaration i' t) = do |
544 i <- id2CTyped t i' |
551 i <- id2CTyped t i' |
545 tp <- type2C t |
552 tp <- type2C t |
546 let res = if includeType then [text "typedef" <+> tp i] else [] |
553 let res = if includeType then [text "typedef" <+> tp i] else [] |
547 case t of |
554 case t of |
548 (Sequence ids) -> do |
555 (Sequence ids) -> do |
549 modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s}) |
556 modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s}) |
550 return res |
557 return res |
551 _ -> return res |
558 _ -> return res |
552 |
559 |
553 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
560 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
554 t' <- liftM ((empty <+>) . ) $ type2C t |
561 t' <- liftM ((empty <+>) . ) $ type2C t |
565 (True, BTInt _, [i], Just _) -> do |
572 (True, BTInt _, [i], Just _) -> do |
566 i' <- id2CTyped t i |
573 i' <- id2CTyped t i |
567 return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] |
574 return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] |
568 (True, BTFloat, [i], Just e) -> do |
575 (True, BTFloat, [i], Just e) -> do |
569 i' <- id2CTyped t i |
576 i' <- id2CTyped t i |
570 ie <- initExpr2C e |
577 ie' <- initExpr2C e |
571 return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else [] |
578 return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else [] |
572 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids |
579 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids |
573 (_, BTArray r _ _, [i], _) -> do |
580 (_, BTArray r _ _, [i], _) -> do |
574 i' <- id2CTyped t i |
581 i' <- id2CTyped t i |
575 ie' <- return $ case (r, mInitExpr, ignoreInit) of |
582 ie' <- return $ case (r, mInitExpr, ignoreInit) of |
576 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all |
583 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all |
577 (_, _, _) -> ie |
584 (_, _, _) -> ie |
578 result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids |
585 result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids |
579 case (r, ignoreInit) of |
586 case (r, ignoreInit) of |
580 (RangeInfinite, False) -> |
587 (RangeInfinite, False) -> |
581 -- if the array is dynamic, add dimension info to it |
588 -- if the array is dynamic, add dimension info to it |
582 return $ [dimDecl] ++ result |
589 return $ [dimDecl] ++ result |
583 where |
590 where |
592 initExpr Nothing = return $ empty |
599 initExpr Nothing = return $ empty |
593 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
600 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
594 varDeclDecision True True varStr expStr = varStr <+> expStr |
601 varDeclDecision True True varStr expStr = varStr <+> expStr |
595 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
602 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
596 varDeclDecision False False varStr expStr = varStr <+> expStr |
603 varDeclDecision False False varStr expStr = varStr <+> expStr |
597 varDeclDecision True False varStr expStr = empty |
604 varDeclDecision True False _ _ = empty |
598 arrayDimension a = case a of |
605 arrayDimension a = case a of |
599 ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t |
606 ArrayDecl Nothing t' -> let a' = arrayDimension t' in |
|
607 if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' |
600 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." |
608 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." |
601 _ -> 0 |
609 _ -> 0 |
602 |
610 |
603 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do |
611 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do |
604 r <- op2CTyped op (extractTypes params) |
612 r <- op2CTyped op (extractTypes params) |
605 fun2C f i (FunctionDeclaration r inline False ret params body) |
613 fun2C f i (FunctionDeclaration r inline False ret params body) |
606 |
614 |
607 |
615 |
608 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
616 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
609 op2CTyped op t = do |
617 op2CTyped op t = do |
610 t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t |
618 t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t |
611 bt <- gets lastType |
619 bt <- gets lastType |
612 return $ Identifier (t' ++ "_op_" ++ opStr) bt |
620 return $ Identifier (t' ++ "_op_" ++ opStr) bt |
613 where |
621 where |
614 opStr = case op of |
622 opStr = case op of |
615 "+" -> "add" |
623 "+" -> "add" |
643 initExpr2C' (InitBinOp op expr1 expr2) = do |
651 initExpr2C' (InitBinOp op expr1 expr2) = do |
644 e1 <- initExpr2C' expr1 |
652 e1 <- initExpr2C' expr1 |
645 e2 <- initExpr2C' expr2 |
653 e2 <- initExpr2C' expr2 |
646 return $ parens $ e1 <+> text (op2C op) <+> e2 |
654 return $ parens $ e1 <+> text (op2C op) <+> e2 |
647 initExpr2C' (InitNumber s) = do |
655 initExpr2C' (InitNumber s) = do |
648 modify(\s -> s{lastType = (BTInt True)}) |
656 modify(\st -> st{lastType = (BTInt True)}) |
649 return $ text s |
657 return $ text s |
650 initExpr2C' (InitFloat s) = return $ text s |
658 initExpr2C' (InitFloat s) = return $ text s |
651 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
659 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
652 initExpr2C' (InitString [a]) = return . quotes $ text [a] |
660 initExpr2C' (InitString [a]) = return . quotes $ text [a] |
653 initExpr2C' (InitString s) = return $ strInit s |
661 initExpr2C' (InitString s) = return $ strInit s |
670 _ -> error $ "InitRange: " ++ show r |
678 _ -> error $ "InitRange: " ++ show r |
671 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
679 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
672 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
680 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
673 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" |
681 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" |
674 initExpr2C' (InitSet []) = return $ text "0" |
682 initExpr2C' (InitSet []) = return $ text "0" |
675 initExpr2C' (InitSet a) = return $ text "<<set>>" |
683 initExpr2C' (InitSet _) = return $ text "<<set>>" |
676 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ |
684 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ |
677 case e of |
685 case e of |
678 (Identifier "LongInt" _) -> int (-2^31) |
686 (Identifier "LongInt" _) -> int (-2^31) |
679 (Identifier "SmallInt" _) -> int (-2^15) |
687 (Identifier "SmallInt" _) -> int (-2^15) |
680 _ -> error $ "BuiltInFunction 'low': " ++ show e |
688 _ -> error $ "BuiltInFunction 'low': " ++ show e |
681 initExpr2C' (BuiltInFunction "high" [e]) = do |
689 initExpr2C' (BuiltInFunction "high" [e]) = do |
682 initExpr2C e |
690 void $ initExpr2C e |
683 t <- gets lastType |
691 t <- gets lastType |
684 case t of |
692 case t of |
685 (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i] |
693 (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i] |
686 a -> error $ "BuiltInFunction 'high': " ++ show a |
694 a -> error $ "BuiltInFunction 'high': " ++ show a |
687 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e |
695 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e |
719 lt <- gets lastType |
727 lt <- gets lastType |
720 case lt of |
728 case lt of |
721 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
729 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
722 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
730 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
723 _ -> return $ \a -> i' <+> text "*" <+> a |
731 _ -> return $ \a -> i' <+> text "*" <+> a |
724 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
732 type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t |
725 type2C' (RecordType tvs union) = do |
733 type2C' (RecordType tvs union) = do |
726 t <- withState' f $ mapM (tvar2C False False True False) tvs |
734 t' <- withState' f $ mapM (tvar2C False False True False) tvs |
727 u <- unions |
735 u <- unions |
728 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i |
736 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i |
729 where |
737 where |
730 f s = s{currentUnit = ""} |
738 f s = s{currentUnit = ""} |
731 unions = case union of |
739 unions = case union of |
732 Nothing -> return empty |
740 Nothing -> return empty |
733 Just a -> do |
741 Just a -> do |
734 structs <- mapM struct2C a |
742 structs <- mapM struct2C a |
735 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
743 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
736 struct2C tvs = do |
744 struct2C stvs = do |
737 t <- withState' f $ mapM (tvar2C False False True False) tvs |
745 txts <- withState' f $ mapM (tvar2C False False True False) stvs |
738 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi |
746 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi |
739 type2C' (RangeType r) = return (text "int" <+>) |
747 type2C' (RangeType r) = return (text "int" <+>) |
740 type2C' (Sequence ids) = do |
748 type2C' (Sequence ids) = do |
741 is <- mapM (id2C IOInsert . setBaseType bt) ids |
749 is <- mapM (id2C IOInsert . setBaseType bt) ids |
742 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
750 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
743 where |
751 where |
766 type2C' (DeriveType r@(InitReference {})) = do |
774 type2C' (DeriveType r@(InitReference {})) = do |
767 initExpr2C r |
775 initExpr2C r |
768 t <- gets lastType |
776 t <- gets lastType |
769 return (baseType2C (show r) t <+>) |
777 return (baseType2C (show r) t <+>) |
770 type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a |
778 type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a |
|
779 type2C' a = error $ "type2C: unknown type " ++ show a |
771 |
780 |
772 phrase2C :: Phrase -> State RenderState Doc |
781 phrase2C :: Phrase -> State RenderState Doc |
773 phrase2C (Phrases p) = do |
782 phrase2C (Phrases p) = do |
774 ps <- mapM phrase2C p |
783 ps <- mapM phrase2C p |
775 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
784 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
776 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
785 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
777 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True |
786 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True |
778 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do |
787 phrase2C (ProcCall _ _) = error $ "ProcCall"{-do |
779 r <- ref2C ref |
788 r <- ref2C ref |
780 ps <- mapM expr2C params |
789 ps <- mapM expr2C params |
781 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
790 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
782 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
791 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
783 e <- expr2C expr |
792 e <- expr2C expr |