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