15 import qualified Data.Map as Map |
15 import qualified Data.Map as Map |
16 import qualified Data.Set as Set |
16 import qualified Data.Set as Set |
17 import Data.List (find) |
17 import Data.List (find) |
18 import Numeric |
18 import Numeric |
19 |
19 |
20 import PascalParser |
20 import PascalParser(pascalUnit) |
21 import PascalUnitSyntaxTree |
21 import PascalUnitSyntaxTree |
22 |
22 |
23 |
23 |
24 data InsertOption = |
24 data InsertOption = |
25 IOInsert |
25 IOInsert |
|
26 | IOInsertWithType Doc |
26 | IOLookup |
27 | IOLookup |
27 | IOLookupLast |
28 | IOLookupLast |
28 | IOLookupFunction Int |
29 | IOLookupFunction Int |
29 | IODeferred |
30 | IODeferred |
30 |
31 |
31 type Record = (String, BaseType) |
32 data Record = Record |
|
33 { |
|
34 lcaseId :: String, |
|
35 baseType :: BaseType, |
|
36 typeDecl :: Doc |
|
37 } |
|
38 deriving Show |
32 type Records = Map.Map String [Record] |
39 type Records = Map.Map String [Record] |
33 data RenderState = RenderState |
40 data RenderState = RenderState |
34 { |
41 { |
35 currentScope :: Records, |
42 currentScope :: Records, |
36 lastIdentifier :: String, |
43 lastIdentifier :: String, |
37 lastType :: BaseType, |
44 lastType :: BaseType, |
|
45 lastIdTypeDecl :: Doc, |
38 stringConsts :: [(String, String)], |
46 stringConsts :: [(String, String)], |
39 uniqCounter :: Int, |
47 uniqCounter :: Int, |
40 toMangle :: Set.Set String, |
48 toMangle :: Set.Set String, |
41 currentUnit :: String, |
49 currentUnit :: String, |
42 currentFunctionResult :: String, |
50 currentFunctionResult :: String, |
43 namespaces :: Map.Map String Records |
51 namespaces :: Map.Map String Records |
44 } |
52 } |
45 |
53 |
46 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" "" |
54 rec2Records = map (\(a, b) -> Record a b empty) |
|
55 |
|
56 emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" "" |
47 |
57 |
48 getUniq :: State RenderState Int |
58 getUniq :: State RenderState Int |
49 getUniq = do |
59 getUniq = do |
50 i <- gets uniqCounter |
60 i <- gets uniqCounter |
51 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
61 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
159 withLastIdNamespace f = do |
169 withLastIdNamespace f = do |
160 li <- gets lastIdentifier |
170 li <- gets lastIdentifier |
161 nss <- gets namespaces |
171 nss <- gets namespaces |
162 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 |
163 |
173 |
164 withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
174 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc |
165 withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
175 withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
166 withRecordNamespace prefix recs = withState' f |
176 withRecordNamespace prefix recs = withState' f |
167 where |
177 where |
168 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} |
178 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} |
169 records = Map.fromList $ map (\(a, b) -> (map toLower a, [(prefix ++ a, b)])) recs |
179 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs |
170 un [a] b = a : b |
180 un [a] b = a : b |
171 |
181 |
172 toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO () |
182 toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO () |
173 toCFiles _ (_, System _) = return () |
183 toCFiles _ (_, System _) = return () |
174 toCFiles _ (_, Redo _) = return () |
184 toCFiles _ (_, Redo _) = return () |
259 |
269 |
260 uses2List :: Uses -> [String] |
270 uses2List :: Uses -> [String] |
261 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
271 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
262 |
272 |
263 |
273 |
|
274 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) |
|
275 |
264 id2C :: InsertOption -> Identifier -> State RenderState Doc |
276 id2C :: InsertOption -> Identifier -> State RenderState Doc |
265 id2C IOInsert (Identifier i t) = do |
277 id2C IOInsert i = id2C (IOInsertWithType empty) i |
|
278 id2C (IOInsertWithType d) (Identifier i t) = do |
266 ns <- gets currentScope |
279 ns <- gets currentScope |
267 tom <- gets (Set.member n . toMangle) |
280 tom <- gets (Set.member n . toMangle) |
268 cu <- gets currentUnit |
281 cu <- gets currentUnit |
269 let (i', t') = case (t, tom) of |
282 let (i', t') = case (t, tom) of |
270 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t) |
283 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t) |
271 (BTFunction _ _ _, _) -> (cu ++ i, t) |
284 (BTFunction _ _ _, _) -> (cu ++ i, t) |
272 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
285 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
273 _ -> (i, t) |
286 _ -> (i, t) |
274 modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t')] (currentScope s), lastIdentifier = n}) |
287 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) |
275 return $ text i' |
288 return $ text i' |
276 where |
289 where |
277 n = map toLower i |
290 n = map toLower i |
278 |
291 |
279 id2C IOLookup i = id2CLookup head i |
292 id2C IOLookup i = id2CLookup head i |
284 lt <- gets lastType |
297 lt <- gets lastType |
285 if isNothing v then |
298 if isNothing v then |
286 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
299 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
287 else |
300 else |
288 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
301 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
289 modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
302 modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
290 where |
303 where |
291 checkParam (_, BTFunction _ p _) = p == params |
304 checkParam (Record _ (BTFunction _ p _) _) = p == params |
292 checkParam _ = False |
305 checkParam _ = False |
293 id2C IODeferred (Identifier i t) = do |
306 id2C IODeferred (Identifier i t) = do |
294 let i' = map toLower i |
307 let i' = map toLower i |
295 v <- gets $ Map.lookup i' . currentScope |
308 v <- gets $ Map.lookup i' . currentScope |
296 if (isNothing v) then |
309 if (isNothing v) then |
297 modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) |
310 modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) |
298 else |
311 else |
299 let vv = head $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
312 let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
300 |
313 |
301 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
314 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
302 id2CLookup f (Identifier i t) = do |
315 id2CLookup f (Identifier i t) = do |
303 let i' = map toLower i |
316 let i' = map toLower i |
304 v <- gets $ Map.lookup i' . currentScope |
317 v <- gets $ Map.lookup i' . currentScope |
305 lt <- gets lastType |
318 lt <- gets lastType |
306 if isNothing v then |
319 if isNothing v then |
307 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
320 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
308 else |
321 else |
309 let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
322 let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
310 |
323 |
311 |
324 |
312 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
325 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
313 id2CTyped t (Identifier i _) = do |
326 id2CTyped = id2CTyped2 Nothing |
|
327 |
|
328 id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc |
|
329 id2CTyped2 md t (Identifier i _) = do |
314 tb <- resolveType t |
330 tb <- resolveType t |
315 case (t, tb) of |
331 case (t, tb) of |
316 (_, BTUnknown) -> do |
332 (_, BTUnknown) -> do |
317 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t |
333 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t |
318 (SimpleType {}, BTRecord _ r) -> do |
334 (SimpleType {}, BTRecord _ r) -> do |
319 ts <- type2C t |
335 ts <- type2C t |
320 id2C IOInsert (Identifier i (BTRecord (render $ ts empty) r)) |
336 id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r)) |
321 (_, BTRecord _ r) -> do |
337 (_, BTRecord _ r) -> do |
322 ts <- type2C t |
338 ts <- type2C t |
323 id2C IOInsert (Identifier i (BTRecord i r)) |
339 id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) |
324 _ -> id2C IOInsert (Identifier i tb) |
340 _ -> case md of |
325 |
341 Nothing -> id2C IOInsert (Identifier i tb) |
|
342 Just ts -> id2C (IOInsertWithType ts) (Identifier i tb) |
326 |
343 |
327 |
344 |
328 resolveType :: TypeDecl -> State RenderState BaseType |
345 resolveType :: TypeDecl -> State RenderState BaseType |
329 resolveType st@(SimpleType (Identifier i _)) = do |
346 resolveType st@(SimpleType (Identifier i _)) = do |
330 let i' = map toLower i |
347 let i' = map toLower i |
331 v <- gets $ Map.lookup i' . currentScope |
348 v <- gets $ Map.lookup i' . currentScope |
332 if isJust v then return . snd . head $ fromJust v else return $ f i' |
349 if isJust v then return . baseType . head $ fromJust v else return $ f i' |
333 where |
350 where |
334 f "integer" = BTInt |
351 f "integer" = BTInt |
335 f "pointer" = BTPointerTo BTVoid |
352 f "pointer" = BTPointerTo BTVoid |
336 f "boolean" = BTBool |
353 f "boolean" = BTBool |
337 f "float" = BTFloat |
354 f "float" = BTFloat |
478 tp <- type2C t |
495 tp <- type2C t |
479 return $ if includeType then [text "typedef" <+> tp i] else [] |
496 return $ if includeType then [text "typedef" <+> tp i] else [] |
480 |
497 |
481 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
498 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
482 t' <- liftM ((empty <+>) . ) $ type2C t |
499 t' <- liftM ((empty <+>) . ) $ type2C t |
483 liftM (map(\i -> t' i)) $ mapM (id2CTyped (VarParamType t)) ids |
500 liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids |
484 |
501 |
485 tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
502 tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
486 t' <- liftM (((if isConst then text "static const" else if externVar |
503 t' <- liftM (((if isConst then text "static const" else if externVar |
487 then text "extern" |
504 then text "extern" |
488 else empty) |
505 else empty) |
513 arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}") |
530 arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}") |
514 dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp |
531 dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp |
515 |
532 |
516 (_, _) -> return result |
533 (_, _) -> return result |
517 |
534 |
518 _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped t) ids |
535 _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids |
519 where |
536 where |
520 initExpr Nothing = return $ empty |
537 initExpr Nothing = return $ empty |
521 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
538 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
522 varDeclDecision True True varStr expStr = varStr <+> expStr |
539 varDeclDecision True True varStr expStr = varStr <+> expStr |
523 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
540 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
778 |
795 |
779 phrase2C wb@(WithBlock ref p) = do |
796 phrase2C wb@(WithBlock ref p) = do |
780 r <- ref2C ref |
797 r <- ref2C ref |
781 t <- gets lastType |
798 t <- gets lastType |
782 case t of |
799 case t of |
783 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
800 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p |
784 a -> do |
801 a -> do |
785 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
802 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
786 phrase2C (ForCycle i' e1' e2' p up) = do |
803 phrase2C (ForCycle i' e1' e2' p up) = do |
787 i <- id2C IOLookup i' |
804 i <- id2C IOLookup i' |
|
805 iType <- gets lastIdTypeDecl |
788 e1 <- expr2C e1' |
806 e1 <- expr2C e1' |
789 e2 <- expr2C e2' |
807 e2 <- expr2C e2' |
790 ph <- phrase2C (wrapPhrase p) |
808 let inc = if up then "inc" else "dec" |
791 cmp <- return $ if up == True then "<=" else ">=" |
809 let add = if up then "+ 1" else "- 1" |
792 inc <- return $ if up == True then "++" else "--" |
810 ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p |
793 return $ |
811 return . braces $ |
794 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> parens e1, i <+> text cmp <+> parens e2, text inc <> i]) |
812 i <+> text "=" <+> e1 <> semi |
795 $$ |
813 $$ |
796 ph |
814 iType <+> i <> text "__end__" <+> text "=" <+> e2 <+> text add <> semi |
|
815 $$ |
|
816 text "do" <+> ph <+> |
|
817 text "while" <> parens (i <+> text "!=" <+> i <> text "__end__") <> semi |
|
818 where |
|
819 appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] |
797 phrase2C (RepeatCycle e' p') = do |
820 phrase2C (RepeatCycle e' p') = do |
798 e <- expr2C e' |
821 e <- expr2C e' |
799 p <- phrase2C (Phrases p') |
822 p <- phrase2C (Phrases p') |
800 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
823 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
801 phrase2C NOP = return $ text ";" |
824 phrase2C NOP = return $ text ";" |
990 ref2C (SimpleReference name) = id2C IOLookup name |
1013 ref2C (SimpleReference name) = id2C IOLookup name |
991 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
1014 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
992 r1 <- ref2C ref1 |
1015 r1 <- ref2C ref1 |
993 t <- fromPointer (show ref1) =<< gets lastType |
1016 t <- fromPointer (show ref1) =<< gets lastType |
994 r2 <- case t of |
1017 r2 <- case t of |
995 BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2 |
1018 BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2 |
996 BTUnit -> error "What??" |
1019 BTUnit -> error "What??" |
997 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
1020 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
998 return $ |
1021 return $ |
999 r1 <> text "->" <> r2 |
1022 r1 <> text "->" <> r2 |
1000 ref2C rf@(RecordField ref1 ref2) = do |
1023 ref2C rf@(RecordField ref1 ref2) = do |
1001 r1 <- ref2C ref1 |
1024 r1 <- ref2C ref1 |
1002 t <- gets lastType |
1025 t <- gets lastType |
1003 case t of |
1026 case t of |
1004 BTRecord _ rs -> do |
1027 BTRecord _ rs -> do |
1005 r2 <- withRecordNamespace "" rs $ ref2C ref2 |
1028 r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2 |
1006 return $ r1 <> text "." <> r2 |
1029 return $ r1 <> text "." <> r2 |
1007 BTUnit -> withLastIdNamespace $ ref2C ref2 |
1030 BTUnit -> withLastIdNamespace $ ref2C ref2 |
1008 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
1031 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
1009 ref2C d@(Dereference ref) = do |
1032 ref2C d@(Dereference ref) = do |
1010 r <- ref2C ref |
1033 r <- ref2C ref |