tools/pas2c.hs
author unc0rr
Mon, 09 Apr 2012 23:36:23 +0400
changeset 6874 b9e2e509a42d
parent 6872 0f6eef4a07c8
child 6875 6528171ce36d
permissions -rw-r--r--
Better handle switch statement
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables #-}
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
     2
module Pas2C where
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
     3
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
     4
import Text.PrettyPrint.HughesPJ
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
     5
import Data.Maybe
6277
627b5752733a A try to improve parser move (has regressions)
unc0rr
parents: 6275
diff changeset
     6
import Data.Char
6511
bc6e67598dde Ok, State monad instead
unc0rr
parents: 6509
diff changeset
     7
import Text.Parsec.Prim hiding (State)
6417
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
     8
import Control.Monad.State
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
     9
import System.IO
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    10
import System.Directory
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    11
import Control.Monad.IO.Class
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    12
import PascalPreprocessor
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    13
import Control.Exception
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    14
import System.IO.Error
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    15
import qualified Data.Map as Map
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    16
import Data.List (find)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
    17
import Numeric
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
    18
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
    19
import PascalParser
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
    20
import PascalUnitSyntaxTree
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
    21
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    22
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    23
data InsertOption = 
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    24
    IOInsert
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    25
    | IOLookup
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    26
    | IODeferred
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    27
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    28
type Record = (String, (String, BaseType))
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    29
data RenderState = RenderState 
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    30
    {
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    31
        currentScope :: [Record],
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
    32
        lastIdentifier :: String,
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    33
        lastType :: BaseType,
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    34
        namespaces :: Map.Map String [Record]
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    35
    }
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    36
    
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
    37
emptyState = RenderState [] "" BTUnknown
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
    38
    
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    39
docToLower :: Doc -> Doc
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    40
docToLower = text . map toLower . render
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    41
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    42
pas2C :: String -> IO ()
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    43
pas2C fn = do
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    44
    setCurrentDirectory "../hedgewars/"
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    45
    s <- flip execStateT initState $ f fn
6514
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
    46
    renderCFiles s
6417
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    47
    where
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    48
    printLn = liftIO . hPutStrLn stderr
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    49
    print = liftIO . hPutStr stderr
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    50
    initState = Map.empty
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    51
    f :: String -> StateT (Map.Map String PascalUnit) IO ()
6417
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    52
    f fileName = do
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    53
        processed <- gets $ Map.member fileName
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    54
        unless processed $ do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    55
            print ("Preprocessing '" ++ fileName ++ ".pas'... ")
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    56
            fc' <- liftIO 
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    57
                $ tryJust (guard . isDoesNotExistError) 
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    58
                $ preprocess (fileName ++ ".pas")
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    59
            case fc' of
6453
11c578d30bd3 Countless imporvements to the parser and countless help to the parser in sources.
unc0rr
parents: 6450
diff changeset
    60
                (Left a) -> do
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    61
                    modify (Map.insert fileName (System []))
6453
11c578d30bd3 Countless imporvements to the parser and countless help to the parser in sources.
unc0rr
parents: 6450
diff changeset
    62
                    printLn "doesn't exist"
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    63
                (Right fc) -> do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    64
                    print "ok, parsing... "
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    65
                    let ptree = parse pascalUnit fileName fc
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    66
                    case ptree of
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    67
                         (Left a) -> do
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    68
                            liftIO $ writeFile "preprocess.out" fc
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    69
                            printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    70
                            fail "stop"
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    71
                         (Right a) -> do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    72
                            printLn "ok"
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    73
                            modify (Map.insert fileName a)
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    74
                            mapM_ f (usesFiles a)
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    75
6514
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
    76
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
    77
renderCFiles :: Map.Map String PascalUnit -> IO ()
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
    78
renderCFiles units = do
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
    79
    let u = Map.toList units
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    80
    let nss = Map.map (toNamespace nss) units
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
    81
    hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss)
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
    82
    --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    83
    mapM_ (toCFiles nss) u
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    84
    where
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    85
    toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record]
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    86
    toNamespace nss (System tvs) = 
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
    87
        currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss)
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    88
    toNamespace _ (Program {}) = []
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    89
    toNamespace nss (Unit _ interface _ _ _) = 
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
    90
        currentScope $ execState (interface2C interface) (emptyState nss)
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
    91
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
    92
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
    93
withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
    94
withState' f sf = do
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
    95
    st <- liftM f get
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
    96
    let (a, s) = runState sf st
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
    97
    modify(\st -> st{lastType = lastType s})
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
    98
    return a
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
    99
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   100
withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   101
withLastIdNamespace f = do
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   102
    li <- gets lastIdentifier
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   103
    nss <- gets namespaces
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   104
    withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   105
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   106
withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   107
withRecordNamespace _ [] = error "withRecordNamespace: empty record"
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   108
withRecordNamespace prefix recs = withState' f
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   109
    where
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   110
        f st = st{currentScope = records ++ currentScope st}
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   111
        records = map (\(a, b) -> (map toLower a, (prefix ++ a, b))) recs
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   112
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   113
toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO ()
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   114
toCFiles _ (_, System _) = return ()
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   115
toCFiles ns p@(fn, pu) = do
6474
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   116
    hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..."
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   117
    toCFiles' p
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   118
    where
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   119
    toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p
6854
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
   120
    toCFiles' (fn, (Unit unitId interface implementation _ _)) = do
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
   121
        let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   122
        writeFile (fn ++ ".h") $ "#pragma once\n\n" ++ (render a)
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   123
        writeFile (fn ++ ".c") $ "#include \"pas2c.h\"\n#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   124
    initialState = emptyState ns
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   125
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   126
    render2C :: RenderState -> State RenderState Doc -> String
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   127
    render2C a = render . flip evalState a
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   128
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   129
usesFiles :: PascalUnit -> [String]
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   130
usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   131
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   132
usesFiles (System {}) = []
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   133
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   134
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   135
pascal2C :: PascalUnit -> State RenderState Doc
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   136
pascal2C (Unit _ interface implementation init fin) =
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   137
    liftM2 ($+$) (interface2C interface) (implementation2C implementation)
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   138
    
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   139
pascal2C (Program _ implementation mainFunction) = do
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   140
    impl <- implementation2C implementation
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   141
    main <- tvar2C True 
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   142
        (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   143
    return $ impl $+$ main
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   144
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   145
    
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   146
    
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   147
interface2C :: Interface -> State RenderState Doc
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   148
interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   149
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   150
implementation2C :: Implementation -> State RenderState Doc
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   151
implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   152
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   153
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   154
typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   155
typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   156
6816
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   157
setBaseType :: BaseType -> Identifier -> Identifier
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   158
setBaseType bt (Identifier i _) = Identifier i bt
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   159
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   160
uses2C :: Uses -> State RenderState Doc
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   161
uses2C uses@(Uses unitIds) = do
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   162
    mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
6816
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   163
    mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   164
    return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   165
    where
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   166
    injectNamespace (Identifier i _) = do
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   167
        getNS <- gets (flip Map.lookup . namespaces)
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   168
        let f = flip (foldl (flip (:))) (fromMaybe [] (getNS i))
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   169
        modify (\s -> s{currentScope = f $ currentScope s})
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   170
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   171
uses2List :: Uses -> [String]
6489
e1f0058cfedd Add base type tags to identifiers
unc0rr
parents: 6474
diff changeset
   172
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   173
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   174
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   175
id2C :: InsertOption -> Identifier -> State RenderState Doc
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   176
id2C IOInsert (Identifier i t) = do
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   177
    ns <- gets currentScope
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   178
{--    case t of 
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   179
        BTUnknown -> do
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   180
            ns <- gets currentScope
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   181
            error $ "id2C IOInsert: type BTUnknown for " ++ show i ++ "\nnamespace: " ++ show (take 100 ns)
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   182
        _ -> do --}
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   183
    modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n})
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   184
    return $ text i
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   185
    where
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   186
        n = map toLower i
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   187
id2C IOLookup (Identifier i t) = do
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   188
    let i' = map toLower i
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   189
    v <- gets $ find (\(a, _) -> a == i') . currentScope
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   190
    ns <- gets currentScope
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   191
    lt <- gets lastType
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   192
    if isNothing v then 
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   193
        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\n" ++ show (take 100 ns)
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   194
        else 
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   195
        let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   196
id2C IODeferred (Identifier i t) = do
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   197
    let i' = map toLower i
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   198
    v <- gets $ find (\(a, _) -> a == i') . currentScope
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   199
    if (isNothing v) then
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   200
        return $ text i
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   201
        else
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   202
        return . text . fst . snd . fromJust $ v
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   203
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   204
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   205
id2CTyped t (Identifier i _) = do
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   206
    tb <- resolveType t
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   207
    ns <- gets currentScope
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   208
    case tb of 
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   209
        BTUnknown -> do
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   210
            ns <- gets currentScope
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   211
            error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show (take 100 ns)
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   212
        _ -> return ()
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   213
    id2C IOInsert (Identifier i tb)
6626
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   214
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   215
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   216
resolveType :: TypeDecl -> State RenderState BaseType
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   217
resolveType st@(SimpleType (Identifier i _)) = do
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   218
    let i' = map toLower i
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   219
    v <- gets $ find (\(a, _) -> a == i') . currentScope
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   220
    if isJust v then return . snd . snd $ fromJust v else return $ f i'
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   221
    where
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   222
    f "integer" = BTInt
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   223
    f "pointer" = BTPointerTo BTVoid
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   224
    f "boolean" = BTBool
6649
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   225
    f "float" = BTFloat
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   226
    f "char" = BTChar
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   227
    f "string" = BTString
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   228
    f _ = error $ "Unknown system type: " ++ show st
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   229
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   230
resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
6626
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   231
resolveType (RecordType tv mtvs) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   232
    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   233
    return . BTRecord . concat $ tvs
6626
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   234
    where
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   235
        f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   236
        f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
6626
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   237
resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   238
resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   239
resolveType (FunctionType t _) = liftM BTFunction $ resolveType t
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   240
resolveType (DeriveType (InitHexNumber _)) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   241
resolveType (DeriveType (InitNumber _)) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   242
resolveType (DeriveType (InitFloat _)) = return BTFloat
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   243
resolveType (DeriveType (InitString _)) = return BTString
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   244
resolveType (DeriveType (InitBinOp {})) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   245
resolveType (DeriveType (InitPrefixOp {})) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   246
resolveType (DeriveType (BuiltInFunction{})) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   247
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   248
resolveType (DeriveType _) = return BTUnknown
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   249
resolveType (String _) = return BTString
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   250
resolveType VoidType = return BTVoid
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   251
resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   252
resolveType (RangeType _) = return $ BTVoid
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   253
resolveType (Set t) = liftM BTSet $ resolveType t
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   254
   
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   255
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   256
fromPointer :: String -> BaseType -> State RenderState BaseType    
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   257
fromPointer s (BTPointerTo t) = f t
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   258
    where
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   259
        f (BTUnresolved s) = do
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   260
            v <- gets $ find (\(a, _) -> a == s) . currentScope
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   261
            if isJust v then
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   262
                f . snd . snd . fromJust $ v
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   263
                else
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   264
                error $ "Unknown type " ++ show t ++ "\n" ++ s
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   265
        f t = return t
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   266
fromPointer s t = do
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   267
    ns <- gets currentScope
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   268
    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s ++ "\n\n" ++ show (take 100 ns)
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   269
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   270
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   271
tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   272
tvar2C _ (FunctionDeclaration name returnType params Nothing) = do
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   273
    t <- type2C returnType 
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   274
    t'<- gets lastType
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   275
    p <- withState' id $ liftM hcat $ mapM (tvar2C False) params
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   276
    n <- id2C IOInsert $ setBaseType (BTFunction t') name
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   277
    return $ t <+> n <> parens p <> text ";"
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   278
    
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   279
tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   280
    t <- type2C returnType
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   281
    t'<- gets lastType
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   282
    n <- id2C IOInsert $ setBaseType (BTFunction t') name
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   283
    (p, ph) <- withState' (\st -> st{currentScope = (lastIdentifier st, (lastIdentifier st ++ "_result", t')) : currentScope st}) $ do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   284
        p <- liftM hcat $ mapM (tvar2C False) params
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   285
        ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   286
        return (p, ph)
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   287
    let res = docToLower $ n <> text "_result"
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   288
    let phrasesBlock = case returnType of
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   289
            VoidType -> ph
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   290
            _ -> t <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   291
    return $ 
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   292
        t <+> n <> parens p
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   293
        $+$
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   294
        text "{" 
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   295
        $+$ 
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   296
        nest 4 phrasesBlock
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   297
        $+$
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   298
        text "}"
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   299
    where
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   300
    phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   301
    phrase2C' p = phrase2C p
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   302
    
6489
e1f0058cfedd Add base type tags to identifiers
unc0rr
parents: 6474
diff changeset
   303
tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   304
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   305
tvar2C _ td@(TypeDeclaration i' t) = do
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   306
    i <- id2CTyped t i'
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   307
    tp <- type2C t
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   308
    return $ text "typedef" <+> i <+> tp <> semi
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   309
    
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   310
tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   311
    t' <- type2C t
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   312
    i <- mapM (id2CTyped t) ids
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   313
    ie <- initExpr mInitExpr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   314
    return $ if isConst then text "const" else empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   315
        <+> t'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   316
        <+> (hsep . punctuate (char ',') $ i)
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   317
        <+> ie
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   318
        <> text ";"
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   319
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   320
    initExpr Nothing = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   321
    initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   322
    
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   323
tvar2C f (OperatorDeclaration op i ret params body) = 
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   324
    tvar2C f (FunctionDeclaration i ret params body)
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   325
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   326
    
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   327
initExpr2C :: InitExpression -> State RenderState Doc
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   328
initExpr2C InitNull = return $ text "NULL"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   329
initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr)
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   330
initExpr2C (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C expr)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   331
initExpr2C (InitBinOp op expr1 expr2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   332
    e1 <- initExpr2C expr1
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   333
    e2 <- initExpr2C expr2
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   334
    return $ parens $ e1 <+> text (op2C op) <+> e2
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   335
initExpr2C (InitNumber s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   336
initExpr2C (InitFloat s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   337
initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   338
initExpr2C (InitString [a]) = return . quotes $ text [a]
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   339
initExpr2C (InitString s) = return $ doubleQuotes $ text s 
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   340
initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   341
initExpr2C (InitReference i) = id2C IOLookup i
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   342
initExpr2C (InitRecord fields) = do
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   343
    (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   344
    return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   345
initExpr2C (InitArray [value]) = initExpr2C value
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   346
initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   347
initExpr2C (InitRange (Range i)) = id2C IOLookup i
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   348
initExpr2C (InitRange a) = return $ text "<<range>>"
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   349
initExpr2C (InitSet []) = return $ text "0"
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   350
initExpr2C (InitSet a) = return $ text "<<set>>"
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   351
initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>"
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   352
initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   353
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   354
range2C :: InitExpression -> State RenderState [Doc]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   355
range2C (InitString [a]) = return [quotes $ text [a]]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   356
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   357
range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   358
    
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   359
range2C a = liftM (flip (:) []) $ initExpr2C a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   360
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   361
type2C :: TypeDecl -> State RenderState Doc
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   362
type2C (SimpleType i) = id2C IOLookup i
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   363
type2C t = do
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   364
    r <- type2C' t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   365
    rt <- resolveType t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   366
    modify (\st -> st{lastType = rt})
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   367
    return r
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   368
    where
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   369
    type2C' VoidType = return $ text "void"
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   370
    type2C' (String l) = return $ text $ "string" ++ show l
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   371
    type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   372
    type2C' (PointerTo t) = liftM (<> text "*") $ type2C t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   373
    type2C' (RecordType tvs union) = do
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   374
        t <- withState' id $ mapM (tvar2C False) tvs
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   375
        return $ lbrace $+$ (nest 4 . vcat $ t) $+$ rbrace
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   376
    type2C' (RangeType r) = return $ text "<<range type>>"
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   377
    type2C' (Sequence ids) = do
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   378
        mapM_ (id2C IOInsert) ids
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   379
        return $ text "<<sequence type>>"
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   380
    type2C' (ArrayDecl r t) = do
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   381
        t' <- type2C t
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   382
        return $ t' <> brackets (text "<<range>>")
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   383
    type2C' (Set t) = return $ text "<<set>>"
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   384
    type2C' (FunctionType returnType params) = return $ text "<<function>>"
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   385
    type2C' (DeriveType (InitBinOp {})) = return $ text "int"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   386
    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   387
    type2C' (DeriveType (InitNumber _)) = return $ text "int"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   388
    type2C' (DeriveType (InitHexNumber _)) = return $ text "int"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   389
    type2C' (DeriveType (InitFloat _)) = return $ text "float"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   390
    type2C' (DeriveType (BuiltInFunction {})) = return $ text "int"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   391
    type2C' (DeriveType (InitString {})) = return $ text "string255"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   392
    type2C' (DeriveType (InitReference {})) = return $ text "<<some type>>"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   393
    type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   394
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   395
phrase2C :: Phrase -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   396
phrase2C (Phrases p) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   397
    ps <- mapM phrase2C p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   398
    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   399
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   400
phrase2C (ProcCall ref params) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   401
    r <- ref2C ref
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   402
    ps <- mapM expr2C params
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   403
    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   404
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   405
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   406
    p1 <- (phrase2C . wrapPhrase) phrase1
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   407
    el <- elsePart
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   408
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   409
        text "if" <> parens e $+$ p1 $+$ el
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   410
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   411
    elsePart | isNothing mphrase2 = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   412
             | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   413
phrase2C (Assignment ref expr) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   414
    r <- ref2C ref 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   415
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   416
    return $
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   417
        r <> text " = " <> e <> semi
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   418
phrase2C (WhileCycle expr phrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   419
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   420
    p <- phrase2C $ wrapPhrase phrase
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   421
    return $ text "while" <> parens e $$ p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   422
phrase2C (SwitchCase expr cases mphrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   423
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   424
    cs <- mapM case2C cases
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   425
    d <- dflt
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   426
    return $ 
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   427
        text "switch" <> parens e <> text "of" $+$ braces (nest 4 . vcat $ cs ++ d)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   428
    where
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   429
    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   430
    case2C (e, p) = do
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   431
        ies <- mapM range2C e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   432
        ph <- phrase2C p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   433
        return $ 
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   434
             vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   435
    dflt | isNothing mphrase = return []
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   436
         | otherwise = do
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   437
             ph <- mapM phrase2C $ fromJust mphrase
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   438
             return [text "default:" <+> nest 4 (vcat ph)]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   439
                                         
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   440
phrase2C wb@(WithBlock ref p) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   441
    r <- ref2C ref 
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   442
    t <- gets lastType
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   443
    case t of
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   444
        (BTRecord rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   445
        a -> do
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   446
            ns <- gets currentScope
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   447
            error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb ++ "\nnamespace: " ++ show (take 100 ns)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   448
phrase2C (ForCycle i' e1' e2' p) = do
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   449
    i <- id2C IOLookup i'
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   450
    e1 <- expr2C e1'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   451
    e2 <- expr2C e2'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   452
    ph <- phrase2C (wrapPhrase p)
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   453
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   454
        text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i])
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   455
        $$
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   456
        ph
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   457
phrase2C (RepeatCycle e' p') = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   458
    e <- expr2C e'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   459
    p <- phrase2C (Phrases p')
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   460
    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e)
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   461
phrase2C NOP = return $ text ";"
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   462
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   463
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   464
wrapPhrase p@(Phrases _) = p
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   465
wrapPhrase p = Phrases [p]
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   466
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   467
expr2C :: Expression -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   468
expr2C (Expression s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   469
expr2C (BinOp op expr1 expr2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   470
    e1 <- expr2C expr1
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   471
    t1 <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   472
    e2 <- expr2C expr2
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   473
    case (op2C op, t1) of
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   474
        ("+", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString))
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   475
        ("==", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool))
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   476
        ("!=", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool))
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   477
        ("&", BTBool) -> return $ parens $ e1 <+> text "&&" <+> e2
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   478
        ("|", BTBool) -> return $ parens $ e1 <+> text "||" <+> e2
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   479
        (o, _) -> return $ parens $ e1 <+> text o <+> e2
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   480
expr2C (NumberLiteral s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   481
expr2C (FloatLiteral s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   482
expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   483
expr2C (StringLiteral [a]) = return . quotes $ text [a]
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   484
expr2C (StringLiteral s) = return $ doubleQuotes $ text s 
6277
627b5752733a A try to improve parser move (has regressions)
unc0rr
parents: 6275
diff changeset
   485
expr2C (Reference ref) = ref2C ref
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   486
expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   487
expr2C Null = return $ text "NULL"
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   488
expr2C (BuiltInFunCall params ref) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   489
    r <- ref2C ref 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   490
    ps <- mapM expr2C params
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   491
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   492
        r <> parens (hsep . punctuate (char ',') $ ps)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   493
expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   494
expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   495
expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   496
expr2C a = error $ "Don't know how to render " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   497
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   498
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   499
ref2C :: Reference -> State RenderState Doc
6854
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
   500
-- rewrite into proper form
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   501
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   502
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   503
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   504
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   505
ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
6854
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
   506
-- conversion routines
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   507
ref2C ae@(ArrayElement exprs ref) = do
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   508
    es <- mapM expr2C exprs
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   509
    r <- ref2C ref 
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   510
    t <- gets lastType
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   511
    ns <- gets currentScope
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   512
    case t of
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   513
         (BTArray _ t') -> modify (\st -> st{lastType = t'})
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   514
         (BTString) -> modify (\st -> st{lastType = BTChar})
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   515
         (BTPointerTo t) -> do
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   516
                t'' <- fromPointer (show t) =<< gets lastType
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   517
                case t'' of
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   518
                     BTChar -> modify (\st -> st{lastType = BTChar})
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   519
                     a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns)
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   520
         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   521
    return $ r <> (brackets . hcat) (punctuate comma es)
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   522
ref2C (SimpleReference name) = id2C IOLookup name
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   523
ref2C rf@(RecordField (Dereference ref1) ref2) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   524
    r1 <- ref2C ref1 
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   525
    t <- fromPointer (show ref1) =<< gets lastType
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   526
    ns <- gets currentScope
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   527
    r2 <- case t of
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   528
        BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   529
        BTUnit -> withLastIdNamespace $ ref2C ref2
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   530
        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   531
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   532
        r1 <> text "->" <> r2
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   533
ref2C rf@(RecordField ref1 ref2) = do
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   534
    r1 <- ref2C ref1
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   535
    t <- gets lastType
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   536
    ns <- gets currentScope
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   537
    r2 <- case t of
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   538
        BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   539
        BTUnit -> withLastIdNamespace $ ref2C ref2
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   540
        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   541
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   542
        r1 <> text "." <> r2
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   543
ref2C d@(Dereference ref) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   544
    r <- ref2C ref
6855
807156c01475 Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents: 6854
diff changeset
   545
    t <- fromPointer (show d) =<< gets lastType
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   546
    modify (\st -> st{lastType = t})
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   547
    return $ (parens $ text "*" <> r)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   548
ref2C (FunCall params ref) = do
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   549
    ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   550
    r <- ref2C ref
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   551
    t <- gets lastType
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   552
    case t of
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   553
        BTFunction t -> do
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   554
            modify (\s -> s{lastType = t})
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   555
            return $ r <> ps
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   556
        _ -> return $ parens r <> ps
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   557
        
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   558
ref2C (Address ref) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   559
    r <- ref2C ref
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   560
    return $ text "&" <> parens r
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   561
ref2C (TypeCast t' expr) = do
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   562
    t <- id2C IOLookup t'
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   563
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   564
    return $ parens t <> e
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   565
ref2C (RefExpression expr) = expr2C expr
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   566
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   567
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   568
op2C :: String -> String
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   569
op2C "or" = "|"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   570
op2C "and" = "&"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   571
op2C "not" = "!"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   572
op2C "xor" = "^"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   573
op2C "div" = "/"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   574
op2C "mod" = "%"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   575
op2C "shl" = "<<"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   576
op2C "shr" = ">>"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   577
op2C "<>" = "!="
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   578
op2C "=" = "=="
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   579
op2C a = a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   580