diff -r 459bc720cea1 -r b26c2772e754 tools/pas2c/Pas2C.hs --- a/tools/pas2c/Pas2C.hs Thu Feb 06 23:02:35 2014 +0400 +++ b/tools/pas2c/Pas2C.hs Fri Feb 07 00:46:49 2014 +0400 @@ -7,8 +7,6 @@ import Text.Parsec.Prim hiding (State) import Control.Monad.State import System.IO -import System.Directory -import Control.Monad.IO.Class import PascalPreprocessor import Control.Exception import System.IO.Error @@ -53,8 +51,10 @@ namespaces :: Map.Map String Records } +rec2Records :: [(String, BaseType)] -> [Record] rec2Records = map (\(a, b) -> Record a b empty) +emptyState :: Map.Map String Records -> RenderState emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" "" getUniq :: State RenderState Int @@ -102,22 +102,22 @@ renderCFiles s outputPath where printLn = liftIO . hPutStrLn stdout - print = liftIO . hPutStr stdout + print' = liftIO . hPutStr stdout initState = Map.empty f :: String -> StateT (Map.Map String PascalUnit) IO () f fileName = do processed <- gets $ Map.member fileName unless processed $ do - print ("Preprocessing '" ++ fileName ++ ".pas'... ") + print' ("Preprocessing '" ++ fileName ++ ".pas'... ") fc' <- liftIO $ tryJust (guard . isDoesNotExistError) $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols case fc' of - (Left a) -> do + (Left _) -> do modify (Map.insert fileName (System [])) printLn "doesn't exist" (Right fc) -> do - print "ok, parsing... " + print' "ok, parsing... " let ptree = parse pascalUnit fileName fc case ptree of (Left a) -> do @@ -159,16 +159,16 @@ withState' f sf = do st <- liftM f get let (a, s) = runState sf st - modify(\st -> st{ + modify(\st' -> st'{ lastType = lastType s , uniqCounter = uniqCounter s , stringConsts = stringConsts s }) return a +withLastIdNamespace :: State RenderState Doc -> State RenderState Doc withLastIdNamespace f = do li <- gets lastIdentifier - nss <- gets namespaces withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc @@ -178,34 +178,36 @@ f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs un [a] b = a : b + un _ _ = error "withRecordNamespace un: pattern not matched" toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO () toCFiles _ _ (_, System _) = return () toCFiles _ _ (_, Redo _) = return () -toCFiles outputPath ns p@(fn, pu) = do - hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." - toCFiles' p +toCFiles outputPath ns pu@(fileName, _) = do + hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..." + toCFiles' pu where toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} - (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} + (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} enumDecl = (renderEnum2Strs (enums s) False) enumImpl = (renderEnum2Strs (enums s) True) writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl + toCFiles' _ = undefined -- just pleasing compiler to not warn us initialState = emptyState ns render2C :: RenderState -> State RenderState Doc -> String render2C st p = - let (a, s) = runState p st in + let (a, _) = runState p st in render a renderEnum2Strs :: [(String, [String])] -> Bool -> String -renderEnum2Strs enums implement = - render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums +renderEnum2Strs enums' implement = + render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums' where - decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar") + decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar") enum2strBlock en = text "{" $+$ @@ -230,7 +232,7 @@ usesFiles (Redo {}) = [] pascal2C :: PascalUnit -> State RenderState Doc -pascal2C (Unit _ interface implementation init fin) = +pascal2C (Unit _ interface implementation _ _) = liftM2 ($+$) (interface2C interface True) (implementation2C implementation) pascal2C (Program _ implementation mainFunction) = do @@ -239,6 +241,7 @@ return $ impl $+$ main +pascal2C _ = error "pascal2C: pattern not matched" -- the second bool indicates whether do normal interface translation or generate variable declarations -- that will be inserted into implementation files @@ -249,9 +252,9 @@ r <- renderStringConsts return (u $+$ r $+$ tv) interface2C (Interface uses tvars) False = do - u <- uses2C uses + void $ uses2C uses tv <- typesAndVars2C True False False tvars - r <- renderStringConsts + void $ renderStringConsts return tv implementation2C :: Implementation -> State RenderState Doc @@ -265,6 +268,7 @@ checkDuplicateFunDecls tvs = modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs} where + initMap :: Map.Map String Int initMap = Map.empty --initMap = Map.fromList [("reset", 2)] ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m @@ -297,18 +301,18 @@ uses2List (Uses ids) = map (\(Identifier i _) -> i) ids +setLastIdValues :: Record -> RenderState -> RenderState setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) id2C :: InsertOption -> Identifier -> State RenderState Doc id2C IOInsert i = id2C (IOInsertWithType empty) i id2C (IOInsertWithType d) (Identifier i t) = do - ns <- gets currentScope tom <- gets (Set.member n . toMangle) cu <- gets currentUnit let (i', t') = case (t, tom) of (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t) (BTFunction _ _ _, _) -> (cu ++ i, t) - (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t') + (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'') _ -> (i, t) modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) return $ text i' @@ -317,7 +321,7 @@ id2C IOLookup i = id2CLookup head i id2C IOLookupLast i = id2CLookup last i -id2C (IOLookupFunction params) (Identifier i t) = do +id2C (IOLookupFunction params) (Identifier i _) = do let i' = map toLower i v <- gets $ Map.lookup i' . currentScope lt <- gets lastType @@ -329,7 +333,7 @@ where checkParam (Record _ (BTFunction _ p _) _) = (length p) == params checkParam _ = False -id2C IODeferred (Identifier i t) = do +id2C IODeferred (Identifier i _) = do let i' = map toLower i v <- gets $ Map.lookup i' . currentScope if (isNothing v) then @@ -338,7 +342,7 @@ let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc -id2CLookup f (Identifier i t) = do +id2CLookup f (Identifier i _) = do let i' = map toLower i v <- gets $ Map.lookup i' . currentScope lt <- gets lastType @@ -405,6 +409,7 @@ where f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids + f _ = error "resolveType f: pattern not matched" resolveType (ArrayDecl (Just i) t) = do t' <- resolveType t return $ BTArray i (BTInt True) t' @@ -444,6 +449,7 @@ error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s +functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params numberOfDeclarations :: [TypeVarDeclaration] -> Int @@ -473,7 +479,7 @@ ps = zip ['a'..] (toIsVarList params) fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] -fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do +fun2C _ _ (FunctionDeclaration name _ overload returnType params Nothing) = do t <- type2C returnType t'<- gets lastType bts <- typeVarDecl2BaseType params @@ -482,7 +488,7 @@ let decor = if overload then text "__attribute__((overloadable))" else empty return [t empty <+> decor <+> text n <> parens p] -fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do +fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload returnType params (Just (tvars, phrase))) = do let isVoid = case returnType of VoidType -> True _ -> False @@ -492,7 +498,7 @@ t' <- gets lastType bts <- typeVarDecl2BaseType params - cu <- gets currentUnit + --cu <- gets currentUnit notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name @@ -507,7 +513,7 @@ return (p, ph) let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi - let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty + --let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty let inlineDecor = if inline then case notDeclared of True -> text "static inline" False -> text "inline" @@ -528,6 +534,7 @@ phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p phrase2C' p = phrase2C p un [a] b = a : b + un _ _ = error "fun2C u: pattern not matched" hasVars = hasPassByReference params fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name @@ -540,13 +547,13 @@ tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do t <- fun2C b name f if includeType then return t else return [] -tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do +tvar2C _ _ includeType _ (TypeDeclaration i' t) = do i <- id2CTyped t i' tp <- type2C t let res = if includeType then [text "typedef" <+> tp i] else [] case t of (Sequence ids) -> do - modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s}) + modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s}) return res _ -> return res @@ -567,15 +574,15 @@ return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] (True, BTFloat, [i], Just e) -> do i' <- id2CTyped t i - ie <- initExpr2C e - return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else [] + ie' <- initExpr2C e + return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else [] (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids (_, BTArray r _ _, [i], _) -> do i' <- id2CTyped t i ie' <- return $ case (r, mInitExpr, ignoreInit) of (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all (_, _, _) -> ie - result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids + result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids case (r, ignoreInit) of (RangeInfinite, False) -> -- if the array is dynamic, add dimension info to it @@ -594,9 +601,10 @@ varDeclDecision True True varStr expStr = varStr <+> expStr varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr varDeclDecision False False varStr expStr = varStr <+> expStr - varDeclDecision True False varStr expStr = empty + varDeclDecision True False _ _ = empty arrayDimension a = case a of - ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t + ArrayDecl Nothing t' -> let a' = arrayDimension t' in + if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." _ -> 0 @@ -607,7 +615,7 @@ op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier op2CTyped op t = do - t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t + t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t bt <- gets lastType return $ Identifier (t' ++ "_op_" ++ opStr) bt where @@ -645,7 +653,7 @@ e2 <- initExpr2C' expr2 return $ parens $ e1 <+> text (op2C op) <+> e2 initExpr2C' (InitNumber s) = do - modify(\s -> s{lastType = (BTInt True)}) + modify(\st -> st{lastType = (BTInt True)}) return $ text s initExpr2C' (InitFloat s) = return $ text s initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) @@ -660,7 +668,7 @@ -- e <- initExpr2C $ InitRecord fields -- return $ braces $ e initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do - id2C IOLookup i + void $ id2C IOLookup i t <- gets lastType case t of BTEnum s -> return . int $ length s @@ -672,14 +680,14 @@ initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] initExpr2C' (InitRange a) = error $ show a --return $ text "<>" initExpr2C' (InitSet []) = return $ text "0" -initExpr2C' (InitSet a) = return $ text "<>" +initExpr2C' (InitSet _) = return $ text "<>" initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ case e of (Identifier "LongInt" _) -> int (-2^31) (Identifier "SmallInt" _) -> int (-2^15) _ -> error $ "BuiltInFunction 'low': " ++ show e initExpr2C' (BuiltInFunction "high" [e]) = do - initExpr2C e + void $ initExpr2C e t <- gets lastType case t of (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i] @@ -705,7 +713,7 @@ baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s type2C :: TypeDecl -> State RenderState (Doc -> Doc) -type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i +type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i type2C t = do r <- type2C' t rt <- resolveType t @@ -721,11 +729,11 @@ BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a _ -> return $ \a -> i' <+> text "*" <+> a - type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t + type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t type2C' (RecordType tvs union) = do - t <- withState' f $ mapM (tvar2C False False True False) tvs + t' <- withState' f $ mapM (tvar2C False False True False) tvs u <- unions - return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i + return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i where f s = s{currentUnit = ""} unions = case union of @@ -733,9 +741,9 @@ Just a -> do structs <- mapM struct2C a return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi - struct2C tvs = do - t <- withState' f $ mapM (tvar2C False False True False) tvs - return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi + struct2C stvs = do + txts <- withState' f $ mapM (tvar2C False False True False) stvs + return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi type2C' (RangeType r) = return (text "int" <+>) type2C' (Sequence ids) = do is <- mapM (id2C IOInsert . setBaseType bt) ids @@ -768,6 +776,7 @@ t <- gets lastType return (baseType2C (show r) t <+>) type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a + type2C' a = error $ "type2C: unknown type " ++ show a phrase2C :: Phrase -> State RenderState Doc phrase2C (Phrases p) = do @@ -775,7 +784,7 @@ return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True -phrase2C (ProcCall ref params) = error $ "ProcCall"{-do +phrase2C (ProcCall _ _) = error $ "ProcCall"{-do r <- ref2C ref ps <- mapM expr2C params return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} @@ -796,7 +805,7 @@ e <- ref2C r' return $ r <+> text "=" <+> e <> semi (BTString, _) -> do - e <- expr2C expr + void $ expr2C expr lt <- gets lastType case lt of -- assume pointer to char for simplicity @@ -810,7 +819,7 @@ (BTArray _ _ _, _) -> do case expr of Reference er -> do - exprRef <- ref2C er + void $ ref2C er exprT <- gets lastType case exprT of BTArray RangeInfinite _ _ -> @@ -904,7 +913,7 @@ expr2C :: Expression -> State RenderState Doc expr2C (Expression s) = return $ text s -expr2C b@(BinOp op expr1 expr2) = do +expr2C (BinOp op expr1 expr2) = do e1 <- expr2C expr1 t1 <- gets lastType e2 <- expr2C expr2 @@ -1006,7 +1015,7 @@ e' <- liftM (map toLower . render) $ expr2C e lt <- gets lastType case lt of - BTEnum a -> return $ int 0 + BTEnum _-> return $ int 0 BTInt _ -> case e' of "longint" -> return $ int (-2147483648) BTArray {} -> return $ int 0