# HG changeset patch
# User unc0rr
# Date 1320475087 -10800
# Node ID 68db7625060de1d2add45917ffeed1568b36bd34
# Parent  627b5752733ad1085b6eec6a06d84fabecb4d077# Parent  835392304f81acf1069adade45e59635378b852f
merge

diff -r 835392304f81 -r 68db7625060d hedgewars/uTypes.pas
--- a/hedgewars/uTypes.pas	Sat Nov 05 06:06:04 2011 +0100
+++ b/hedgewars/uTypes.pas	Sat Nov 05 09:38:07 2011 +0300
@@ -32,7 +32,7 @@
 
 type
     HwColor4f = record
-        r, g, b, a: byte
+        r, g, b, a: byte;
         end;
 
     // Possible states of the game
diff -r 835392304f81 -r 68db7625060d tools/PascalParser.hs
--- a/tools/PascalParser.hs	Sat Nov 05 06:06:04 2011 +0100
+++ b/tools/PascalParser.hs	Sat Nov 05 09:38:07 2011 +0300
@@ -14,7 +14,6 @@
     Program Identifier Implementation
     | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
     deriving Show
-
 data Interface = Interface Uses TypesAndVars
     deriving Show
 data Implementation = Implementation Uses TypesAndVars
@@ -23,16 +22,19 @@
     deriving Show
 data TypesAndVars = TypesAndVars [TypeVarDeclaration]
     deriving Show
-data TypeVarDeclaration = TypeDeclaration TypeDecl
-    | ConstDeclaration String
-    | VarDeclaration String
+data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
+    | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe Expression)
     | FunctionDeclaration Identifier Identifier (Maybe Phrase)
     deriving Show
 data TypeDecl = SimpleType Identifier
     | RangeType Range
+    | Sequence [Identifier]
     | ArrayDecl Range TypeDecl
+    | RecordType [TypeVarDeclaration]
+    | UnknownType
     deriving Show
-data Range = Range Identifier    
+data Range = Range Identifier
+           | RangeFromTo Expression Expression
     deriving Show
 data Initialize = Initialize String
     deriving Show
@@ -43,19 +45,31 @@
 data Phrase = ProcCall Identifier [Expression]
         | IfThenElse Expression Phrase (Maybe Phrase)
         | WhileCycle Expression Phrase
-        | RepeatCycle Expression Phrase
-        | ForCycle
+        | RepeatCycle Expression [Phrase]
+        | ForCycle Identifier Expression Expression Phrase
+        | WithBlock Expression Phrase
         | Phrases [Phrase]
         | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase)
-        | Assignment Identifier Expression
+        | Assignment Reference Expression
     deriving Show
 data Expression = Expression String
-    | FunCall Identifier [Expression]
+    | FunCall Reference [Expression]
     | PrefixOp String Expression
+    | PostfixOp String Expression
     | BinOp String Expression Expression
+    | StringLiteral String
+    | CharCode String
+    | NumberLiteral String
+    | HexNumber String
+    | Address Reference
+    | Reference Reference
+    deriving Show
+data Reference = ArrayElement Identifier Expression
+    | SimpleReference Identifier
+    | RecordField Reference Reference
+    | Dereference Reference
     deriving Show
     
-
 pascalLanguageDef
     = emptyDef
     { commentStart   = "(*"
@@ -69,13 +83,27 @@
             , "implementation", "and", "or", "xor", "shl"
             , "shr", "while", "do", "repeat", "until", "case", "of"
             , "type", "var", "const", "out", "array"
-            , "procedure", "function"
+            , "procedure", "function", "with", "for", "to"
+            , "downto", "div", "mod", "record", "set"
             ]
     , reservedOpNames= [] 
     , caseSensitive  = False   
     }
     
-pas = makeTokenParser pascalLanguageDef
+pas = patch $ makeTokenParser pascalLanguageDef
+    where
+    patch tp = tp {stringLiteral = sl}
+    sl = do
+        (char '\'')
+        s <- (many $ noneOf "'")
+        (char '\'')
+        ss <- many $ do
+            (char '\'')
+            s' <- (many $ noneOf "'")
+            (char '\'')
+            return $ '\'' : s'
+        comments    
+        return $ concat (s:ss)
     
 comments = do
     spaces
@@ -95,33 +123,93 @@
         , (try $ string "//") >> manyTill anyChar (try newline)
         ]
 
+iD = do
+    i <- liftM Identifier (identifier pas)
+    comments
+    return i
+        
 unit = do
