diff -r 162bc562335b -r 59b5b19e6604 tools/pas2c.hs
--- a/tools/pas2c.hs	Wed Jun 27 13:47:42 2012 -0400
+++ b/tools/pas2c.hs	Wed Jun 27 22:53:26 2012 +0400
@@ -21,7 +21,7 @@
 import PascalUnitSyntaxTree
 
 
-data InsertOption = 
+data InsertOption =
     IOInsert
     | IOLookup
     | IOLookupLast
@@ -30,7 +30,7 @@
 
 type Record = (String, BaseType)
 type Records = Map.Map String [Record]
-data RenderState = RenderState 
+data RenderState = RenderState
     {
         currentScope :: Records,
         lastIdentifier :: String,
@@ -42,7 +42,7 @@
         currentFunctionResult :: String,
         namespaces :: Map.Map String Records
     }
-    
+
 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" ""
 
 getUniq :: State RenderState Int
@@ -50,7 +50,7 @@
     i <- gets uniqCounter
     modify(\s -> s{uniqCounter = uniqCounter s + 1})
     return i
-    
+
 addStringConst :: String -> State RenderState Doc
 addStringConst str = do
     strs <- gets stringConsts
@@ -65,7 +65,7 @@
         let sn = "__str" ++ show i
         modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
         return $ text sn
-    
+
 escapeStr :: String -> String
 escapeStr = foldr escapeChar []
 
@@ -77,9 +77,9 @@
 strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
 
 renderStringConsts :: State RenderState Doc
-renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi)) 
+renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
     $ gets stringConsts
-    
+
 docToLower :: Doc -> Doc
 docToLower = text . map toLower . render
 
@@ -97,8 +97,8 @@
         processed <- gets $ Map.member fileName
         unless processed $ do
             print ("Preprocessing '" ++ fileName ++ ".pas'... ")
-            fc' <- liftIO 
-                $ tryJust (guard . isDoesNotExistError) 
+            fc' <- liftIO
+                $ tryJust (guard . isDoesNotExistError)
                 $ preprocess (fileName ++ ".pas")
             case fc' of
                 (Left a) -> do
@@ -127,14 +127,14 @@
     mapM_ (toCFiles nss) u
     where
     toNamespace :: Map.Map String Records -> PascalUnit -> Records
-    toNamespace nss (System tvs) = 
+    toNamespace nss (System tvs) =
         currentScope $ execState f (emptyState nss)
         where
         f = do
             checkDuplicateFunDecls tvs
-            mapM_ (tvar2C True) tvs                
+            mapM_ (tvar2C True) tvs
     toNamespace _ (Program {}) = Map.empty
-    toNamespace nss (Unit (Identifier i _) interface _ _ _) = 
+    toNamespace nss (Unit (Identifier i _) interface _ _ _) =
         currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"}
 
 
@@ -188,22 +188,22 @@
 pascal2C :: PascalUnit -> State RenderState Doc
 pascal2C (Unit _ interface implementation init fin) =
     liftM2 ($+$) (interface2C interface) (implementation2C implementation)
-    
+
 pascal2C (Program _ implementation mainFunction) = do
     impl <- implementation2C implementation
-    [main] <- tvar2C True 
+    [main] <- tvar2C True
         (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
     return $ impl $+$ main
 
-    
-    
+
+
 interface2C :: Interface -> State RenderState Doc
 interface2C (Interface uses tvars) = do
     u <- uses2C uses
     tv <- typesAndVars2C True tvars
     r <- renderStringConsts
     return (u $+$ r $+$ tv)
-    
+
 implementation2C :: Implementation -> State RenderState Doc
 implementation2C (Implementation uses tvars) = do
     u <- uses2C uses
@@ -261,10 +261,10 @@
     let i' = map toLower i
     v <- gets $ Map.lookup i' . currentScope
     lt <- gets lastType
-    if isNothing v then 
+    if isNothing v then
         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
-        else 
-        let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in 
+        else
+        let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
             modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
     where
         checkParam (_, BTFunction p _) = p == params
@@ -282,16 +282,16 @@
     let i' = map toLower i
     v <- gets $ Map.lookup i' . currentScope
     lt <- gets lastType
-    if isNothing v then 
+    if isNothing v then
         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
-        else 
+        else
         let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
-        
-        
+
+
 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
 id2CTyped t (Identifier i _) = do
     tb <- resolveType t
-    case (t, tb) of 
+    case (t, tb) of
         (_, BTUnknown) -> do
             error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
         (SimpleType {}, BTRecord _ r) -> do
@@ -301,7 +301,7 @@
             ts <- type2C t
             id2C IOInsert (Identifier i (BTRecord i r))
         _ -> id2C IOInsert (Identifier i tb)
-    
+
 
 
 resolveType :: TypeDecl -> State RenderState BaseType
@@ -327,7 +327,7 @@
         f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
 resolveType (ArrayDecl (Just i) t) = do
     t' <- resolveType t
-    return $ BTArray i BTInt t' 
+    return $ BTArray i BTInt t'
 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
 resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t
 resolveType (DeriveType (InitHexNumber _)) = return BTInt
@@ -344,7 +344,7 @@
 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
 resolveType (RangeType _) = return $ BTVoid
 resolveType (Set t) = liftM BTSet $ resolveType t
-   
+
 
 resolve :: String -> BaseType -> State RenderState BaseType
 resolve s (BTUnresolved t) = do
@@ -360,7 +360,7 @@
 fromPointer s t = do
     error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
 
-    
+
 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
 
 numberOfDeclarations :: [TypeVarDeclaration] -> Int
@@ -371,35 +371,35 @@
 
 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do
-    t <- type2C returnType 
+    t <- type2C returnType
     t'<- gets lastType
     p <- withState' id $ functionParams2C params
     n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name
     return [t empty <+> n <> parens p]
-    
+
 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
     let res = docToLower $ text rv <> text "_result"
     t <- type2C returnType
     t'<- gets lastType
     n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name
-    
+
     let isVoid = case returnType of
             VoidType -> True
             _ -> False
-            
+
     (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st
             , currentFunctionResult = if isVoid then [] else render res}) $ do
         p <- functionParams2C params
         ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
         return (p, ph)
-        
+
     let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
-    
-    return [ 
+
+    return [
         t empty <+> n <> parens p
         $+$
-        text "{" 
-        $+$ 
+        text "{"
+        $+$
         nest 4 phrasesBlock
         $+$
         text "}"]
@@ -407,7 +407,7 @@
     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
     phrase2C' p = phrase2C p
     un [a] b = a : b
-    
+
 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
 
@@ -418,7 +418,7 @@
     i <- id2CTyped t i'
     tp <- type2C t
     return [text "typedef" <+> tp i]
-    
+
 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
     t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t
     ie <- initExpr mInitExpr
@@ -436,18 +436,18 @@
     where
     initExpr Nothing = return $ empty
     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
-    
+
 tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do
     r <- op2CTyped op (extractTypes params)
     fun2C f i (FunctionDeclaration r ret params body)
 
-    
+
 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
 op2CTyped op t = do
     t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
     bt <- gets lastType
     return $ Identifier (t' ++ "_op_" ++ opStr) bt
-    where 
+    where
     opStr = case op of
                     "+" -> "add"
                     "-" -> "sub"
@@ -458,7 +458,7 @@
                     ">" -> "gt"
                     "<>" -> "neq"
                     _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
-    
+
 extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
 extractTypes = concatMap f
     where
@@ -500,7 +500,7 @@
 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
 initExpr2C' (InitSet []) = return $ text "0"
 initExpr2C' (InitSet a) = return $ text "<<set>>"
-initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ 
+initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
     case e of
          (Identifier "LongInt" _) -> int (-2^31)
          (Identifier "SmallInt" _) -> int (-2^15)
@@ -515,7 +515,7 @@
 initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
 initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
 initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
-initExpr2C' b@(BuiltInFunction _ _) = error $ show b    
+initExpr2C' b@(BuiltInFunction _ _) = error $ show b
 initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
 
 
@@ -610,7 +610,7 @@
     e <- expr2C expr
     p1 <- (phrase2C . wrapPhrase) phrase1
     el <- elsePart
-    return $ 
+    return $
         text "if" <> parens e $+$ p1 $+$ el
     where
     elsePart | isNothing mphrase2 = return $ empty
@@ -634,7 +634,7 @@
                     e <- expr2C expr
                     return $ r <+> text "=" <+> e <> semi
                 _ -> error $ "Assignment to string from " ++ show lt
-        (BTArray _ _ _, _) -> phrase2C $ 
+        (BTArray _ _ _, _) -> phrase2C $
             ProcCall (FunCall
                 [
                 Reference $ Address ref
@@ -654,22 +654,22 @@
     e <- expr2C expr
     cs <- mapM case2C cases
     d <- dflt
-    return $ 
+    return $
         text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
     where
     case2C :: ([InitExpression], Phrase) -> State RenderState Doc
     case2C (e, p) = do
         ies <- mapM range2C e
         ph <- phrase2C p
-        return $ 
+        return $
              vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
     dflt | isNothing mphrase = return []
          | otherwise = do
              ph <- mapM phrase2C $ fromJust mphrase
              return [text "default:" <+> nest 4 (vcat ph)]
-                                         
+
 phrase2C wb@(WithBlock ref p) = do
-    r <- ref2C ref 
+    r <- ref2C ref
     t <- gets lastType
     case t of
         (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
@@ -680,7 +680,7 @@
     e1 <- expr2C e1'
     e2 <- expr2C e2'
     ph <- phrase2C (wrapPhrase p)
-    return $ 
+    return $
         text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i])
         $$
         ph
@@ -732,7 +732,7 @@
             -- aw, "LongInt" here is hwengine-specific hack
             i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
             ref2C $ FunCall [expr1, expr2] (SimpleReference i)
-        ("in", _, _) -> 
+        ("in", _, _) ->
             case expr2 of
                  SetExpression set -> do
                      ids <- mapM (id2C IOLookup) set
@@ -804,14 +804,14 @@
          BTArray {} -> return $ text "length_ar" <> parens e'
          _ -> error $ "length() called on " ++ show lt
 expr2C (BuiltInFunCall params ref) = do
-    r <- ref2C ref 
+    r <- ref2C ref
     t <- gets lastType
     ps <- mapM expr2C params
     case t of
         BTFunction _ t' -> do
             modify (\s -> s{lastType = t'})
         _ -> error $ "BuiltInFunCall lastType: " ++ show t
-    return $ 
+    return $
         r <> parens (hsep . punctuate (char ',') $ ps)
 expr2C a = error $ "Don't know how to render " ++ show a
 
@@ -844,7 +844,7 @@
 -- conversion routines
 ref2C ae@(ArrayElement [expr] ref) = do
     e <- expr2C expr
-    r <- ref2C ref 
+    r <- ref2C ref
     t <- gets lastType
     case t of
          (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
@@ -862,13 +862,13 @@
          _ -> return $ r <> brackets e
 ref2C (SimpleReference name) = id2C IOLookup name
 ref2C rf@(RecordField (Dereference ref1) ref2) = do
-    r1 <- ref2C ref1 
+    r1 <- ref2C ref1
     t <- fromPointer (show ref1) =<< gets lastType
     r2 <- case t of
         BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2
         BTUnit -> error "What??"
         a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
-    return $ 
+    return $
         r1 <> text "->" <> r2
 ref2C rf@(RecordField ref1 ref2) = do
     r1 <- ref2C ref1
@@ -898,7 +898,7 @@
     where
     fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
     fref2C a = ref2C a
-        
+
 ref2C (Address ref) = do
     r <- ref2C ref
     return $ text "&" <> parens r
@@ -909,7 +909,7 @@
         ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
         (a, _) -> do
             e <- expr2C expr
-            t <- id2C IOLookup t'    
+            t <- id2C IOLookup t'
             return . parens $ parens t <> e
 ref2C (RefExpression expr) = expr2C expr