# HG changeset patch
# User unc0rr
# Date 1322235372 -10800
# Node ID 1ef4192aa80de7f96a093a2ca703b3bec35c99e7
# Parent  a3b428e7441060a0fd3d49afd438594601b2f74b
 - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
 - Improve rendering of C code
 - Fix preprocessor issues, define "FPC"
 - Make pas2c convert unit along with its dependencies into corresponding .c files, so you just call it for hwengine.pas to convert the whole engine

diff -r a3b428e74410 -r 1ef4192aa80d tools/PascalBasics.hs
--- a/tools/PascalBasics.hs	Fri Nov 25 05:15:38 2011 +0100
+++ b/tools/PascalBasics.hs	Fri Nov 25 18:36:12 2011 +0300
@@ -25,7 +25,7 @@
             , "type", "var", "const", "out", "array", "packed"
             , "procedure", "function", "with", "for", "to"
             , "downto", "div", "mod", "record", "set", "nil"
-            , "string", "shortstring"
+            , "string", "shortstring", "cdecl", "external"
             ] ++ builtin
     , reservedOpNames= [] 
     , caseSensitive  = False   
diff -r a3b428e74410 -r 1ef4192aa80d tools/PascalParser.hs
--- a/tools/PascalParser.hs	Fri Nov 25 05:15:38 2011 +0100
+++ b/tools/PascalParser.hs	Fri Nov 25 18:36:12 2011 +0300
@@ -27,15 +27,17 @@
     deriving Show
 data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
     | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe InitExpression)
-    | FunctionDeclaration Identifier TypeDecl (Maybe (TypesAndVars, Phrase))
+    | FunctionDeclaration Identifier TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
     deriving Show
 data TypeDecl = SimpleType Identifier
     | RangeType Range
     | Sequence [Identifier]
-    | ArrayDecl Range TypeDecl
-    | RecordType [TypeVarDeclaration]
+    | ArrayDecl (Maybe Range) TypeDecl
+    | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])
     | PointerTo TypeDecl
     | String Integer
+    | Set TypeDecl
+    | FunctionType TypeDecl [TypeVarDeclaration]
     | UnknownType
     deriving Show
 data Range = Range Identifier
@@ -126,13 +128,12 @@
             [Infix (try (char '.' >> notFollowedBy (char '.')) >> return RecordField) AssocLeft]
         ]
     
-    postfixes r = many postfix >>= return . foldl fp r
+    postfixes r = many postfix >>= return . foldl (flip ($)) r
     postfix = choice [
             parens pas (option [] parameters) >>= return . FunCall
           , char '^' >> return Dereference
           , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
         ]
-    fp r f = f r
 
     
 varsDecl1 = varsParser sepEndBy1    
@@ -142,7 +143,7 @@
     return vs
 
 aVarDecl endsWithSemi = do
-    when (not endsWithSemi) $
+    unless endsWithSemi $
         optional $ choice [
             try $ string "var"
             , try $ string "const"
@@ -177,6 +178,7 @@
             char ':'
             comments
             t <- typeDecl
+            comments
             return ()
         char '='
         comments
@@ -190,30 +192,75 @@
     , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
     , arrayDecl
     , recordDecl
+    , setDecl
+    , functionType
     , sequenceDecl >>= return . Sequence
     , try (identifier pas) >>= return . SimpleType . Identifier
     , rangeDecl >>= return . RangeType
     ] <?> "type declaration"
     where
     arrayDecl = do
-        try $ string "array"
+        try $ do
+            optional $ (try $ string "packed") >> comments
+            string "array"
         comments
-        char '['
-        r <- rangeDecl
-        char ']'
-        comments
+        r <- optionMaybe $ do
+            char '['
+            r <- rangeDecl
+            char ']'
+            comments
+            return r
         string "of"
         comments
         t <- typeDecl
         return $ ArrayDecl r t
     recordDecl = do
-        optional $ (try $ string "packed") >> comments
-        try $ string "record"
+        try $ do
+            optional $ (try $ string "packed") >> comments
+            string "record"
         comments
         vs <- varsDecl True
+        union <- optionMaybe $ do
+            string "case"
+            comments
+            iD
+            comments
+            string "of"
+            comments
+            many unionCase
         string "end"
-        return $ RecordType vs
-    sequenceDecl = (parens pas) $ (commaSep pas) iD
+        return $ RecordType vs union
+    setDecl = do
+        try $ string "set" >> space
+        comments
+        string "of"
+        comments
+        liftM Set typeDecl
+    unionCase = do
+        try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
+        char ':'
+        comments
+        u <- parens pas $ varsDecl True
+        char ';'
+        comments
+        return u
+    sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
+    functionType = do
+        fp <- try (string "function") <|> try (string "procedure")
+        comments
+        vs <- option [] $ parens pas $ varsDecl False
+        comments
+        ret <- if (fp == "function") then do
+            char ':'
+            comments
+            ret <- typeDecl
+            comments
+            return ret
+            else
+            return UnknownType
+        optional $ try $ char ';' >> comments >> string "cdecl"
+        comments
+        return $ FunctionType ret vs
 
 typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
     where
@@ -245,8 +292,7 @@
     varSection,
     constSection,
     typeSection,
-    funcDecl,
-    procDecl
+    funcDecl
     ]
     where
     varSection = do
@@ -270,41 +316,34 @@
         comments
         return t
         
-    procDecl = do
-        try $ string "procedure"
+    funcDecl = do
+        fp <- try (string "function") <|> try (string "procedure")
         comments
         i <- iD
-        optional $ parens pas $ varsDecl False
+        vs <- option [] $ parens pas $ varsDecl False
         comments
+        ret <- if (fp == "function") then do
+            char ':'
+            comments
+            ret <- typeDecl
+            comments
+            return ret
+            else
+            return UnknownType
         char ';'
         comments
-        forward <- liftM isJust $ optionMaybe ((try $ string "forward;") >> comments)
+        forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
+        many functionDecorator
         b <- if isImpl && (not forward) then
                 liftM Just functionBody
                 else
                 return Nothing
---        comments
-        return $ [FunctionDeclaration i UnknownType b]
-        
-    funcDecl = do
-        try $ string "function"
-        comments
-        i <- iD
-        optional $ parens pas $ varsDecl False
-        comments
-        char ':'
-        comments
-        ret <- typeDecl
-        comments
-        char ';'
-        comments
-        forward <- liftM isJust $ optionMaybe ((try $ string "forward;") >> comments)
-        b <- if isImpl && (not forward) then
-                liftM Just functionBody
-                else
-                return Nothing
-        return $ [FunctionDeclaration i ret b]
-
+        return $ [FunctionDeclaration i ret vs b]
+    functionDecorator = choice [
+        try $ string "inline;"
+        , try $ string "cdecl;"
+        , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
+        ] >> comments
 program = do
     string "program"
     comments
@@ -366,6 +405,7 @@
         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
            , Infix (char '-' >> return (BinOp "-")) AssocLeft
           ]
+        , [Prefix (try (string "not") >> return (PrefixOp "not"))]
         , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
@@ -380,7 +420,6 @@
         , [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
            , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
           ]
-        , [Prefix (try (string "not") >> return (PrefixOp "not"))]
         ]
     
 phrasesBlock = do
@@ -416,7 +455,7 @@
     o1 <- phrase
     comments
     o2 <- optionMaybe $ do
-        try $ string "else"
+        try $ string "else" >> space
         comments
         o <- phrase
         comments
@@ -434,7 +473,7 @@
     return $ WhileCycle e o
 
 withBlock = do
-    try $ string "with"
+    try $ string "with" >> space
     comments
     rs <- (commaSep1 pas) reference
     comments
@@ -444,7 +483,7 @@
     return $ foldr WithBlock o rs
     
 repeatCycle = do
-    try $ string "repeat"
+    try $ string "repeat" >> space
     comments
     o <- many phrase
     string "until"
@@ -454,7 +493,7 @@
     return $ RepeatCycle e o
 
 forCycle = do
-    try $ string "for"
+    try $ string "for" >> space
     comments
     i <- iD
     comments
diff -r a3b428e74410 -r 1ef4192aa80d tools/PascalPreprocessor.hs
--- a/tools/PascalPreprocessor.hs	Fri Nov 25 05:15:38 2011 +0100
+++ b/tools/PascalPreprocessor.hs	Fri Nov 25 18:36:12 2011 +0300
@@ -15,9 +15,11 @@
         , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"
         ]
 
+initDefines = Map.fromList [("FPC", "")]
+        
 preprocess :: String -> IO String
 preprocess fn = do
-    r <- runParserT (preprocessFile fn) (Map.empty, [True]) "" ""
+    r <- runParserT (preprocessFile fn) (initDefines, [True]) "" ""
     case r of
          (Left a) -> do
              hPutStrLn stderr (show a)
@@ -81,7 +83,7 @@
         let f = if s == "IFNDEF" then not else id
         
         spaces
-        d <- many1 alphaNum
+        d <- identifier
         spaces
         char '}'
         
@@ -103,7 +105,7 @@
         try $ string "DEFINE"
         spaces
         i <- identifier        
-        d <- option "" (string ":=" >> many (noneOf "}"))
+        d <- ((string ":=" >> return ())<|> spaces) >> many (noneOf "}")
         char '}'
         updateState $ \(m, b) -> (if and b then Map.insert i d m else m, b)
         return ""
diff -r a3b428e74410 -r 1ef4192aa80d tools/pas2c.hs
--- a/tools/pas2c.hs	Fri Nov 25 05:15:38 2011 +0100
+++ b/tools/pas2c.hs	Fri Nov 25 18:36:12 2011 +0300
@@ -12,30 +12,44 @@
 import PascalPreprocessor
 import Control.Exception
 import System.IO.Error