-    name <- liftM Identifier unitName
+    string "unit" >> comments
+    name <- iD
+    semi pas
     comments
     int <- interface
     impl <- implementation
     comments
     return $ Unit name int impl Nothing Nothing
+
+    
+reference = buildExpressionParser table term <?> "reference"
     where
-        unitName = between (string "unit" >> comments) (semi pas) (identifier pas)
+    term = comments >> choice [
+        parens pas reference 
+        , try $ iD >>= \i -> (brackets pas) expression >>= return . ArrayElement i
+        , iD >>= return . SimpleReference
+        ] <?> "simple reference"
 
-varsDecl endsWithSemi = do
-    vs <- many (try (aVarDecl >> semi pas) >> comments)
-    when (not endsWithSemi) $ aVarDecl >> return ()
+    table = [ 
+        [Postfix (char '^' >> return Dereference)]
+        , [Infix (char '.' >> return RecordField) AssocLeft]
+        ]
+    
+varsDecl1 = varsParser many1    
+varsDecl = varsParser many
+varsParser m endsWithSemi = do
+    vs <- m (aVarDecl >>= \i -> semi pas >> comments >> return i)
+    v <- if not endsWithSemi then liftM (\a -> [a]) aVarDecl else return []
     comments
-    return $ VarDeclaration $ show vs
+    return $ vs ++ v
     where
     aVarDecl = do
-        ids <- (commaSep1 pas) $ ((identifier pas) <?> "variable declaration") >>= \i -> comments >> return (Identifier i)
-        char ':'
+        when (not endsWithSemi) $
+            optional $ choice [
+                try $ string "var"
+                , try $ string "const"
+                , try $ string "out"
+                ]
+        comments
+        ids <- try $ do
+            i <- (commaSep1 pas) $ (iD <?> "variable declaration")
+            char ':'
+            return i
+        comments
+        t <- typeDecl <?> "variable type declaration"
         comments
-        t <- typeDecl
+        init <- option Nothing $ do
+            char '='
+            comments
+            e <- expression
+            comments
+            char ';'
+            comments
+            return (Just e)
+        return $ VarDeclaration False (ids, t) init
+
+
+constsDecl = do
+    vs <- many (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
+    comments
+    return vs
+    where
+    aConstDecl = do
         comments
-        return (ids, t)
+        i <- iD <?> "const declaration"
+        optional $ do
+            char ':'
+            comments
+            t <- typeDecl
+            return ()
+        char '='
+        comments
+        e <- expression
+        comments
+        return $ VarDeclaration False ([i], UnknownType) (Just e)
         
 typeDecl = choice [
     arrayDecl
+    , recordDecl
     , rangeDecl >>= return . RangeType
+    , seqenceDecl >>= return . Sequence
     , identifier pas >>= return . SimpleType . Identifier
     ] <?> "type declaration"
     where
@@ -136,13 +224,44 @@
         comments
         t <- typeDecl
         return $ ArrayDecl r t
+    recordDecl = do
+        try $ string "record"
+        comments
+        vs <- varsDecl True
+        string "end"
+        return $ RecordType vs
+    seqenceDecl = (parens pas) $ (commaSep pas) iD
 
+typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
+    where
+    aTypeDecl = do
+        i <- try $ do
+            i <- iD <?> "type declaration"
+            comments
+            char '='
+            return i
+        comments
+        t <- typeDecl
+        comments
+        semi pas
+        comments
+        return $ TypeDeclaration i t
+        
 rangeDecl = choice [
-    identifier pas >>= return . Range . Identifier
+    try $ rangeft
+    , iD >>= return . Range
     ] <?> "range declaration"
-
-typeVarDeclaration isImpl = choice [
+    where
+    rangeft = do
+    e1 <- expression
+    string ".."
+    e2 <- expression
+    return $ RangeFromTo e1 e2
+    
+typeVarDeclaration isImpl = (liftM concat . many . choice) [
     varSection,
+    constSection,
+    typeSection,
     funcDecl,
     procDecl
     ]
@@ -150,14 +269,28 @@
     varSection = do
         try $ string "var"
         comments
-        v <- varsDecl True
+        v <- varsDecl1 True
         comments
         return v
-            
+
+    constSection = do
+        try $ string "const"
+        comments
+        c <- constsDecl
+        comments
+        return c
+
+    typeSection = do
+        try $ string "type"
+        comments
+        t <- typesDecl
+        comments
+        return t
+        
     procDecl = do
         string "procedure"
         comments
-        i <- liftM Identifier $ identifier pas
+        i <- iD
         optional $ do
             char '('
             varsDecl False
@@ -167,51 +300,53 @@
         b <- if isImpl then
                 do
                 comments
-                typeVarDeclaration isImpl
+                optional $ typeVarDeclaration True
                 comments
                 liftM Just functionBody
                 else
                 return Nothing
         comments
-        return $ FunctionDeclaration i (Identifier "") b
+        return $ [FunctionDeclaration i (Identifier "") b]
         
     funcDecl = do
         string "function"
         comments
+        i <- iD
         optional $ do
             char '('
             varsDecl False
             char ')'
         comments
         char ':'
-        ret <- identifier pas
+        ret <- iD
         comments
         char ';'
         b <- if isImpl then
                 do
                 comments
-                typeVarDeclaration isImpl
+                optional $ typeVarDeclaration True
                 comments
                 liftM Just functionBody
                 else
                 return Nothing
-        return $ FunctionDeclaration (Identifier "function") (Identifier ret) Nothing
+        return $ [FunctionDeclaration i ret Nothing]
 
 program = do
-    name <- liftM Identifier programName
+    string "program"
+    comments
+    name <- iD
+    (char ';')
     comments
     impl <- implementation
     comments
     return $ Program name impl
-    where
-        programName = between (string "program") (char ';') (identifier pas)
 
 interface = do
     string "interface"
     comments
     u <- uses
     comments
-    tv <- many (typeVarDeclaration False)
+    tv <- typeVarDeclaration False
     comments
     return $ Interface u (TypesAndVars tv)
 
@@ -220,7 +355,7 @@
     comments
     u <- uses
     comments
-    tv <- many (typeVarDeclaration True)
+    tv <- typeVarDeclaration True
     string "end."
     comments
     return $ Implementation u (TypesAndVars tv)
@@ -229,30 +364,37 @@
     where
     term = comments >> choice [
         parens pas $ expression 
-        , natural pas >>= return . Expression . show
-        , funCall
+        , integer pas >>= return . NumberLiteral . show
+        , stringLiteral pas >>= return . StringLiteral
+        , char '#' >> many digit >>= return . CharCode
+        , char '$' >> many hexDigit >>= return . HexNumber
+        , char '@' >> reference >>= return . Address
+        , try $ funCall
+        , reference >>= return . Reference
         ] <?> "simple expression"
 
     table = [ 
-          [Infix (string "^." >> return (BinOp "^.")) AssocLeft]
-        , [Prefix (string "not" >> return (PrefixOp "not"))]
+          [Prefix (string "not" >> return (PrefixOp "not"))]
         , [  Infix (char '*' >> return (BinOp "*")) AssocLeft
            , Infix (char '/' >> return (BinOp "/")) AssocLeft
-           ]
+           , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
+           , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
+          ]
         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
            , Infix (char '-' >> return (BinOp "-")) AssocLeft
-           ]
-        , [  Infix (try (string "<>" )>> return (BinOp "<>")) AssocNone
+           , Prefix (char '-' >> return (PrefixOp "-"))
+          ]
+        , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
            , Infix (char '<' >> return (BinOp "<")) AssocNone
            , Infix (char '>' >> return (BinOp ">")) AssocNone
            , Infix (char '=' >> return (BinOp "=")) AssocNone
-           ]
-        , [  Infix (try $ string "and" >> return (BinOp "and")) AssocNone
-           , Infix (try $ string "or" >> return (BinOp "or")) AssocNone
-           , Infix (try $ string "xor" >> return (BinOp "xor")) AssocNone
-           ]
+          ]
+        , [  Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
+           , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+           , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
+          ]
         ]
     
 phrasesBlock = do
@@ -267,8 +409,11 @@
         phrasesBlock
         , ifBlock
         , whileCycle
+        , repeatCycle
         , switchCase
-        , try $ identifier pas >>= \i -> string ":=" >> expression >>= return . Assignment (Identifier i)
+        , withBlock
+        , forCycle
+        , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r
         , procCall
         ]
     optional $ char ';'
@@ -290,7 +435,6 @@
         o <- phrase
         comments
         return o
-    optional $ char ';'
     return $ IfThenElse e o1 o2
 
 whileCycle = do
@@ -301,9 +445,47 @@
     string "do"
     comments
     o <- phrase
-    optional $ char ';'
     return $ WhileCycle e o
 
+withBlock = do
+    try $ string "with"
+    comments
+    e <- expression
+    comments
+    string "do"
+    comments
+    o <- phrase
+    return $ WithBlock e o
+    
+repeatCycle = do
+    try $ string "repeat"
+    comments
+    o <- many phrase
+    string "until"
+    comments
+    e <- expression
+    comments
+    return $ RepeatCycle e o
+
+forCycle = do
+    try $ string "for"
+    comments
+    i <- iD
+    comments
+    string ":="
+    comments
+    e1 <- expression
+    comments
+    choice [string "to", string "downto"]
+    comments
+    e2 <- expression
+    comments
+    string "do"
+    comments
+    p <- phrase
+    comments
+    return $ ForCycle i e1 e2 p
+    
 switchCase = do
     try $ string "case"
     comments
@@ -319,7 +501,6 @@
         comments
         return o
     string "end"
-    optional $ char ';'
     return $ SwitchCase e cs o2
     where
     aCase = do
@@ -332,16 +513,16 @@
         return (e, p)
     
 procCall = do
-    i <- liftM Identifier $ identifier pas
+    i <- iD
     p <- option [] $ (parens pas) parameters
     return $ ProcCall i p
 
 funCall = do
-    i <- liftM Identifier $ identifier pas
-    p <- option [] $ (parens pas) parameters
-    return $ FunCall i p
+    r <- reference
+    p <- (parens pas) $ option [] parameters
+    return $ FunCall r p
 
-parameters = expression `sepBy` (char ',' >> comments)
+parameters = (commaSep pas) expression <?> "parameters"
         
 functionBody = do
     p <- phrasesBlock
@@ -354,7 +535,7 @@
         u = do
             string "uses"
             comments
-            u <- (identifier pas >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments)
+            u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
             char ';'
             comments
             return u
diff -r 835392304f81 -r 68db7625060d tools/pas2c.hs
--- a/tools/pas2c.hs	Sat Nov 05 06:06:04 2011 +0100
+++ b/tools/pas2c.hs	Sat Nov 05 09:38:07 2011 +0300
@@ -3,6 +3,7 @@
 import PascalParser
 import Text.PrettyPrint.HughesPJ
 import Data.Maybe
+import Data.Char
 
 
 pascal2C :: PascalUnit -> Doc
@@ -36,7 +37,7 @@
     where
     elsePart | isNothing mphrase2 = empty
              | otherwise = text "else" $$ (braces . nest 4 . phrase2C) (fromJust mphrase2)
-phrase2C (Assignment (Identifier name) expr) = text name <> text " = " <> expr2C expr <> semi
+phrase2C (Assignment ref expr) = ref2C ref <> text " = " <> expr2C expr <> semi
 phrase2C (WhileCycle expr phrase) = text "while" <> parens (expr2C expr) $$ nest 4 (phrase2C phrase)
 phrase2C (SwitchCase expr cases mphrase) = text "switch" <> parens (expr2C expr) <> text "of" $$ (nest 4 . vcat . map case2C) cases
     where
@@ -50,18 +51,36 @@
         -}
 phrase2C _ = empty
 
+ref2C :: Reference -> Doc
+ref2C (ArrayElement (Identifier name) expr) = text name <> brackets (expr2C expr)
+ref2C (SimpleReference (Identifier name)) = text name
+ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2
+ref2C (Dereference ref) = parens $ text "*" <> ref2C ref
 
 expr2C :: Expression -> Doc
 expr2C (Expression s) = text s
-expr2C (FunCall (Identifier name) params) = text name <> parens (hsep . punctuate (char ',') . map expr2C $ params)
+expr2C (FunCall ref params) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params)
 expr2C (BinOp op expr1 expr2) = (expr2C expr1) <+> op2C op <+> (expr2C expr2)
-{-    | FunCall Identifier [Expression]
+expr2C (NumberLiteral s) = text s
+expr2C (HexNumber s) = text "0x" <> (text . map toLower $ s)
+expr2C (StringLiteral s) = doubleQuotes $ text s 
+expr2C (Address ref) = text "&" <> ref2C ref
+expr2C (Reference ref) = ref2C ref
+
+{-    
     | PrefixOp String Expression
-    | BinOp String Expression Expression
+    | PostfixOp String Expression
+    | CharCode String
     -}            
 expr2C _ = empty
 
-op2C = text
+op2C "or" = text "|"
+op2C "and" = text "&"
+op2C "div" = text "/"
+op2C "mod" = text "%"
+op2C "<>" = text "!="
+op2C "=" = text "=="
+op2C a = text a
 
 maybeVoid "" = "void"
 maybeVoid a = a