40 data RenderState = RenderState |
40 data RenderState = RenderState |
41 { |
41 { |
42 currentScope :: Records, |
42 currentScope :: Records, |
43 lastIdentifier :: String, |
43 lastIdentifier :: String, |
44 lastType :: BaseType, |
44 lastType :: BaseType, |
|
45 isFunctionType :: Bool, -- set to true if the current function parameter is functiontype |
45 lastIdTypeDecl :: Doc, |
46 lastIdTypeDecl :: Doc, |
46 stringConsts :: [(String, String)], |
47 stringConsts :: [(String, String)], |
47 uniqCounter :: Int, |
48 uniqCounter :: Int, |
48 toMangle :: Set.Set String, |
49 toMangle :: Set.Set String, |
|
50 enums :: [(String, [String])], -- store all declared enums |
49 currentUnit :: String, |
51 currentUnit :: String, |
50 currentFunctionResult :: String, |
52 currentFunctionResult :: String, |
51 namespaces :: Map.Map String Records |
53 namespaces :: Map.Map String Records |
52 } |
54 } |
53 |
55 |
54 rec2Records = map (\(a, b) -> Record a b empty) |
56 rec2Records = map (\(a, b) -> Record a b empty) |
55 |
57 |
56 emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" "" |
58 emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" "" |
57 |
59 |
58 getUniq :: State RenderState Int |
60 getUniq :: State RenderState Int |
59 getUniq = do |
61 getUniq = do |
60 i <- gets uniqCounter |
62 i <- gets uniqCounter |
61 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
63 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
187 where |
188 where |
188 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
189 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
189 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
190 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
190 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
191 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
191 (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
192 (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
192 writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
193 enumDecl = (renderEnum2Strs (enums s) False) |
193 writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation |
194 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 ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl |
194 initialState = emptyState ns |
197 initialState = emptyState ns |
195 |
198 |
196 render2C :: RenderState -> State RenderState Doc -> String |
199 render2C :: RenderState -> State RenderState Doc -> String |
197 render2C a = render . ($+$ empty) . flip evalState a |
200 render2C st p = |
198 |
201 let (a, s) = runState p st in |
|
202 render a |
|
203 |
|
204 renderEnum2Strs :: [(String, [String])] -> Bool -> String |
|
205 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 |
|
207 where |
|
208 decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar") |
|
209 enum2strBlock en = |
|
210 text "{" |
|
211 $+$ |
|
212 (nest 4 $ |
|
213 text "switch(enumvar){" |
|
214 $+$ |
|
215 (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en) |
|
216 $+$ |
|
217 text "default: assert(0);" |
|
218 $+$ |
|
219 (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");") |
|
220 $+$ |
|
221 text "}" |
|
222 ) |
|
223 $+$ |
|
224 text "}" |
199 |
225 |
200 usesFiles :: PascalUnit -> [String] |
226 usesFiles :: PascalUnit -> [String] |
201 usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses |
227 usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses |
202 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 |
228 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 |
203 usesFiles (System {}) = [] |
229 usesFiles (System {}) = [] |
207 pascal2C (Unit _ interface implementation init fin) = |
233 pascal2C (Unit _ interface implementation init fin) = |
208 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
234 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
209 |
235 |
210 pascal2C (Program _ implementation mainFunction) = do |
236 pascal2C (Program _ implementation mainFunction) = do |
211 impl <- implementation2C implementation |
237 impl <- implementation2C implementation |
212 [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) |
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))) |
|
239 |
213 return $ impl $+$ main |
240 return $ impl $+$ main |
214 |
241 |
215 |
242 |
216 -- the second bool indicates whether do normal interface translation or generate variable declarations |
243 -- the second bool indicates whether do normal interface translation or generate variable declarations |
217 -- that will be inserted into implementation files |
244 -- that will be inserted into implementation files |
277 id2C (IOInsertWithType d) (Identifier i t) = do |
304 id2C (IOInsertWithType d) (Identifier i t) = do |
278 ns <- gets currentScope |
305 ns <- gets currentScope |
279 tom <- gets (Set.member n . toMangle) |
306 tom <- gets (Set.member n . toMangle) |
280 cu <- gets currentUnit |
307 cu <- gets currentUnit |
281 let (i', t') = case (t, tom) of |
308 let (i', t') = case (t, tom) of |
282 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t) |
309 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t) |
283 (BTFunction _ _ _, _) -> (cu ++ i, t) |
310 (BTFunction _ _ _, _) -> (cu ++ i, t) |
284 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
311 (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') |
285 _ -> (i, t) |
312 _ -> (i, t) |
286 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) |
313 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) |
287 return $ text i' |
314 return $ text i' |
338 id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) |
366 id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) |
339 _ -> case md of |
367 _ -> case md of |
340 Nothing -> id2C IOInsert (Identifier i tb) |
368 Nothing -> id2C IOInsert (Identifier i tb) |
341 Just ts -> id2C (IOInsertWithType ts) (Identifier i tb) |
369 Just ts -> id2C (IOInsertWithType ts) (Identifier i tb) |
342 |
370 |
343 |
371 typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)] |
|
372 typeVarDecl2BaseType d = do |
|
373 st <- get |
|
374 result <- sequence $ concat $ map resolveType' d |
|
375 put st -- restore state (not sure if necessary) |
|
376 return result |
|
377 where |
|
378 resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)] |
|
379 resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar) |
|
380 resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration" |
|
381 resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType) |
|
382 resolveTypeHelper' st b = do |
|
383 bt <- st |
|
384 return (b, bt) |
|
385 |
344 resolveType :: TypeDecl -> State RenderState BaseType |
386 resolveType :: TypeDecl -> State RenderState BaseType |
345 resolveType st@(SimpleType (Identifier i _)) = do |
387 resolveType st@(SimpleType (Identifier i _)) = do |
346 let i' = map toLower i |
388 let i' = map toLower i |
347 v <- gets $ Map.lookup i' . currentScope |
389 v <- gets $ Map.lookup i' . currentScope |
348 if isJust v then return . baseType . head $ fromJust v else return $ f i' |
390 if isJust v then return . baseType . head $ fromJust v else return $ f i' |
349 where |
391 where |
350 f "integer" = BTInt |
392 f "uinteger" = BTInt False |
|
393 f "integer" = BTInt True |
351 f "pointer" = BTPointerTo BTVoid |
394 f "pointer" = BTPointerTo BTVoid |
352 f "boolean" = BTBool |
395 f "boolean" = BTBool |
353 f "float" = BTFloat |
396 f "float" = BTFloat |
354 f "char" = BTChar |
397 f "char" = BTChar |
355 f "string" = BTString |
398 f "string" = BTString |
362 where |
405 where |
363 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
406 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
364 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
407 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
365 resolveType (ArrayDecl (Just i) t) = do |
408 resolveType (ArrayDecl (Just i) t) = do |
366 t' <- resolveType t |
409 t' <- resolveType t |
367 return $ BTArray i BTInt t' |
410 return $ BTArray i (BTInt True) t' |
368 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t |
411 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t |
369 resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t |
412 resolveType (FunctionType t a) = do |
370 resolveType (DeriveType (InitHexNumber _)) = return BTInt |
413 bts <- typeVarDecl2BaseType a |
371 resolveType (DeriveType (InitNumber _)) = return BTInt |
414 liftM (BTFunction False bts) $ resolveType t |
|
415 resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) |
|
416 resolveType (DeriveType (InitNumber _)) = return (BTInt True) |
372 resolveType (DeriveType (InitFloat _)) = return BTFloat |
417 resolveType (DeriveType (InitFloat _)) = return BTFloat |
373 resolveType (DeriveType (InitString _)) = return BTString |
418 resolveType (DeriveType (InitString _)) = return BTString |
374 resolveType (DeriveType (InitBinOp {})) = return BTInt |
419 resolveType (DeriveType (InitBinOp {})) = return (BTInt True) |
375 resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType |
420 resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType |
376 resolveType (DeriveType (BuiltInFunction{})) = return BTInt |
421 resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) |
377 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
422 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
378 resolveType (DeriveType _) = return BTUnknown |
423 resolveType (DeriveType _) = return BTUnknown |
379 resolveType (String _) = return BTString |
424 resolveType (String _) = return BTString |
380 resolveType VoidType = return BTVoid |
425 resolveType VoidType = return BTVoid |
381 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
426 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
426 abc = hcat . punctuate comma . map (char . fst) $ ps |
471 abc = hcat . punctuate comma . map (char . fst) $ ps |
427 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps |
472 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps |
428 ps = zip ['a'..] (toIsVarList params) |
473 ps = zip ['a'..] (toIsVarList params) |
429 |
474 |
430 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
475 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
431 fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do |
476 fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do |
432 t <- type2C returnType |
477 t <- type2C returnType |
433 t'<- gets lastType |
478 t'<- gets lastType |
|
479 bts <- typeVarDecl2BaseType params |
434 p <- withState' id $ functionParams2C params |
480 p <- withState' id $ functionParams2C params |
435 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name |
481 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name |
436 let decor = if inline then text "inline" else empty |
482 let decor = if overload then text "__attribute__((overloadable))" else empty |
437 if hasVars then |
483 return [t empty <+> decor <+> text n <> parens p] |
438 return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p] |
484 |
439 else |
485 fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do |
440 return [decor <+> t empty <+> text n <> parens p] |
|
441 where |
|
442 hasVars = hasPassByReference params |
|
443 |
|
444 |
|
445 fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do |
|
446 let res = docToLower $ text rv <> text "_result" |
|
447 t <- type2C returnType |
|
448 t'<- gets lastType |
|
449 |
|
450 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
|
451 |
|
452 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name |
|
453 |
|
454 let isVoid = case returnType of |
486 let isVoid = case returnType of |
455 VoidType -> True |
487 VoidType -> True |
456 _ -> False |
488 _ -> False |
457 |
489 |
458 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st |
490 let res = docToLower $ text rv <> if isVoid then empty else text "_result" |
|
491 t <- type2C returnType |
|
492 t' <- gets lastType |
|
493 |
|
494 bts <- typeVarDecl2BaseType params |
|
495 cu <- gets currentUnit |
|
496 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
|
497 |
|
498 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name |
|
499 let resultId = if isVoid |
|
500 then n -- void type doesn't have result, solving recursive procedure calls |
|
501 else (render res) |
|
502 |
|
503 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars bts t') else t') empty] $ currentScope st |
459 , currentFunctionResult = if isVoid then [] else render res}) $ do |
504 , currentFunctionResult = if isVoid then [] else render res}) $ do |
460 p <- functionParams2C params |
505 p <- functionParams2C params |
461 ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) |
506 ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) |
462 return (p, ph) |
507 return (p, ph) |
463 |
508 |
464 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
509 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
465 let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty |
510 let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty |
466 let decor = if inline then text "inline" else empty |
511 let inlineDecor = if inline then case notDeclared of |
|
512 True -> text "static inline" |
|
513 False -> text "inline" |
|
514 else empty |
|
515 overloadDecor = if overload then text "__attribute__((overloadable))" else empty |
467 return [ |
516 return [ |
468 define |
517 --define |
469 $+$ |
518 -- $+$ |
470 --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ |
519 --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ |
471 decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p |
520 inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p |
472 $+$ |
521 $+$ |
473 text "{" |
522 text "{" |
474 $+$ |
523 $+$ |
475 nest 4 phrasesBlock |
524 nest 4 phrasesBlock |
476 $+$ |
525 $+$ |
479 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
528 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
480 phrase2C' p = phrase2C p |
529 phrase2C' p = phrase2C p |
481 un [a] b = a : b |
530 un [a] b = a : b |
482 hasVars = hasPassByReference params |
531 hasVars = hasPassByReference params |
483 |
532 |
484 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name |
533 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name |
485 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
534 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
486 |
535 |
487 -- the second bool indicates whether declare variable as extern or not |
536 -- the second bool indicates whether declare variable as extern or not |
488 -- the third bool indicates whether include types or not |
537 -- the third bool indicates whether include types or not |
489 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
538 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
490 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
539 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
491 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do |
540 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do |
492 t <- fun2C b name f |
541 t <- fun2C b name f |
493 if includeType then return t else return [] |
542 if includeType then return t else return [] |
494 tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do |
543 tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do |
495 i <- id2CTyped t i' |
544 i <- id2CTyped t i' |
496 tp <- type2C t |
545 tp <- type2C t |
497 return $ if includeType then [text "typedef" <+> tp i] else [] |
546 let res = if includeType then [text "typedef" <+> tp i] else [] |
|
547 case t of |
|
548 (Sequence ids) -> do |
|
549 modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s}) |
|
550 return res |
|
551 _ -> return res |
498 |
552 |
499 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
553 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
500 t' <- liftM ((empty <+>) . ) $ type2C t |
554 t' <- liftM ((empty <+>) . ) $ type2C t |
501 liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids |
555 liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids |
502 |
556 |
581 initExpr2C' InitNull = return $ text "NULL" |
635 initExpr2C' InitNull = return $ text "NULL" |
582 initExpr2C' (InitAddress expr) = do |
636 initExpr2C' (InitAddress expr) = do |
583 ie <- initExpr2C' expr |
637 ie <- initExpr2C' expr |
584 lt <- gets lastType |
638 lt <- gets lastType |
585 case lt of |
639 case lt of |
586 BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars" |
640 BTFunction True _ _ -> return $ text "&" <> ie -- <> text "__vars" |
587 _ -> return $ text "&" <> ie |
641 _ -> return $ text "&" <> ie |
588 initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) |
642 initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) |
589 initExpr2C' (InitBinOp op expr1 expr2) = do |
643 initExpr2C' (InitBinOp op expr1 expr2) = do |
590 e1 <- initExpr2C' expr1 |
644 e1 <- initExpr2C' expr1 |
591 e2 <- initExpr2C' expr2 |
645 e2 <- initExpr2C' expr2 |
592 return $ parens $ e1 <+> text (op2C op) <+> e2 |
646 return $ parens $ e1 <+> text (op2C op) <+> e2 |
593 initExpr2C' (InitNumber s) = return $ text s |
647 initExpr2C' (InitNumber s) = do |
|
648 modify(\s -> s{lastType = (BTInt True)}) |
|
649 return $ text s |
594 initExpr2C' (InitFloat s) = return $ text s |
650 initExpr2C' (InitFloat s) = return $ text s |
595 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
651 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
596 initExpr2C' (InitString [a]) = return . quotes $ text [a] |
652 initExpr2C' (InitString [a]) = return . quotes $ text [a] |
597 initExpr2C' (InitString s) = return $ strInit s |
653 initExpr2C' (InitString s) = return $ strInit s |
598 initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
654 initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
714 phrase2C :: Phrase -> State RenderState Doc |
770 phrase2C :: Phrase -> State RenderState Doc |
715 phrase2C (Phrases p) = do |
771 phrase2C (Phrases p) = do |
716 ps <- mapM phrase2C p |
772 ps <- mapM phrase2C p |
717 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
773 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
718 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
774 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
719 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref |
775 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True |
720 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do |
776 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do |
721 r <- ref2C ref |
777 r <- ref2C ref |
722 ps <- mapM expr2C params |
778 ps <- mapM expr2C params |
723 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
779 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
724 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
780 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
813 return . braces $ |
869 return . braces $ |
814 i <+> text "=" <+> e1 <> semi |
870 i <+> text "=" <+> e1 <> semi |
815 $$ |
871 $$ |
816 iType <+> iEnd <+> text "=" <+> e2 <> semi |
872 iType <+> iEnd <+> text "=" <+> e2 <> semi |
817 $$ |
873 $$ |
818 text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+> |
874 text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> |
819 text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi |
875 text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi |
820 where |
876 where |
821 appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] |
877 appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] |
822 phrase2C (RepeatCycle e' p') = do |
878 phrase2C (RepeatCycle e' p') = do |
823 e <- expr2C e' |
879 e <- expr2C e' |
824 p <- phrase2C (Phrases p') |
880 p <- phrase2C (Phrases p') |
825 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
881 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
|
882 |
826 phrase2C NOP = return $ text ";" |
883 phrase2C NOP = return $ text ";" |
827 |
884 |
828 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do |
885 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do |
829 f <- gets currentFunctionResult |
886 f <- gets currentFunctionResult |
830 if null f then |
887 if null f then |
849 e1 <- expr2C expr1 |
906 e1 <- expr2C expr1 |
850 t1 <- gets lastType |
907 t1 <- gets lastType |
851 e2 <- expr2C expr2 |
908 e2 <- expr2C expr2 |
852 t2 <- gets lastType |
909 t2 <- gets lastType |
853 case (op2C op, t1, t2) of |
910 case (op2C op, t1, t2) of |
854 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString)) |
911 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False [(False, t1), (False, t2)] BTString)) |
855 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString)) |
912 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False [(False, t1), (False, t2)] BTString)) |
856 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString)) |
913 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False [(False, t1), (False, t2)] BTString)) |
857 ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString)) |
914 ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False [(False, t1), (False, t2)] BTString)) |
858 ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool)) |
915 ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False [(False, t1), (False, t2)] BTBool)) |
859 ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool)) |
916 |
860 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool)) |
917 -- for function/procedure comparision |
|
918 ("==", BTVoid, _) -> procCompare expr1 expr2 "==" |
|
919 ("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "==" |
|
920 |
|
921 ("!=", BTVoid, _) -> procCompare expr1 expr2 "!=" |
|
922 ("!=", BTFunction _ _ _, _) -> procCompare expr1 expr2 "!=" |
|
923 |
|
924 ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False [(False, t1), (False, t2)] BTBool)) |
|
925 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False [(False, t1), (False, t2)] BTBool)) |
861 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
926 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
862 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
927 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
863 (_, BTRecord t1 _, BTRecord t2 _) -> do |
928 (_, BTRecord t1 _, BTRecord t2 _) -> do |
864 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] |
929 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] |
865 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
930 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
866 (_, BTRecord t1 _, BTInt) -> do |
931 (_, BTRecord t1 _, BTInt _) -> do |
867 -- aw, "LongInt" here is hwengine-specific hack |
932 -- aw, "LongInt" here is hwengine-specific hack |
868 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] |
933 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] |
869 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
934 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
870 ("in", _, _) -> |
935 ("in", _, _) -> |
871 case expr2 of |
936 case expr2 of |
880 | otherwise -> do |
945 | otherwise -> do |
881 o' <- return $ case o of |
946 o' <- return $ case o of |
882 "/(float)" -> text "/(float)" -- pascal returns real value |
947 "/(float)" -> text "/(float)" -- pascal returns real value |
883 _ -> text o |
948 _ -> text o |
884 e1' <- return $ case (o, t1, t2) of |
949 e1' <- return $ case (o, t1, t2) of |
885 ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1 |
950 ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1 |
886 _ -> parens e1 |
951 _ -> parens e1 |
887 e2' <- return $ case (o, t1, t2) of |
952 e2' <- return $ case (o, t1, t2) of |
888 ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2 |
953 ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2 |
889 _ -> parens e2 |
954 _ -> parens e2 |
890 return $ e1' <+> o' <+> e2' |
955 return $ e1' <+> o' <+> e2' |
891 where |
956 where |
892 boolOps = ["==", "!=", "<", ">", "<=", ">="] |
957 boolOps = ["==", "!=", "<", ">", "<=", ">="] |
|
958 procCompare expr1 expr2 op = |
|
959 case (expr1, expr2) of |
|
960 (Reference r1, Reference r2) -> do |
|
961 id1 <- ref2C r1 |
|
962 id2 <- ref2C r2 |
|
963 return $ (parens id1) <+> text op <+> (parens id2) |
|
964 (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2 |
|
965 |
893 expr2C (NumberLiteral s) = do |
966 expr2C (NumberLiteral s) = do |
894 modify(\s -> s{lastType = BTInt}) |
967 modify(\s -> s{lastType = BTInt True}) |
895 return $ text s |
968 return $ text s |
896 expr2C (FloatLiteral s) = return $ text s |
969 expr2C (FloatLiteral s) = return $ text s |
897 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
970 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
898 {-expr2C (StringLiteral [a]) = do |
971 {-expr2C (StringLiteral [a]) = do |
899 modify(\s -> s{lastType = BTChar}) |
972 modify(\s -> s{lastType = BTChar}) |
927 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do |
1003 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do |
928 e' <- liftM (map toLower . render) $ expr2C e |
1004 e' <- liftM (map toLower . render) $ expr2C e |
929 lt <- gets lastType |
1005 lt <- gets lastType |
930 case lt of |
1006 case lt of |
931 BTEnum a -> return $ int 0 |
1007 BTEnum a -> return $ int 0 |
932 BTInt -> case e' of |
1008 BTInt _ -> case e' of |
933 "longint" -> return $ int (-2147483648) |
1009 "longint" -> return $ int (-2147483648) |
934 BTArray {} -> return $ int 0 |
1010 BTArray {} -> return $ int 0 |
935 _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt |
1011 _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt |
936 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do |
1012 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do |
937 e' <- liftM (map toLower . render) $ expr2C e |
1013 e' <- liftM (map toLower . render) $ expr2C e |
938 lt <- gets lastType |
1014 lt <- gets lastType |
939 case lt of |
1015 case lt of |
940 BTEnum a -> return . int $ length a - 1 |
1016 BTEnum a -> return . int $ length a - 1 |
941 BTInt -> case e' of |
1017 BTInt _ -> case e' of |
942 "longint" -> return $ int (2147483647) |
1018 "longint" -> return $ int (2147483647) |
943 BTString -> return $ int 255 |
1019 BTString -> return $ int 255 |
944 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n |
1020 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n |
945 _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt |
1021 _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt |
946 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
1022 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
947 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
1023 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
948 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e |
1024 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do |
|
1025 e'<- expr2C e |
|
1026 return $ text "(int)" <> parens e' <> text " - 1" |
949 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do |
1027 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do |
950 e' <- expr2C e |
1028 e' <- expr2C e |
951 lt <- gets lastType |
1029 lt <- gets lastType |
952 modify (\s -> s{lastType = BTInt}) |
1030 modify (\s -> s{lastType = BTInt True}) |
953 case lt of |
1031 case lt of |
954 BTString -> return $ text "fpcrtl_Length" <> parens e' |
1032 BTString -> return $ text "fpcrtl_Length" <> parens e' |
955 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' |
1033 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' |
956 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n]) |
1034 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n]) |
957 _ -> error $ "length() called on " ++ show lt |
1035 _ -> error $ "length() called on " ++ show lt |
965 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
1043 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
966 return $ |
1044 return $ |
967 r <> parens (hsep . punctuate (char ',') $ ps) |
1045 r <> parens (hsep . punctuate (char ',') $ ps) |
968 expr2C a = error $ "Don't know how to render " ++ show a |
1046 expr2C a = error $ "Don't know how to render " ++ show a |
969 |
1047 |
970 ref2CF :: Reference -> State RenderState Doc |
1048 ref2CF :: Reference -> Bool -> State RenderState Doc |
971 ref2CF (SimpleReference name) = do |
1049 ref2CF (SimpleReference name) addParens = do |
972 i <- id2C IOLookup name |
1050 i <- id2C IOLookup name |
973 t <- gets lastType |
1051 t <- gets lastType |
974 case t of |
1052 case t of |
975 BTFunction _ _ rt -> do |
1053 BTFunction _ _ rt -> do |
976 modify(\s -> s{lastType = rt}) |
1054 modify(\s -> s{lastType = rt}) |
977 return $ i <> parens empty --xymeng: removed parens |
1055 return $ if addParens then i <> parens empty else i --xymeng: removed parens |
978 _ -> return $ i |
1056 _ -> return $ i |
979 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do |
1057 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do |
980 i <- ref2C r |
1058 i <- ref2C r |
981 t <- gets lastType |
1059 t <- gets lastType |
982 case t of |
1060 case t of |
983 BTFunction _ _ rt -> do |
1061 BTFunction _ _ rt -> do |
984 modify(\s -> s{lastType = rt}) |
1062 modify(\s -> s{lastType = rt}) |
985 return $ i <> parens empty |
1063 return $ if addParens then i <> parens empty else i |
986 _ -> return $ i |
1064 _ -> return $ i |
987 ref2CF r = ref2C r |
1065 ref2CF r _ = ref2C r |
988 |
1066 |
989 ref2C :: Reference -> State RenderState Doc |
1067 ref2C :: Reference -> State RenderState Doc |
990 -- rewrite into proper form |
1068 -- rewrite into proper form |
991 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
1069 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
992 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
1070 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
1038 return $ (parens $ text "*" <> r) |
1116 return $ (parens $ text "*" <> r) |
1039 ref2C f@(FunCall params ref) = do |
1117 ref2C f@(FunCall params ref) = do |
1040 r <- fref2C ref |
1118 r <- fref2C ref |
1041 t <- gets lastType |
1119 t <- gets lastType |
1042 case t of |
1120 case t of |
1043 BTFunction _ _ t' -> do |
1121 BTFunction _ bts t' -> do |
1044 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
1122 ps <- liftM (parens . hsep . punctuate (char ',')) $ |
|
1123 if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params |
|
1124 then |
|
1125 mapM expr2CHelper (zip params bts) |
|
1126 else mapM expr2C params |
1045 modify (\s -> s{lastType = t'}) |
1127 modify (\s -> s{lastType = t'}) |
1046 return $ r <> ps |
1128 return $ r <> ps |
1047 _ -> case (ref, params) of |
1129 _ -> case (ref, params) of |
1048 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
1130 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
1049 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
1131 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t |
1050 where |
1132 where |
1051 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
1133 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
1052 fref2C a = ref2C a |
1134 fref2C a = ref2C a |
|
1135 expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc |
|
1136 expr2CHelper (e, (_, BTFunction _ _ _)) = do |
|
1137 modify (\s -> s{isFunctionType = True}) |
|
1138 expr2C e |
|
1139 expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e |
1053 |
1140 |
1054 ref2C (Address ref) = do |
1141 ref2C (Address ref) = do |
1055 r <- ref2C ref |
1142 r <- ref2C ref |
1056 lt <- gets lastType |
1143 lt <- gets lastType |
1057 case lt of |
1144 case lt of |
1058 BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars") |
1145 BTFunction True _ _ -> return $ text "&" <> parens r |
1059 _ -> return $ text "&" <> parens r |
1146 _ -> return $ text "&" <> parens r |
1060 ref2C (TypeCast t'@(Identifier i _) expr) = do |
1147 ref2C (TypeCast t'@(Identifier i _) expr) = do |
1061 lt <- expr2C expr >> gets lastType |
1148 lt <- expr2C expr >> gets lastType |
1062 case (map toLower i, lt) of |
1149 case (map toLower i, lt) of |
1063 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
1150 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |