1{-# LANGUAGE ScopedTypeVariables #-} 2module Pas2C where 3 4import Prelude hiding ((<>)) 5import Text.PrettyPrint.HughesPJ 6import Data.Maybe 7import Data.Char 8import Text.Parsec.Prim hiding (State) 9import Control.Monad.State 10import System.IO 11import PascalPreprocessor 12import Control.Exception 13import System.IO.Error 14import qualified Data.Map as Map 15import qualified Data.Set as Set 16import Data.List (find) 17import Numeric 18 19import PascalParser 20import PascalUnitSyntaxTree 21 22 23data InsertOption = 24 IOInsert 25 | IOInsertWithType Doc 26 | IOLookup 27 | IOLookupLast 28 | IOLookupFunction Int 29 | IODeferred 30 31data Record = Record 32 { 33 lcaseId :: String, 34 baseType :: BaseType, 35 typeDecl :: Doc 36 } 37 deriving Show 38type Records = Map.Map String [Record] 39data RenderState = RenderState 40 { 41 currentScope :: Records, 42 lastIdentifier :: String, 43 lastType :: BaseType, 44 isFunctionType :: Bool, -- set to true if the current function parameter is functiontype 45 lastIdTypeDecl :: Doc, 46 stringConsts :: [(String, String)], 47 uniqCounter :: Int, 48 toMangle :: Set.Set String, 49 enums :: [(String, [String])], -- store all declared enums 50 currentUnit :: String, 51 currentFunctionResult :: String, 52 namespaces :: Map.Map String Records 53 } 54 55rec2Records :: [(String, BaseType)] -> [Record] 56rec2Records = map (\(a, b) -> Record a b empty) 57 58emptyState :: Map.Map String Records -> RenderState 59emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" "" 60 61getUniq :: State RenderState Int 62getUniq = do 63 i <- gets uniqCounter 64 modify(\s -> s{uniqCounter = uniqCounter s + 1}) 65 return i 66 67addStringConst :: String -> State RenderState Doc 68addStringConst str = do 69 strs <- gets stringConsts 70 let a = find ((==) str . snd) strs 71 if isJust a then 72 do 73 modify (\s -> s{lastType = BTString}) 74 return . text . fst . fromJust $ a 75 else 76 do 77 i <- getUniq 78 let sn = "__str" ++ show i 79 modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs}) 80 return $ text sn 81 82escapeStr :: String -> String 83escapeStr = foldr escapeChar [] 84 85escapeChar :: Char -> ShowS 86escapeChar '"' s = "\\\"" ++ s 87escapeChar '\\' s = "\\\\" ++ s 88escapeChar a s = a : s 89 90strInit :: String -> Doc 91strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a)) 92 93renderStringConsts :: State RenderState Doc 94renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi)) 95 $ gets stringConsts 96 97docToLower :: Doc -> Doc 98docToLower = text . map toLower . render 99 100pas2C :: String -> String -> String -> String -> [String] -> IO () 101pas2C fn inputPath outputPath alternateInputPath symbols = do 102 s <- flip execStateT initState $ f fn 103 renderCFiles s outputPath 104 where 105 printLn = liftIO . hPutStrLn stdout 106 print' = liftIO . hPutStr stdout 107 initState = Map.empty 108 f :: String -> StateT (Map.Map String PascalUnit) IO () 109 f fileName = do 110 processed <- gets $ Map.member fileName 111 unless processed $ do 112 print' ("Preprocessing '" ++ fileName ++ ".pas'... ") 113 fc' <- liftIO 114 $ tryJust (guard . isDoesNotExistError) 115 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols 116 case fc' of 117 (Left _) -> do 118 modify (Map.insert fileName (System [])) 119 printLn "doesn't exist" 120 (Right fc) -> do 121 print' "ok, parsing... " 122 let ptree = parse pascalUnit fileName fc 123 case ptree of 124 (Left a) -> do 125 liftIO $ writeFile (outputPath ++ fileName ++ "preprocess.out") fc 126 printLn $ show a ++ "\nsee preprocess.out for preprocessed source" 127 fail "stop" 128 (Right a) -> do 129 printLn "ok" 130 modify (Map.insert fileName a) 131 mapM_ f (usesFiles a) 132 133 134renderCFiles :: Map.Map String PascalUnit -> String -> IO () 135renderCFiles units outputPath = do 136 let u = Map.toList units 137 let nss = Map.map (toNamespace nss) units 138 --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) 139 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss 140 mapM_ (toCFiles outputPath nss) u 141 where 142 toNamespace :: Map.Map String Records -> PascalUnit -> Records 143 toNamespace nss (System tvs) = 144 currentScope $ execState f (emptyState nss) 145 where 146 f = do 147 checkDuplicateFunDecls tvs 148 mapM_ (tvar2C True False True False) tvs 149 toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them 150 currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"} 151 where 152 f = do 153 checkDuplicateFunDecls tvs 154 mapM_ (tvar2C True False True False) tvs 155 toNamespace _ (Program {}) = Map.empty 156 toNamespace nss (Unit (Identifier i _) interface _ _ _) = 157 currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"} 158 159withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a 160withState' f sf = do 161 st <- liftM f get 162 let (a, s) = runState sf st 163 modify(\st' -> st'{ 164 lastType = lastType s 165 , uniqCounter = uniqCounter s 166 , stringConsts = stringConsts s 167 }) 168 return a 169 170withLastIdNamespace :: State RenderState Doc -> State RenderState Doc 171withLastIdNamespace f = do 172 li <- gets lastIdentifier 173 withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f 174 175withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc 176withRecordNamespace _ [] = error "withRecordNamespace: empty record" 177withRecordNamespace prefix recs = withState' f 178 where 179 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} 180 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs 181 un [a] b = a : b 182 un _ _ = error "withRecordNamespace un: pattern not matched" 183 184toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO () 185toCFiles _ _ (_, System _) = return () 186toCFiles _ _ (_, Redo _) = return () 187toCFiles outputPath ns pu@(fileName, _) = do 188 hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..." 189 --let (fn, p) = pu in writeFile (outputPath ++ fn ++ ".dump") $ show p 190 toCFiles' pu 191 where 192 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p 193 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do 194 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} 195 (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} 196 enumDecl = (renderEnum2Strs (enums s) False) 197 enumImpl = (renderEnum2Strs (enums s) True) 198 writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl 199 writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl 200 toCFiles' _ = undefined -- just pleasing compiler to not warn us 201 initialState = emptyState ns 202 203 render2C :: RenderState -> State RenderState Doc -> String 204 render2C st p = 205 let (a, _) = runState p st in 206 render a 207 208renderEnum2Strs :: [(String, [String])] -> Bool -> String 209renderEnum2Strs enums' implement = 210 render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums' 211 where 212 decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar") 213 enum2strBlock en = 214 text "{" 215 $+$ 216 (nest 4 $ 217 text "switch(enumvar){" 218 $+$ 219 (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en) 220 $+$ 221 text "default: assert(0);" 222 $+$ 223 (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");") 224 $+$ 225 text "}" 226 ) 227 $+$ 228 text "}" 229 230usesFiles :: PascalUnit -> [String] 231usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses 232usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 233usesFiles (System {}) = [] 234usesFiles (Redo {}) = [] 235 236pascal2C :: PascalUnit -> State RenderState Doc 237pascal2C (Unit _ interface implementation _ _) = 238 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) 239 240pascal2C (Program _ implementation mainFunction) = do 241 impl <- implementation2C implementation 242 main <- liftM head $ tvar2C True False True True 243 (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) 244 [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing 245 , VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] 246 (Just (TypesAndVars [], Phrases [mainResultInit, mainFunction]))) 247 248 return $ impl $+$ main 249 250pascal2C _ = error "pascal2C: pattern not matched" 251 252-- the second bool indicates whether do normal interface translation or generate variable declarations 253-- that will be inserted into implementation files 254interface2C :: Interface -> Bool -> State RenderState Doc 255interface2C (Interface uses tvars) True = do 256 u <- uses2C uses 257 tv <- typesAndVars2C True True True tvars 258 r <- renderStringConsts 259 return (u $+$ r $+$ tv) 260interface2C (Interface uses tvars) False = do 261 void $ uses2C uses 262 tv <- typesAndVars2C True False False tvars 263 void $ renderStringConsts 264 return tv 265 266implementation2C :: Implementation -> State RenderState Doc 267implementation2C (Implementation uses tvars) = do 268 u <- uses2C uses 269 tv <- typesAndVars2C True False True tvars 270 r <- renderStringConsts 271 return (u $+$ r $+$ tv) 272 273checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () 274checkDuplicateFunDecls tvs = 275 modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs} 276 where 277 initMap :: Map.Map String Int 278 initMap = Map.empty 279 --initMap = Map.fromList [("reset", 2)] 280 ins (FunctionDeclaration (Identifier i _) _ _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m 281 ins _ m = m 282 283-- the second bool indicates whether declare variable as extern or not 284-- the third bool indicates whether include types or not 285 286typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc 287typesAndVars2C b externVar includeType(TypesAndVars ts) = do 288 checkDuplicateFunDecls ts 289 liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts 290 291setBaseType :: BaseType -> Identifier -> Identifier 292setBaseType bt (Identifier i _) = Identifier i bt 293 294uses2C :: Uses -> State RenderState Doc 295uses2C uses@(Uses unitIds) = do 296 297 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) 298 mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds) 299 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds 300 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses 301 where 302 injectNamespace :: Identifier -> State RenderState () 303 injectNamespace (Identifier i _) = do 304 getNS <- gets (flip Map.lookup . namespaces) 305 modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s}) 306 307uses2List :: Uses -> [String] 308uses2List (Uses ids) = map (\(Identifier i _) -> i) ids 309 310 311setLastIdValues :: Record -> RenderState -> RenderState 312setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) 313 314id2C :: InsertOption -> Identifier -> State RenderState Doc 315id2C IOInsert i = id2C (IOInsertWithType empty) i 316id2C (IOInsertWithType d) (Identifier i t) = do 317 tom <- gets (Set.member n . toMangle) 318 cu <- gets currentUnit 319 let (i', t') = case (t, tom) of 320 (BTFunction _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t) 321 (BTFunction _ e _ _, _) -> ((if e then id else (++) cu) i, t) 322 (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'') 323 _ -> (i, t) 324 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) 325 return $ text i' 326 where 327 n = map toLower i 328 329id2C IOLookup i = id2CLookup head i 330id2C IOLookupLast i = id2CLookup last i 331id2C (IOLookupFunction params) (Identifier i _) = do 332 let i' = map toLower i 333 v <- gets $ Map.lookup i' . currentScope 334 lt <- gets lastType 335 if isNothing v then 336 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v 337 else 338 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in 339 modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 340 where 341 checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params 342 checkParam _ = False 343id2C IODeferred (Identifier i _) = do 344 let i' = map toLower i 345 v <- gets $ Map.lookup i' . currentScope 346 if (isNothing v) then 347 modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) 348 else 349 let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 350 351id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc 352id2CLookup f (Identifier i _) = do 353 let i' = map toLower i 354 v <- gets $ Map.lookup i' . currentScope 355 lt <- gets lastType 356 if isNothing v then 357 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt 358 else 359 let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 360 361 362 363id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc 364id2CTyped = id2CTyped2 Nothing 365 366id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc 367id2CTyped2 md t (Identifier i _) = do 368 tb <- resolveType t 369 case (t, tb) of 370 (_, BTUnknown) -> do 371 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t 372 (SimpleType {}, BTRecord _ r) -> do 373 ts <- type2C t 374 id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r)) 375 (_, BTRecord _ r) -> do 376 ts <- type2C t 377 id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) 378 _ -> case md of 379 Nothing -> id2C IOInsert (Identifier i tb) 380 Just ts -> id2C (IOInsertWithType ts) (Identifier i tb) 381 382typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)] 383typeVarDecl2BaseType d = do 384 st <- get 385 result <- sequence $ concat $ map resolveType' d 386 put st -- restore state (not sure if necessary) 387 return result 388 where 389 resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)] 390 resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar) 391 resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration" 392 resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType) 393 resolveTypeHelper' st b = do 394 bt <- st 395 return (b, bt) 396 397resolveType :: TypeDecl -> State RenderState BaseType 398resolveType st@(SimpleType (Identifier i _)) = do 399 let i' = map toLower i 400 v <- gets $ Map.lookup i' . currentScope 401 if isJust v then return . baseType . head $ fromJust v else return $ f i' 402 where 403 f "uinteger" = BTInt False 404 f "integer" = BTInt True 405 f "pointer" = BTPointerTo BTVoid 406 f "boolean" = BTBool 407 f "float" = BTFloat 408 f "char" = BTChar 409 f "string" = BTString 410 f "ansistring" = BTAString 411 f _ = error $ "Unknown system type: " ++ show st 412resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) 413resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t 414resolveType (RecordType tv mtvs) = do 415 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) 416 return . BTRecord "" . concat $ tvs 417 where 418 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] 419 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids 420 f _ = error "resolveType f: pattern not matched" 421resolveType (ArrayDecl (Just i) t) = do 422 t' <- resolveType t 423 return $ BTArray i (BTInt True) t' 424resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t 425resolveType (FunctionType t a) = do 426 bts <- typeVarDecl2BaseType a 427 liftM (BTFunction False False bts) $ resolveType t 428resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) 429resolveType (DeriveType (InitNumber _)) = return (BTInt True) 430resolveType (DeriveType (InitFloat _)) = return BTFloat 431resolveType (DeriveType (InitString _)) = return BTString 432resolveType (DeriveType (InitBinOp {})) = return (BTInt True) 433resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType 434resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) 435resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type 436resolveType (DeriveType _) = return BTUnknown 437resolveType String = return BTString 438resolveType AString = return BTAString 439resolveType VoidType = return BTVoid 440resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids 441resolveType (RangeType _) = return $ BTVoid 442resolveType (Set t) = liftM BTSet $ resolveType t 443resolveType (VarParamType t) = liftM BTVarParam $ resolveType t 444 445 446resolve :: String -> BaseType -> State RenderState BaseType 447resolve s (BTUnresolved t) = do 448 v <- gets $ Map.lookup t . currentScope 449 if isJust v then 450 resolve s . baseType . head . fromJust $ v 451 else 452 error $ "Unknown type " ++ show t ++ "\n" ++ s 453resolve _ t = return t 454 455fromPointer :: String -> BaseType -> State RenderState BaseType 456fromPointer s (BTPointerTo t) = resolve s t 457fromPointer s t = do 458 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s 459 460 461functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc 462functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params 463 464numberOfDeclarations :: [TypeVarDeclaration] -> Int 465numberOfDeclarations = sum . map cnt 466 where 467 cnt (VarDeclaration _ _ (ids, _) _) = length ids 468 cnt _ = 1 469 470hasPassByReference :: [TypeVarDeclaration] -> Bool 471hasPassByReference = or . map isVar 472 where 473 isVar (VarDeclaration v _ (_, _) _) = v 474 isVar _ = error $ "hasPassByReference called not on function parameters" 475 476toIsVarList :: [TypeVarDeclaration] -> [Bool] 477toIsVarList = concatMap isVar 478 where 479 isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v 480 isVar _ = error $ "toIsVarList called not on function parameters" 481 482 483funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc 484funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams 485 where 486 abc = hcat . punctuate comma . map (char . fst) $ ps 487 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps 488 ps = zip ['a'..] (toIsVarList params) 489 490fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] 491fun2C _ _ (FunctionDeclaration name _ overload external returnType params Nothing) = do 492 t <- type2C returnType 493 t'<- gets lastType 494 bts <- typeVarDecl2BaseType params 495 p <- withState' id $ functionParams2C params 496 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name 497 let decor = if overload then text "__attribute__((overloadable))" else empty 498 return [t empty <+> decor <+> text n <> parens p] 499 500fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do 501 let isVoid = case returnType of 502 VoidType -> True 503 _ -> False 504 505 let res = docToLower $ text rv <> if isVoid then empty else text "_result" 506 t <- type2C returnType 507 t' <- gets lastType 508 509 bts <- typeVarDecl2BaseType params 510 --cu <- gets currentUnit 511 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope 512 513 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name 514 let resultId = if isVoid 515 then n -- void type doesn't have result, solving recursive procedure calls 516 else (render res) 517 518 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else t') empty] $ currentScope st 519 , currentFunctionResult = if isVoid then [] else render res}) $ do 520 p <- functionParams2C params 521 ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) 522 return (p, ph) 523 524 let isTrivialReturn = case phrase of 525 (Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True 526 _ -> False 527 let phrasesBlock = if isVoid || isTrivialReturn then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi 528 --let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty 529 let inlineDecor = if inline then case notDeclared of 530 True -> text "static inline" 531 False -> text "inline" 532 else empty 533 overloadDecor = if overload then text "__attribute__((overloadable))" else empty 534 return [ 535 --define 536 -- $+$ 537 --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ 538 inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p 539 $+$ 540 text "{" 541 $+$ 542 nest 4 phrasesBlock 543 $+$ 544 text "}"] 545 where 546 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p 547 phrase2C' p = phrase2C p 548 un [a] b = a : b 549 un _ _ = error "fun2C u: pattern not matched" 550 hasVars = hasPassByReference params 551 552fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = error $ "nested functions not allowed: " ++ name 553fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv 554 555-- the second bool indicates whether declare variable as extern or not 556-- the third bool indicates whether include types or not 557-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) 558tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] 559tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = do 560 t <- fun2C b name f 561 if includeType then return t else return [] 562tvar2C _ _ includeType _ (TypeDeclaration i' t) = do 563 i <- id2CTyped t i' 564 tp <- type2C t 565 let res = if includeType then [text "typedef" <+> tp i] else [] 566 case t of 567 (Sequence ids) -> do 568 modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s}) 569 return res 570 _ -> return res 571 572tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do 573 t' <- liftM ((empty <+>) . ) $ type2C t 574 liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids 575 576tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do 577 t' <- liftM (((if isConst then text "static const" else if externVar 578 then text "extern" 579 else empty) 580 <+>) . ) $ type2C t 581 ie <- initExpr mInitExpr 582 lt <- gets lastType 583 case (isConst, lt, ids, mInitExpr) of 584 (True, BTInt _, [i], Just _) -> do 585 i' <- id2CTyped t i 586 return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] 587 (True, BTFloat, [i], Just e) -> do 588 i' <- id2CTyped t i 589 ie' <- initExpr2C e 590 return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else [] 591 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids 592 (_, BTArray r _ _, [i], _) -> do 593 i' <- id2CTyped t i 594 ie' <- return $ case (r, mInitExpr, ignoreInit) of 595 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all 596 (_, _, _) -> ie 597 result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids 598 case (r, ignoreInit) of 599 (RangeInfinite, False) -> 600 -- if the array is dynamic, add dimension info to it 601 return $ [dimDecl] ++ result 602 where 603 arrayDimStr = show $ arrayDimension t 604 arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}") 605 dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp 606 607 (_, _) -> return result 608 609 _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids 610 where 611 initExpr Nothing = return $ empty 612 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) 613 varDeclDecision True True varStr expStr = varStr <+> expStr 614 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr 615 varDeclDecision False False varStr expStr = varStr <+> expStr 616 varDeclDecision True False _ _ = empty 617 arrayDimension a = case a of 618 ArrayDecl Nothing t' -> let a' = arrayDimension t' in 619 if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' 620 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." 621 _ -> 0 622 623tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do 624 r <- op2CTyped op (extractTypes params) 625 fun2C f i (FunctionDeclaration r inline False False ret params body) 626 627 628op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier 629op2CTyped op t = do 630 t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t 631 bt <- gets lastType 632 return $ Identifier (t' ++ "_op_" ++ opStr) bt 633 where 634 opStr = case op of 635 "+" -> "add" 636 "-" -> "sub" 637 "*" -> "mul" 638 "/" -> "div" 639 "/(float)" -> "div" 640 "=" -> "eq" 641 "<" -> "lt" 642 ">" -> "gt" 643 "<>" -> "neq" 644 _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" 645 646extractTypes :: [TypeVarDeclaration] -> [TypeDecl] 647extractTypes = concatMap f 648 where 649 f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t 650 f a = error $ "extractTypes: can't extract from " ++ show a 651 652initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc 653initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values 654initExpr2C a = initExpr2C' a 655initExpr2C' InitNull = return $ text "NULL" 656initExpr2C' (InitAddress expr) = do 657 ie <- initExpr2C' expr 658 lt <- gets lastType 659 case lt of 660 BTFunction True _ _ _ -> return $ text "&" <> ie -- <> text "__vars" 661 _ -> return $ text "&" <> ie 662initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) 663initExpr2C' (InitBinOp op expr1 expr2) = do 664 e1 <- initExpr2C' expr1 665 e2 <- initExpr2C' expr2 666 return $ parens $ e1 <+> text (op2C op) <+> e2 667initExpr2C' (InitNumber s) = do 668 modify(\st -> st{lastType = (BTInt True)}) 669 return $ text s 670initExpr2C' (InitFloat s) = return $ text s 671initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) 672initExpr2C' (InitString [a]) = return . quotes $ text [a] 673initExpr2C' (InitString s) = return $ strInit s 674initExpr2C' (InitPChar s) = return $ doubleQuotes (text $ escapeStr s) 675initExpr2C' (InitChar a) = return $ text "0x" <> text (showHex (read a) "") 676initExpr2C' (InitReference i) = id2C IOLookup i 677initExpr2C' (InitRecord fields) = do 678 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields 679 return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace 680--initExpr2C' (InitArray [InitRecord fields]) = do 681-- e <- initExpr2C $ InitRecord fields 682-- return $ braces $ e 683initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do 684 void $ id2C IOLookup i 685 t <- gets lastType 686 case t of 687 BTEnum s -> return . int $ length s 688 BTInt _ -> case i' of 689 "byte" -> return $ int 256 690 _ -> error $ "InitRange identifier: " ++ i' 691 _ -> error $ "InitRange: " ++ show r 692initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] 693initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] 694initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" 695initExpr2C' (InitSet []) = return $ text "0" 696initExpr2C' (InitSet _) = return $ text "<<set>>" 697initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ 698 case e of 699 (Identifier "LongInt" _) -> int (-2^31) 700 (Identifier "SmallInt" _) -> int (-2^15) 701 _ -> error $ "BuiltInFunction 'low': " ++ show e 702initExpr2C' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do 703 void $ initExpr2C e 704 t <- gets lastType 705 case t of 706 (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i] 707 BTInt _ -> case e' of 708 (Identifier "LongInt" _) -> return $ int (2147483647) 709 (Identifier "LongWord" _) -> return $ text "4294967295" 710 _ -> error $ "BuiltInFunction 'high' in initExpr: " ++ show e' 711 a -> error $ "BuiltInFunction 'high' in initExpr: " ++ show a ++ ": " ++ show hi 712initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e 713initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e 714initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e 715initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e 716initExpr2C' b@(BuiltInFunction _ _) = error $ show b 717initExpr2C' (InitTypeCast t' i) = do 718 e <- initExpr2C i 719 t <- id2C IOLookup t' 720 return . parens $ parens t <> e 721initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a 722 723 724range2C :: InitExpression -> State RenderState [Doc] 725range2C (InitString [a]) = return [quotes $ text [a]] 726range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i 727range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b] 728range2C a = liftM (flip (:) []) $ initExpr2C a 729 730baseType2C :: String -> BaseType -> Doc 731baseType2C _ BTFloat = text "float" 732baseType2C _ BTBool = text "bool" 733baseType2C _ BTString = text "string255" 734baseType2C _ BTAString = text "astring" 735baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s 736 737type2C :: TypeDecl -> State RenderState (Doc -> Doc) 738type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i 739type2C t = do 740 r <- type2C' t 741 rt <- resolveType t 742 modify (\st -> st{lastType = rt}) 743 return r 744 where 745 type2C' VoidType = return (text "void" <+>) 746 type2C' String = return (text "string255" <+>)--return (text ("string" ++ show l) <+>) 747 type2C' AString = return (text "astring" <+>) 748 type2C' (PointerTo (SimpleType i)) = do 749 i' <- id2C IODeferred i 750 lt <- gets lastType 751 case lt of 752 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a 753 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a 754 _ -> return $ \a -> i' <+> text "*" <+> a 755 type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t 756 type2C' (RecordType tvs union) = do 757 t' <- withState' f $ mapM (tvar2C False False True False) tvs 758 u <- unions 759 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i 760 where 761 f s = s{currentUnit = ""} 762 unions = case union of 763 Nothing -> return empty 764 Just a -> do 765 structs <- mapM struct2C a 766 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi 767 struct2C stvs = do 768 txts <- withState' f $ mapM (tvar2C False False True False) stvs 769 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi 770 type2C' (RangeType r) = return (text "int" <+>) 771 type2C' (Sequence ids) = do 772 is <- mapM (id2C IOInsert . setBaseType bt) ids 773 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) 774 where 775 bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids 776 type2C' (ArrayDecl Nothing t) = type2C (PointerTo t) 777 type2C' (ArrayDecl (Just r1) (ArrayDecl (Just r2) t)) = do 778 t' <- type2C t 779 lt <- gets lastType 780 r1' <- initExpr2C (InitRange r1) 781 r2' <- initExpr2C (InitRange r2) 782 return $ \i -> t' i <> brackets r1' <> brackets r2' 783 type2C' (ArrayDecl (Just r) t) = do 784 t' <- type2C t 785 lt <- gets lastType 786 ft <- case lt of 787 -- BTFunction {} -> type2C (PointerTo t) 788 _ -> return t' 789 r' <- initExpr2C (InitRange r) 790 return $ \i -> ft i <> brackets r' 791 type2C' (Set t) = return (text "<<set>>" <+>) 792 type2C' (FunctionType returnType params) = do 793 t <- type2C returnType 794 p <- withState' id $ functionParams2C params 795 return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p)) 796 type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i) 797 type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) 798 type2C' (DeriveType (InitNumber _)) = return (text "int" <+>) 799 type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>) 800 type2C' (DeriveType (InitFloat _)) = return (text "float" <+>) 801 type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>) 802 type2C' (DeriveType (InitString {})) = return (text "string255" <+>) 803 type2C' (DeriveType r@(InitReference {})) = do 804 initExpr2C r 805 t <- gets lastType 806 return (baseType2C (show r) t <+>) 807 type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a 808 type2C' a = error $ "type2C: unknown type " ++ show a 809 810phrase2C :: Phrase -> State RenderState Doc 811phrase2C (Phrases p) = do 812 ps <- mapM phrase2C p 813 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" 814phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f 815phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True 816phrase2C (ProcCall _ _) = error $ "ProcCall"{-do 817 r <- ref2C ref 818 ps <- mapM expr2C params 819 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} 820phrase2C (IfThenElse (expr) phrase1 mphrase2) = do 821 e <- expr2C expr 822 p1 <- (phrase2C . wrapPhrase) phrase1 823 el <- elsePart 824 return $ 825 text "if" <> parens e $+$ p1 $+$ el 826 where 827 elsePart | isNothing mphrase2 = return $ empty 828 | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) 829phrase2C asgn@(Assignment ref expr) = do 830 r <- ref2C ref 831 t <- gets lastType 832 case (t, expr) of 833 (_, Reference r') | ref == r' -> do 834 e <- ref2C r' 835 return $ text "UNUSED" <+> parens e <> semi 836 (BTFunction {}, (Reference r')) -> do 837 e <- ref2C r' 838 return $ r <+> text "=" <+> e <> semi 839 (BTString, _) -> do 840 void $ expr2C expr 841 lt <- gets lastType 842 case lt of 843 -- assume pointer to char for simplicity 844 BTPointerTo _ -> do 845 e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown)) 846 return $ r <+> text "=" <+> e <> semi 847 BTAString -> do 848 e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown)) 849 return $ r <+> text "=" <+> e <> semi 850 BTString -> do 851 e <- expr2C expr 852 return $ r <+> text "=" <+> e <> semi 853 _ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn 854 (BTAString, _) -> do 855 void $ expr2C expr 856 lt <- gets lastType 857 case lt of 858 -- assume pointer to char for simplicity 859 BTPointerTo _ -> do 860 e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown)) 861 return $ r <+> text "=" <+> e <> semi 862 BTString -> do 863 e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown)) 864 return $ r <+> text "=" <+> e <> semi 865 BTAString -> do 866 e <- expr2C expr 867 return $ r <+> text "=" <+> e <> semi 868 _ -> error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn 869 (BTArray _ _ _, _) -> do 870 case expr of 871 Reference er -> do 872 void $ ref2C er 873 exprT <- gets lastType 874 case exprT of 875 BTArray RangeInfinite _ _ -> 876 return $ text "FIXME: assign a dynamic array to an array" 877 BTArray _ _ _ -> phrase2C $ 878 ProcCall (FunCall 879 [ 880 Reference $ ref 881 , Reference $ RefExpression expr 882 , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown)) 883 ] 884 (SimpleReference (Identifier "memcpy" BTUnknown)) 885 ) [] 886 _ -> return $ text "FIXME: assign a non-specific value to an array" 887 888 _ -> return $ text "FIXME: dynamic array assignment 2" 889 _ -> do 890 e <- expr2C expr 891 return $ r <+> text "=" <+> e <> semi 892phrase2C (WhileCycle expr phrase) = do 893 e <- expr2C expr 894 p <- phrase2C $ wrapPhrase phrase 895 return $ text "while" <> parens e $$ p 896phrase2C (SwitchCase expr cases mphrase) = do 897 e <- expr2C expr 898 cs <- mapM case2C cases 899 d <- dflt 900 return $ 901 text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) 902 where 903 case2C :: ([InitExpression], Phrase) -> State RenderState Doc 904 case2C (e, p) = do 905 ies <- mapM range2C e 906 ph <- phrase2C p 907 return $ 908 vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") 909 dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning 910 | otherwise = do 911 ph <- mapM phrase2C $ fromJust mphrase 912 return [text "default:" <+> nest 4 (vcat ph)] 913 914phrase2C wb@(WithBlock ref p) = do 915 r <- ref2C ref 916 t <- gets lastType 917 case t of 918 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p 919 a -> do 920 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb 921phrase2C (ForCycle i' e1' e2' p up) = do 922 i <- id2C IOLookup i' 923 iType <- gets lastIdTypeDecl 924 e1 <- expr2C e1' 925 e2 <- expr2C e2' 926 let iEnd = i <> text "__end__" 927 ph <- phrase2C $ wrapPhrase p 928 return . braces $ 929 i <+> text "=" <+> e1 <> semi 930 $$ 931 iType <+> iEnd <+> text "=" <+> e2 <> semi 932 $$ 933 text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> 934 text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi 935 where 936 appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] 937 appendPhrase _ _ = error "illegal appendPhrase call" 938phrase2C (RepeatCycle e' p') = do 939 e <- expr2C e' 940 p <- phrase2C (Phrases p') 941 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi 942 943phrase2C NOP = return $ text ";" 944 945phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do 946 f <- gets currentFunctionResult 947 if null f then 948 return $ text "return" <> semi 949 else 950 return $ text "return" <+> text f <> semi 951phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi 952phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi 953phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e 954phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e 955phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2) 956phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e 957phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2) 958phrase2C a = error $ "phrase2C: " ++ show a 959 960wrapPhrase p@(Phrases _) = p 961wrapPhrase p = Phrases [p] 962 963expr2C :: Expression -> State RenderState Doc 964expr2C (Expression s) = return $ text s 965expr2C bop@(BinOp op expr1 expr2) = do 966 e1 <- expr2C expr1 967 t1 <- gets lastType 968 e2 <- expr2C expr2 969 t2 <- gets lastType 970 case (op2C op, t1, t2) of 971 ("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString)) 972 ("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2 BTAString)) 973 ("+", BTChar, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprependA" (fff t1 t2 BTAString)) 974 ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2 BTBool)) 975 (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop 976 (_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop 977 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2 BTString)) 978 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2 BTString)) 979 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2 BTString)) 980 ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2 BTString)) 981 ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2 BTBool)) 982 983 -- for function/procedure comparision 984 ("==", BTVoid, _) -> procCompare expr1 expr2 "==" 985 ("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "==" 986 987 ("!=", BTVoid, _) -> procCompare expr1 expr2 "!=" 988 ("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!=" 989 990 ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2 BTBool)) 991 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2 BTBool)) 992 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 993 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 994 (_, BTRecord t1 _, BTRecord t2 _) -> do 995 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] 996 ref2C $ FunCall [expr1, expr2] (SimpleReference i) 997 (_, BTRecord t1 _, BTInt _) -> do 998 -- aw, "LongInt" here is hwengine-specific hack 999 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] 1000 ref2C $ FunCall [expr1, expr2] (SimpleReference i) 1001 ("in", _, _) -> 1002 case expr2 of 1003 SetExpression set -> do 1004 ids <- mapM (id2C IOLookup) set 1005 modify(\s -> s{lastType = BTBool}) 1006 return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids 1007 _ -> error "'in' against not set expression" 1008 (o, _, _) | o `elem` boolOps -> do 1009 modify(\s -> s{lastType = BTBool}) 1010 return $ parens e1 <+> text o <+> parens e2 1011 | otherwise -> do 1012 o' <- return $ case o of 1013 "/(float)" -> text "/(float)" -- pascal returns real value 1014 _ -> text o 1015 e1' <- return $ case (o, t1, t2) of 1016 ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1 1017 _ -> parens e1 1018 e2' <- return $ case (o, t1, t2) of 1019 ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2 1020 _ -> parens e2 1021 return $ e1' <+> o' <+> e2' 1022 where 1023 fff t1 t2 = BTFunction False False [(False, t1), (False, t2)] 1024 boolOps = ["==", "!=", "<", ">", "<=", ">="] 1025 procCompare expr1 expr2 op = 1026 case (expr1, expr2) of 1027 (Reference r1, Reference r2) -> do 1028 id1 <- ref2C r1 1029 id2 <- ref2C r2 1030 return $ (parens id1) <+> text op <+> (parens id2) 1031 (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2 1032 1033expr2C (NumberLiteral s) = do 1034 modify(\s -> s{lastType = BTInt True}) 1035 return $ text s 1036expr2C (FloatLiteral s) = return $ text s 1037expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) 1038{-expr2C (StringLiteral [a]) = do 1039 modify(\s -> s{lastType = BTChar}) 1040 return . quotes . text $ escape a 1041 where 1042 escape '\'' = "\\\'" 1043 escape a = [a]-} 1044expr2C (StringLiteral s) = addStringConst s 1045expr2C (PCharLiteral s) = return . doubleQuotes $ text s 1046expr2C (Reference ref) = do 1047 isfunc <- gets isFunctionType 1048 modify(\s -> s{isFunctionType = False}) -- reset 1049 if isfunc then ref2CF ref False else ref2CF ref True 1050expr2C (PrefixOp op expr) = do 1051 e <- expr2C expr 1052 lt <- gets lastType 1053 case lt of 1054 BTRecord t _ -> do 1055 i <- op2CTyped op [SimpleType (Identifier t undefined)] 1056 ref2C $ FunCall [expr] (SimpleReference i) 1057 BTBool -> do 1058 o <- return $ case op of 1059 "not" -> text "!" 1060 _ -> text (op2C op) 1061 return $ o <> parens e 1062 _ -> return $ text (op2C op) <> parens e 1063expr2C Null = return $ text "NULL" 1064expr2C (CharCode a) = do 1065 modify(\s -> s{lastType = BTChar}) 1066 return $ text "0x" <> text (showHex (read a) "") 1067expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a 1068expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") 1069 1070expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do 1071 e' <- liftM (map toLower . render) $ expr2C e 1072 lt <- gets lastType 1073 case lt of 1074 BTEnum _-> return $ int 0 1075 BTInt _ -> case e' of 1076 "longint" -> return $ int (-2147483648) 1077 BTArray {} -> return $ int 0 1078 _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt 1079expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do 1080 e' <- liftM (map toLower . render) $ expr2C e 1081 lt <- gets lastType 1082 case lt of 1083 BTEnum a -> return . int $ length a - 1 1084 BTInt _ -> case e' of 1085 "longint" -> return $ int (2147483647) 1086 BTString -> return $ int 255 1087 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n 1088 _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt 1089expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e 1090expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e 1091expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do 1092 e'<- expr2C e 1093 return $ text "(int)" <> parens e' <> text " - 1" 1094expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do 1095 e' <- expr2C e 1096 lt <- gets lastType 1097 modify (\s -> s{lastType = BTInt True}) 1098 case lt of 1099 BTString -> return $ text "fpcrtl_Length" <> parens e' 1100 BTAString -> return $ text "fpcrtl_LengthA" <> parens e' 1101 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' 1102 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n]) 1103 _ -> error $ "length() called on " ++ show lt 1104expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do 1105 e1' <- expr2C e1 1106 e2' <- expr2C e2 1107 e' <- expr2C e 1108 lt <- gets lastType 1109 let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2']) 1110 case lt of 1111 BTString -> f "fpcrtl_copy" 1112 BTAString -> f "fpcrtl_copyA" 1113 _ -> error $ "copy() called on " ++ show lt 1114 1115expr2C (BuiltInFunCall params ref) = do 1116 r <- ref2C ref 1117 t <- gets lastType 1118 ps <- mapM expr2C params 1119 case t of 1120 BTFunction _ _ _ t' -> do 1121 modify (\s -> s{lastType = t'}) 1122 _ -> error $ "BuiltInFunCall `" ++ show ref ++ "`, lastType: " ++ show t 1123 return $ 1124 r <> parens (hsep . punctuate (char ',') $ ps) 1125expr2C a = error $ "Don't know how to render " ++ show a 1126 1127ref2CF :: Reference -> Bool -> State RenderState Doc 1128ref2CF (SimpleReference name) addParens = do 1129 i <- id2C IOLookup name 1130 t <- gets lastType 1131 case t of 1132 BTFunction _ _ _ rt -> do 1133 modify(\s -> s{lastType = rt}) 1134 return $ if addParens then i <> parens empty else i --xymeng: removed parens 1135 _ -> return $ i 1136ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do 1137 i <- ref2C r 1138 t <- gets lastType 1139 case t of 1140 BTFunction _ _ _ rt -> do 1141 modify(\s -> s{lastType = rt}) 1142 return $ if addParens then i <> parens empty else i 1143 _ -> return $ i 1144ref2CF r _ = ref2C r 1145 1146ref2C :: Reference -> State RenderState Doc 1147-- rewrite into proper form 1148ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) 1149ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) 1150ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 1151ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) 1152ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) 1153-- conversion routines 1154ref2C ae@(ArrayElement [expr] ref) = do 1155 e <- expr2C expr 1156 r <- ref2C ref 1157 t <- gets lastType 1158 case t of 1159 (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) 1160-- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'}) 1161-- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar}) 1162 BTString -> modify (\st -> st{lastType = BTChar}) 1163 BTAString -> modify (\st -> st{lastType = BTChar}) 1164 (BTPointerTo t) -> do 1165 t'' <- fromPointer (show t) =<< gets lastType 1166 case t'' of 1167 BTChar -> modify (\st -> st{lastType = BTChar}) 1168 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae 1169 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae 1170 case t of 1171 BTString -> return $ r <> text ".s" <> brackets e 1172 BTAString -> return $ r <> text ".s" <> brackets e 1173 _ -> return $ r <> brackets e 1174ref2C (SimpleReference name) = id2C IOLookup name 1175ref2C rf@(RecordField (Dereference ref1) ref2) = do 1176 r1 <- ref2C ref1 1177 t <- fromPointer (show ref1) =<< gets lastType 1178 r2 <- case t of 1179 BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2 1180 BTUnit -> error "What??" 1181 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf 1182 return $ 1183 r1 <> text "->" <> r2 1184ref2C rf@(RecordField ref1 ref2) = do 1185 r1 <- ref2C ref1 1186 t <- gets lastType 1187 case t of 1188 BTRecord _ rs -> do 1189 r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2 1190 return $ r1 <> text "." <> r2 1191 BTUnit -> withLastIdNamespace $ ref2C ref2 1192 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf 1193ref2C d@(Dereference ref) = do 1194 r <- ref2C ref 1195 t <- fromPointer (show d) =<< gets lastType 1196 modify (\st -> st{lastType = t}) 1197 return $ (parens $ text "*" <> r) 1198ref2C f@(FunCall params ref) = do 1199 r <- fref2C ref 1200 t <- gets lastType 1201 case t of 1202 BTFunction _ _ bts t' -> do 1203 ps <- liftM (parens . hsep . punctuate (char ',')) $ 1204 if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params 1205 then 1206 mapM expr2CHelper (zip params bts) 1207 else mapM expr2C params 1208 modify (\s -> s{lastType = t'}) 1209 return $ r <> ps 1210 _ -> case (ref, params) of 1211 (SimpleReference i, [p]) -> ref2C $ TypeCast i p 1212 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t 1213 where 1214 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name 1215 fref2C a = ref2C a 1216 expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc 1217 expr2CHelper (e, (_, BTFunction _ _ _ _)) = do 1218 modify (\s -> s{isFunctionType = True}) 1219 expr2C e 1220 expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e 1221 1222ref2C (Address ref) = do 1223 r <- ref2C ref 1224 lt <- gets lastType 1225 case lt of 1226 BTFunction True _ _ _ -> return $ text "&" <> parens r 1227 _ -> return $ text "&" <> parens r 1228ref2C (TypeCast t'@(Identifier i _) expr) = do 1229 lt <- expr2C expr >> gets lastType 1230 case (map toLower i, lt) of 1231 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) 1232 ("pchar", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pcharA" $ BTPointerTo BTChar)) 1233 ("shortstring", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString)) 1234 ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) 1235 ("ansistring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString)) 1236 ("ansistring", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString)) 1237 (a, _) -> do 1238 e <- expr2C expr 1239 t <- id2C IOLookup t' 1240 return . parens $ parens t <> e 1241ref2C (RefExpression expr) = expr2C expr 1242 1243 1244op2C :: String -> String 1245op2C "or" = "|" 1246op2C "and" = "&" 1247op2C "not" = "~" 1248op2C "xor" = "^" 1249op2C "div" = "/" 1250op2C "mod" = "%" 1251op2C "shl" = "<<" 1252op2C "shr" = ">>" 1253op2C "<>" = "!=" 1254op2C "=" = "==" 1255op2C "/" = "/(float)" 1256op2C a = a 1257 1258