-import qualified Data.Set as Set
+import qualified Data.Map as Map
 
 
-pas2C :: String -> IO String
-pas2C = flip evalStateT initState . f
+pas2C :: String -> IO ()
+pas2C fn = do
+    setCurrentDirectory "../hedgewars/"
+    flip evalStateT initState $ f fn
     where
     printLn = liftIO . hPutStrLn stderr
-    initState = Set.empty
-    f :: String -> StateT (Set.Set String) IO String
+    initState = Map.empty
+    f :: String -> StateT (Map.Map String PascalUnit) IO ()
     f fileName = do
-        liftIO $ setCurrentDirectory "../hedgewars/"
-        
-        fc' <- liftIO $ tryJust (guard . isDoesNotExistError) $ preprocess fileName
-        case fc' of
-            (Left a) -> return ""
-            (Right fc) -> do
-                modify $ Set.insert fileName
-                printLn $ "Preprocessed " ++ fileName
-                liftIO $ writeFile "debug.txt" fc
-                let ptree = parse pascalUnit fileName fc
-                case ptree of
-                     (Left a) -> return (show a)
-                     (Right a) -> (return . render . pascal2C) a
+        processed <- gets $ Map.member fileName
+        unless processed $ do
+            fc' <- liftIO 
+                $ tryJust (guard . isDoesNotExistError) 
+                $ hPutStr stderr ("Preprocessing '" ++ fileName ++ ".pas'... ") >> preprocess (fileName ++ ".pas")
+            case fc' of
+                (Left a) -> printLn "doesn't exist"
+                (Right fc) -> do
+                    printLn "ok"
+                    let ptree = parse pascalUnit fileName fc
+                    case ptree of
+                         (Left a) -> do
+                            liftIO $ writeFile "preprocess.out" fc
+                            printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
+                            fail "stop"
+                         (Right a) -> do
+                            modify (Map.insert fileName a)
+                            mapM_ f (usesFiles a)
+                            
          
+usesFiles :: PascalUnit -> [String]         
+usesFiles (Program _ (Implementation uses _) _) = uses2List uses
+usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2
+
+
+
 pascal2C :: PascalUnit -> Doc
 pascal2C (Unit unitName interface implementation init fin) = 
     interface2C interface
@@ -44,29 +58,40 @@
 pascal2C (Program _ implementation mainFunction) =
     implementation2C implementation
     $+$
-    tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") (Just (TypesAndVars [], mainFunction)))
+    tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") [] (Just (TypesAndVars [], mainFunction)))
 interface2C :: Interface -> Doc
-interface2C (Interface uses tvars) = typesAndVars2C tvars
+interface2C (Interface uses tvars) = uses2C uses $+$ typesAndVars2C tvars
 
 implementation2C :: Implementation -> Doc
-implementation2C (Implementation uses tvars) = typesAndVars2C tvars
+implementation2C (Implementation uses tvars) = uses2C uses $+$ typesAndVars2C tvars
 
 
 typesAndVars2C :: TypesAndVars -> Doc
 typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts
 
+uses2C :: Uses -> Doc
+uses2C uses = vcat $ map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
+
+uses2List :: Uses -> [String]
+uses2List (Uses ids) = map (\(Identifier i) -> i) ids
 
 tvar2C :: TypeVarDeclaration -> Doc
-tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = 
+tvar2C (FunctionDeclaration (Identifier name) returnType params Nothing) = 
     type2C returnType <+> text (name ++ "();")
-tvar2C (FunctionDeclaration (Identifier name) returnType (Just (tvars, phrase))) = 
+tvar2C (FunctionDeclaration (Identifier name) returnType params (Just (tvars, phrase))) = 
     type2C returnType <+> text (name ++ "()") 
-    $$
-    text "{" $+$ (nest 4 $ typesAndVars2C tvars)
     $+$
-    phrase2C phrase
-    $+$ 
+    text "{" 
+    $+$ nest 4 (
+        typesAndVars2C tvars
+        $+$
+        phrase2C' phrase
+        )
+    $+$
     text "}"
+    where
+    phrase2C' (Phrases p) = vcat $ map phrase2C p
+    phrase2C' p = phrase2C p
 tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";"
 tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = 
     if isConst then text "const" else empty
@@ -98,7 +123,7 @@
 type2C (String l) = text $ "string" ++ show l
 type2C (SimpleType (Identifier i)) = text i
 type2C (PointerTo t) = type2C t <> text "*"
-type2C (RecordType tvs) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}"
+type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}"
 type2C (RangeType r) = text "<<range type>>"
 type2C (Sequence ids) = text "<<sequence type>>"
 type2C (ArrayDecl r t) = text "<<array type>>"