11 import Control.Monad.IO.Class |
11 import Control.Monad.IO.Class |
12 import PascalPreprocessor |
12 import PascalPreprocessor |
13 import Control.Exception |
13 import Control.Exception |
14 import System.IO.Error |
14 import System.IO.Error |
15 import qualified Data.Map as Map |
15 import qualified Data.Map as Map |
|
16 import qualified Data.Set as Set |
16 import Data.List (find) |
17 import Data.List (find) |
17 import Numeric |
18 import Numeric |
18 |
19 |
19 import PascalParser |
20 import PascalParser |
20 import PascalUnitSyntaxTree |
21 import PascalUnitSyntaxTree |
21 |
22 |
22 |
23 |
23 data InsertOption = |
24 data InsertOption = |
24 IOInsert |
25 IOInsert |
25 | IOLookup |
26 | IOLookup |
|
27 | IOLookupFunction Int |
26 | IODeferred |
28 | IODeferred |
27 |
29 |
28 type Records = Map.Map String [(String, BaseType)] |
30 type Records = Map.Map String [(String, BaseType)] |
29 data RenderState = RenderState |
31 data RenderState = RenderState |
30 { |
32 { |
31 currentScope :: Records, |
33 currentScope :: Records, |
32 lastIdentifier :: String, |
34 lastIdentifier :: String, |
33 lastType :: BaseType, |
35 lastType :: BaseType, |
34 stringConsts :: [(String, String)], |
36 stringConsts :: [(String, String)], |
35 uniqCounter :: Int, |
37 uniqCounter :: Int, |
|
38 toMangle :: Set.Set String, |
36 namespaces :: Map.Map String Records |
39 namespaces :: Map.Map String Records |
37 } |
40 } |
38 |
41 |
39 emptyState = RenderState Map.empty "" BTUnknown [] 0 |
42 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty |
40 |
43 |
41 getUniq :: State RenderState Int |
44 getUniq :: State RenderState Int |
42 getUniq = do |
45 getUniq = do |
43 i <- gets uniqCounter |
46 i <- gets uniqCounter |
44 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
47 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
198 u <- uses2C uses |
201 u <- uses2C uses |
199 tv <- typesAndVars2C True tvars |
202 tv <- typesAndVars2C True tvars |
200 r <- renderStringConsts |
203 r <- renderStringConsts |
201 return (u $+$ r $+$ tv) |
204 return (u $+$ r $+$ tv) |
202 |
205 |
|
206 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () |
|
207 checkDuplicateFunDecls tvs = |
|
208 modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins Map.empty $ tvs} |
|
209 where |
|
210 ins (FunctionDeclaration (Identifier i _) _ _ _) m = Map.insertWith (+) (map toLower i) 1 m |
|
211 ins _ m = m |
203 |
212 |
204 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
213 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
205 typesAndVars2C b (TypesAndVars ts) = liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts |
214 typesAndVars2C b (TypesAndVars ts) = do |
|
215 checkDuplicateFunDecls ts |
|
216 liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts |
206 |
217 |
207 setBaseType :: BaseType -> Identifier -> Identifier |
218 setBaseType :: BaseType -> Identifier -> Identifier |
208 setBaseType bt (Identifier i _) = Identifier i bt |
219 setBaseType bt (Identifier i _) = Identifier i bt |
209 |
220 |
210 uses2C :: Uses -> State RenderState Doc |
221 uses2C :: Uses -> State RenderState Doc |
222 |
233 |
223 |
234 |
224 id2C :: InsertOption -> Identifier -> State RenderState Doc |
235 id2C :: InsertOption -> Identifier -> State RenderState Doc |
225 id2C IOInsert (Identifier i t) = do |
236 id2C IOInsert (Identifier i t) = do |
226 ns <- gets currentScope |
237 ns <- gets currentScope |
227 {-- case t of |
238 tom <- gets (Set.member n . toMangle) |
228 BTUnknown -> do |
239 let i' = case (t, tom) of |
229 ns <- gets currentScope |
240 (BTFunction p _, True) -> i ++ ('_' : show p) |
230 error $ "id2C IOInsert: type BTUnknown for " ++ show i ++ "\nnamespace: " ++ show (take 100 ns) |
241 _ -> i |
231 _ -> do --} |
242 modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t)] (currentScope s), lastIdentifier = n}) |
232 modify (\s -> s{currentScope = Map.insertWith (++) n [(i, t)] (currentScope s), lastIdentifier = n}) |
243 return $ text i' |
233 return $ text i |
|
234 where |
244 where |
235 n = map toLower i |
245 n = map toLower i |
236 id2C IOLookup (Identifier i t) = do |
246 id2C IOLookup (Identifier i t) = do |
237 let i' = map toLower i |
247 let i' = map toLower i |
238 v <- gets $ Map.lookup i' . currentScope |
248 v <- gets $ Map.lookup i' . currentScope |
239 lt <- gets lastType |
249 lt <- gets lastType |
240 if isNothing v then |
250 if isNothing v then |
241 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
251 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
242 else |
252 else |
243 let vv = head $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
253 let vv = head $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
|
254 id2C (IOLookupFunction params) (Identifier i t) = do |
|
255 let i' = map toLower i |
|
256 v <- gets $ Map.lookup i' . currentScope |
|
257 lt <- gets lastType |
|
258 if isNothing v then |
|
259 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
|
260 else |
|
261 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
|
262 modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
|
263 where |
|
264 checkParam (_, BTFunction p _) = p == params |
|
265 checkParam _ = False |
244 id2C IODeferred (Identifier i t) = do |
266 id2C IODeferred (Identifier i t) = do |
245 let i' = map toLower i |
267 let i' = map toLower i |
246 v <- gets $ Map.lookup i' . currentScope |
268 v <- gets $ Map.lookup i' . currentScope |
247 if (isNothing v) then |
269 if (isNothing v) then |
248 return $ text i |
270 return $ text i |
310 error $ "Unknown type " ++ show t ++ "\n" ++ s |
332 error $ "Unknown type " ++ show t ++ "\n" ++ s |
311 resolve _ t = return t |
333 resolve _ t = return t |
312 |
334 |
313 fromPointer :: String -> BaseType -> State RenderState BaseType |
335 fromPointer :: String -> BaseType -> State RenderState BaseType |
314 fromPointer s (BTPointerTo t) = resolve s t |
336 fromPointer s (BTPointerTo t) = resolve s t |
315 fromPointer s (BTFunctionReturn _ (BTPointerTo t)) = resolve s t |
337 --fromPointer s (BTFunctionReturn _ (BTPointerTo t)) = resolve s t |
316 fromPointer s t = do |
338 fromPointer s t = do |
317 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
339 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
318 |
340 |
319 |
341 |
320 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params |
342 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params |
|
343 |
|
344 numberOfDeclarations :: [TypeVarDeclaration] -> Int |
|
345 numberOfDeclarations = sum . map cnt |
|
346 where |
|
347 cnt (VarDeclaration _ (ids, _) _) = length ids |
|
348 cnt _ = 1 |
321 |
349 |
322 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
350 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
323 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
351 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
324 t <- type2C returnType |
352 t <- type2C returnType |
325 t'<- gets lastType |
353 t'<- gets lastType |
326 p <- withState' id $ functionParams2C params |
354 p <- withState' id $ functionParams2C params |
327 n <- id2C IOInsert $ setBaseType (BTFunction (length params) t') name |
355 n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
328 return [t empty <+> n <> parens p] |
356 return [t empty <+> n <> parens p] |
329 |
357 |
330 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
358 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
331 let res = docToLower $ text rv <> text "_result" |
359 let res = docToLower $ text rv <> text "_result" |
332 t <- type2C returnType |
360 t <- type2C returnType |
333 t'<- gets lastType |
361 t'<- gets lastType |
334 n <- id2C IOInsert $ setBaseType (BTFunction (length params) t') name |
362 n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
335 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, BTFunctionReturn (render n) t')] $ currentScope st}) $ do |
363 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st}) $ do |
336 p <- functionParams2C params |
364 p <- functionParams2C params |
337 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
365 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
338 return (p, ph) |
366 return (p, ph) |
339 let phrasesBlock = case returnType of |
367 let phrasesBlock = case returnType of |
340 VoidType -> ph |
368 VoidType -> ph |
684 e <- expr2C expr |
712 e <- expr2C expr |
685 r <- ref2C ref |
713 r <- ref2C ref |
686 t <- gets lastType |
714 t <- gets lastType |
687 case t of |
715 case t of |
688 (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) |
716 (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) |
689 (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'}) |
717 -- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'}) |
690 (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar}) |
718 -- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar}) |
691 (BTString) -> modify (\st -> st{lastType = BTChar}) |
719 (BTString) -> modify (\st -> st{lastType = BTChar}) |
692 (BTPointerTo t) -> do |
720 (BTPointerTo t) -> do |
693 t'' <- fromPointer (show t) =<< gets lastType |
721 t'' <- fromPointer (show t) =<< gets lastType |
694 case t'' of |
722 case t'' of |
695 BTChar -> modify (\st -> st{lastType = BTChar}) |
723 BTChar -> modify (\st -> st{lastType = BTChar}) |
710 r1 <> text "->" <> r2 |
738 r1 <> text "->" <> r2 |
711 ref2C rf@(RecordField ref1 ref2) = do |
739 ref2C rf@(RecordField ref1 ref2) = do |
712 r1 <- ref2C ref1 |
740 r1 <- ref2C ref1 |
713 t <- gets lastType |
741 t <- gets lastType |
714 r2 <- case t of |
742 r2 <- case t of |
715 BTFunctionReturn s (BTRecord rs) -> withRecordNamespace "" rs $ ref2C ref2 |
743 -- BTFunctionReturn s (BTRecord rs) -> withRecordNamespace "" rs $ ref2C ref2 |
716 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
744 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
717 BTUnit -> withLastIdNamespace $ ref2C ref2 |
745 BTUnit -> withLastIdNamespace $ ref2C ref2 |
718 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
746 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
719 return $ |
747 return $ |
720 r1 <> text "." <> r2 |
748 r1 <> text "." <> r2 |
722 r <- ref2C ref |
750 r <- ref2C ref |
723 t <- fromPointer (show d) =<< gets lastType |
751 t <- fromPointer (show d) =<< gets lastType |
724 modify (\st -> st{lastType = t}) |
752 modify (\st -> st{lastType = t}) |
725 return $ (parens $ text "*" <> r) |
753 return $ (parens $ text "*" <> r) |
726 ref2C f@(FunCall params ref) = do |
754 ref2C f@(FunCall params ref) = do |
727 r <- ref2C ref |
755 r <- fref2C ref |
728 t <- gets lastType |
756 t <- gets lastType |
729 case t of |
757 case t of |
730 BTFunction _ t' -> do |
758 BTFunction _ t' -> do |
731 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
759 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
732 modify (\s -> s{lastType = t'}) |
760 modify (\s -> s{lastType = t'}) |
733 return $ r <> ps |
761 return $ r <> ps |
734 BTFunctionReturn r t' -> do |
|
735 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
|
736 modify (\s -> s{lastType = t'}) |
|
737 return $ text r <> ps |
|
738 _ -> case (ref, params) of |
762 _ -> case (ref, params) of |
739 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
763 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
740 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
764 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
|
765 where |
|
766 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
|
767 fref2C a = ref2C a |
741 |
768 |
742 ref2C (Address ref) = do |
769 ref2C (Address ref) = do |
743 r <- ref2C ref |
770 r <- ref2C ref |
744 return $ text "&" <> parens r |
771 return $ text "&" <> parens r |
745 ref2C (TypeCast t'@(Identifier i _) expr) = do |
772 ref2C (TypeCast t'@(Identifier i _) expr) = do |