tools/pas2c.hs
author unc0rr
Tue, 01 May 2012 20:54:02 +0400
changeset 6980 07a710e22846
parent 6979 cd28fe36170a
child 7002 5d817ba976f7
permissions -rw-r--r--
Better type deriving
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,
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    34
        stringConsts :: [(String, String)],
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    35
        uniqCounter :: Int,
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    36
        namespaces :: Map.Map String [Record]
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    37
    }
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    38
    
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    39
emptyState = RenderState [] "" BTUnknown [] 0
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    40
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    41
getUniq :: State RenderState Int
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    42
getUniq = do
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    43
    i <- gets uniqCounter
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    44
    modify(\s -> s{uniqCounter = uniqCounter s + 1})
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    45
    return i
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    46
    
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    47
addStringConst :: String -> State RenderState Doc
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    48
addStringConst str = do
6921
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    49
    strs <- gets stringConsts
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    50
    let a = find ((==) str . snd) strs
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    51
    if isJust a then
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
    52
        do
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
    53
        modify (\s -> s{lastType = BTString})
6921
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    54
        return . text . fst . fromJust $ a
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    55
    else
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    56
        do
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    57
        i <- getUniq
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    58
        let sn = "__str" ++ show i
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    59
        modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    60
        return $ text sn
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    61
    
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    62
escapeStr :: String -> String
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    63
escapeStr = foldr escapeChar []
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    64
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    65
escapeChar :: Char -> ShowS
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    66
escapeChar '"' s = "\\\"" ++ s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    67
escapeChar a s = a : s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    68
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    69
strInit :: String -> Doc
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    70
strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    71
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    72
renderStringConsts :: State RenderState Doc
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    73
renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi)) 
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    74
    $ gets stringConsts
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
    75
    
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    76
docToLower :: Doc -> Doc
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    77
docToLower = text . map toLower . render
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    78
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
    79
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
    80
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
    81
    setCurrentDirectory "../hedgewars/"
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    82
    s <- flip execStateT initState $ f fn
6514
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
    83
    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
    84
    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
    85
    printLn = liftIO . hPutStrLn stderr
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    86
    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
    87
    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
    88
    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
    89
    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
    90
        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
    91
        unless processed $ do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    92
            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
    93
            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
    94
                $ tryJust (guard . isDoesNotExistError) 
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
    95
                $ 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
    96
            case fc' of
6453
11c578d30bd3 Countless imporvements to the parser and countless help to the parser in sources.
unc0rr
parents: 6450
diff changeset
    97
                (Left a) -> do
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    98
                    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
    99
                    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
   100
                (Right fc) -> do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
   101
                    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
   102
                    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
   103
                    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
   104
                         (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
   105
                            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
   106
                            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
   107
                            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
   108
                         (Right a) -> do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
   109
                            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
   110
                            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
   111
                            mapM_ f (usesFiles a)
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
   112
6514
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
   113
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
   114
renderCFiles :: Map.Map String PascalUnit -> IO ()
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
   115
renderCFiles units = do
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
   116
    let u = Map.toList units
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   117
    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
   118
    hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss)
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   119
    --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
   120
    mapM_ (toCFiles nss) u
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   121
    where
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   122
    toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record]
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   123
    toNamespace nss (System tvs) = 
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   124
        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
   125
    toNamespace _ (Program {}) = []
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   126
    toNamespace nss (Unit _ interface _ _ _) = 
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   127
        currentScope $ execState (interface2C interface) (emptyState nss)
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   128
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   129
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   130
withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   131
withState' f sf = do
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   132
    st <- liftM f get
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   133
    let (a, s) = runState sf st
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   134
    modify(\st -> st{
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   135
        lastType = lastType s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   136
        , uniqCounter = uniqCounter s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   137
        , stringConsts = stringConsts s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   138
        })
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   139
    return a
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   140
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   141
withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   142
withLastIdNamespace f = do
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   143
    li <- gets lastIdentifier
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   144
    nss <- gets namespaces
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   145
    withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   146
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   147
withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   148
withRecordNamespace _ [] = error "withRecordNamespace: empty record"
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   149
withRecordNamespace prefix recs = withState' f
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   150
    where
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   151
        f st = st{currentScope = records ++ currentScope st}
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   152
        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
   153
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   154
toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO ()
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   155
toCFiles _ (_, System _) = return ()
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   156
toCFiles ns p@(fn, pu) = do
6474
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   157
    hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..."
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   158
    toCFiles' p
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   159
    where
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   160
    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
   161
    toCFiles' (fn, (Unit unitId interface implementation _ _)) = do
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
   162
        let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState
6883
70aec33185e2 Support string constants
unc0rr
parents: 6880
diff changeset
   163
        writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
70aec33185e2 Support string constants
unc0rr
parents: 6880
diff changeset
   164
        writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   165
    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
   166
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   167
    render2C :: RenderState -> State RenderState Doc -> String
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   168
    render2C a = render . ($+$ empty) . 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
   169
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   170
usesFiles :: PascalUnit -> [String]
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   171
usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   172
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   173
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
   174
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
   175
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   176
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
   177
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
   178
    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
   179
    
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   180
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
   181
    impl <- implementation2C implementation
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   182
    [main] <- tvar2C True 
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   183
        (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
   184
    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
   185
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   186
    
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   187
    
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   188
interface2C :: Interface -> State RenderState Doc
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   189
interface2C (Interface uses tvars) = do
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   190
    u <- uses2C uses
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   191
    tv <- typesAndVars2C True tvars
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   192
    r <- renderStringConsts
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   193
    return (u $+$ r $+$ tv)
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   194
    
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   195
implementation2C :: Implementation -> State RenderState Doc
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   196
implementation2C (Implementation uses tvars) = do
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   197
    u <- uses2C uses
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   198
    tv <- typesAndVars2C True tvars
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   199
    r <- renderStringConsts
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   200
    return (u $+$ r $+$ tv)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   201
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   202
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   203
typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   204
typesAndVars2C b (TypesAndVars ts) = liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   205
6816
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   206
setBaseType :: BaseType -> Identifier -> Identifier
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   207
setBaseType bt (Identifier i _) = Identifier i bt
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   208
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   209
uses2C :: Uses -> State RenderState Doc
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   210
uses2C uses@(Uses unitIds) = do
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   211
    mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
6816
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   212
    mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   213
    return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   214
    where
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   215
    injectNamespace (Identifier i _) = do
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   216
        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
   217
        let f = flip (foldl (flip (:))) (fromMaybe [] (getNS i))
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   218
        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
   219
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
   220
uses2List :: Uses -> [String]
6489
e1f0058cfedd Add base type tags to identifiers
unc0rr
parents: 6474
diff changeset
   221
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   222
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   223
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   224
id2C :: InsertOption -> Identifier -> State RenderState Doc
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   225
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
   226
    ns <- gets currentScope
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   227
{--    case t of 
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   228
        BTUnknown -> do
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   229
            ns <- gets currentScope
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   230
            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
   231
        _ -> do --}
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   232
    modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n})
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   233
    return $ text i
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   234
    where
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   235
        n = map toLower i
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   236
id2C IOLookup (Identifier i t) = do
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   237
    let i' = map toLower i
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   238
    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
   239
    ns <- gets currentScope
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   240
    lt <- gets lastType
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   241
    if isNothing v then 
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   242
        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\n" ++ show (take 100 ns)
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   243
        else 
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   244
        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
   245
id2C IODeferred (Identifier i t) = do
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   246
    let i' = map toLower i
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   247
    v <- gets $ find (\(a, _) -> a == i') . currentScope
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   248
    if (isNothing v) then
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   249
        return $ text i
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   250
        else
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   251
        return . text . fst . snd . fromJust $ v
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   252
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   253
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   254
id2CTyped t (Identifier i _) = do
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   255
    tb <- resolveType t
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   256
    ns <- gets currentScope
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   257
    case tb of 
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   258
        BTUnknown -> do
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   259
            ns <- gets currentScope
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   260
            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
   261
        _ -> return ()
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   262
    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
   263
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   264
a447993f2ad7 Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents: 6618
diff changeset
   265
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
   266
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
   267
    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
   268
    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
   269
    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
   270
    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
   271
    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
   272
    f "pointer" = BTPointerTo BTVoid
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   273
    f "boolean" = BTBool
6649
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   274
    f "float" = BTFloat
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   275
    f "char" = BTChar
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   276
    f "string" = BTString
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   277
    f _ = error $ "Unknown system type: " ++ show st
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   278
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   279
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
   280
resolveType (RecordType tv mtvs) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   281
    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   282
    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
   283
    where
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   284
        f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   285
        f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   286
resolveType (ArrayDecl (Just i) t) = do
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   287
    t' <- resolveType t
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   288
    return $ BTArray i BTInt t' 
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   289
resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   290
resolveType (FunctionType t _) = liftM BTFunction $ resolveType t
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   291
resolveType (DeriveType (InitHexNumber _)) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   292
resolveType (DeriveType (InitNumber _)) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   293
resolveType (DeriveType (InitFloat _)) = return BTFloat
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   294
resolveType (DeriveType (InitString _)) = return BTString
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   295
resolveType (DeriveType (InitBinOp {})) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   296
resolveType (DeriveType (InitPrefixOp {})) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   297
resolveType (DeriveType (BuiltInFunction{})) = return BTInt
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   298
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   299
resolveType (DeriveType _) = return BTUnknown
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   300
resolveType (String _) = return BTString
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   301
resolveType VoidType = return BTVoid
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   302
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
   303
resolveType (RangeType _) = return $ BTVoid
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   304
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
   305
   
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   306
6967
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   307
resolve :: String -> BaseType -> State RenderState BaseType
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   308
resolve s (BTUnresolved t) = do
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   309
    v <- gets $ find (\(a, _) -> a == t) . currentScope
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   310
    if isJust v then
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   311
        resolve s . snd . snd . fromJust $ v
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   312
        else
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   313
        error $ "Unknown type " ++ show t ++ "\n" ++ s
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   314
resolve _ t = return t
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   315
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   316
fromPointer :: String -> BaseType -> State RenderState BaseType
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   317
fromPointer s (BTPointerTo t) = resolve s t
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   318
fromPointer s (BTFunctionReturn _ (BTPointerTo t)) = resolve s 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
   319
fromPointer s t = do
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   320
    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
   321
    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
   322
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   323
    
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   324
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   325
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   326
fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   327
fun2C _ _ (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
   328
    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
   329
    t'<- gets lastType
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   330
    p <- withState' id $ functionParams2C 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
   331
    n <- id2C IOInsert $ setBaseType (BTFunction t') name
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   332
    return [t empty <+> n <> parens p]
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   333
    
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   334
fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   335
    let res = docToLower $ text rv <> text "_result"
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   336
    t <- type2C returnType
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   337
    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
   338
    n <- id2C IOInsert $ setBaseType (BTFunction t') name
6967
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   339
    (p, ph) <- withState' (\st -> st{currentScope = (map toLower rv, (render res, BTFunctionReturn (render n) t')) : currentScope st}) $ do
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   340
        p <- functionParams2C params
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   341
        ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   342
        return (p, ph)
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   343
    let phrasesBlock = case returnType of
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   344
            VoidType -> ph
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   345
            _ -> t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   346
    return [ 
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   347
        t empty <+> 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
   348
        $+$
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   349
        text "{" 
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   350
        $+$ 
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   351
        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
   352
        $+$
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   353
        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
   354
    where
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   355
    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
   356
    phrase2C' p = phrase2C p
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   357
    
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   358
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   359
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   360
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   361
tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc]
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   362
tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) =
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   363
    fun2C b name f
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   364
tvar2C _ td@(TypeDeclaration i' t) = do
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   365
    i <- id2CTyped t i'
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   366
    tp <- case t of
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   367
        FunctionType {} -> type2C (PointerTo t)
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   368
        _ -> type2C t
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   369
    return [text "typedef" <+> tp i]
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   370
    
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   371
tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   372
    t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   373
    ie <- initExpr mInitExpr
6979
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   374
    lt <- gets lastType
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   375
    case (isConst, lt, ids, mInitExpr) of
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   376
         (True, BTInt, [i], Just _) -> do
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   377
             i' <- id2CTyped t i
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   378
             return [text "enum" <> braces (i' <+> ie)]
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   379
         _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   380
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   381
    initExpr Nothing = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   382
    initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   383
    
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   384
tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   385
    r <- op2CTyped op (extractTypes params)
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   386
    fun2C f i (FunctionDeclaration r ret params body)
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   387
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   388
    
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   389
op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   390
op2CTyped op t = do
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   391
    t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   392
    bt <- gets lastType
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   393
    return $ case bt of
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   394
         BTRecord {} -> Identifier (t' ++ "_op_" ++ opStr) bt
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   395
         _ -> Identifier t' bt
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   396
    where 
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   397
    opStr = case op of
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   398
                    "+" -> "add"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   399
                    "-" -> "sub"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   400
                    "*" -> "mul"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   401
                    "/" -> "div"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   402
                    "=" -> "eq"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   403
                    "<" -> "lt"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   404
                    ">" -> "gt"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   405
                    _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   406
    
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   407
extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   408
extractTypes = concatMap f
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   409
    where
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   410
        f (VarDeclaration _ (ids, t) _) = replicate (length ids) t
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   411
        f a = error $ "extractTypes: can't extract from " ++ show a
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   412
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   413
initExpr2C :: InitExpression -> State RenderState Doc
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   414
initExpr2C InitNull = return $ text "NULL"
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   415
initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr)
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   416
initExpr2C (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C expr)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   417
initExpr2C (InitBinOp op expr1 expr2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   418
    e1 <- initExpr2C expr1
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   419
    e2 <- initExpr2C expr2
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   420
    return $ parens $ e1 <+> text (op2C op) <+> e2
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   421
initExpr2C (InitNumber s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   422
initExpr2C (InitFloat s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   423
initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   424
initExpr2C (InitString [a]) = return . quotes $ text [a]
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   425
initExpr2C (InitString s) = return $ strInit s
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   426
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
   427
initExpr2C (InitReference i) = id2C IOLookup i
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   428
initExpr2C (InitRecord fields) = do
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   429
    (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   430
    return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   431
initExpr2C (InitArray [value]) = initExpr2C value
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   432
initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   433
initExpr2C r@(InitRange (Range i@(Identifier i' _))) = do
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   434
    id2C IOLookup i
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   435
    t <- gets lastType
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   436
    case t of
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   437
         BTEnum s -> return . int $ length s
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   438
         BTInt -> case i' of
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   439
                       "byte" -> return $ int 256
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   440
                       _ -> error $ "InitRange identifier: " ++ i'
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   441
         _ -> error $ "InitRange: " ++ show r
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   442
initExpr2C (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   443
initExpr2C (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   444
initExpr2C (InitRange a) = error $ show a --return $ text "<<range>>"
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   445
initExpr2C (InitSet []) = return $ text "0"
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   446
initExpr2C (InitSet a) = return $ text "<<set>>"
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   447
initExpr2C (BuiltInFunction "low" [InitReference e]) = return $ 
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   448
    case e of
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   449
         (Identifier "LongInt" _) -> int (-2^31)
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   450
         (Identifier "SmallInt" _) -> int (-2^15)
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   451
         _ -> error $ "BuiltInFunction 'low': " ++ show e
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   452
initExpr2C (BuiltInFunction "high" [e]) = do
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   453
    initExpr2C e
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   454
    t <- gets lastType
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   455
    case t of
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   456
         (BTArray i _ _) -> initExpr2C $ BuiltInFunction "pred" [InitRange i]
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   457
         a -> error $ "BuiltInFunction 'high': " ++ show a
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   458
initExpr2C (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C e
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   459
initExpr2C (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C e
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   460
initExpr2C (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C e
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   461
initExpr2C (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C e
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   462
initExpr2C b@(BuiltInFunction _ _) = error $ show b    
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   463
initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   464
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   465
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   466
range2C :: InitExpression -> State RenderState [Doc]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   467
range2C (InitString [a]) = return [quotes $ text [a]]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   468
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   469
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
   470
range2C a = liftM (flip (:) []) $ initExpr2C a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   471
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   472
baseType2C :: String -> BaseType -> Doc
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   473
baseType2C _ BTFloat = text "float"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   474
baseType2C _ BTBool = text "bool"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   475
baseType2C _ BTString = text "string255"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   476
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   477
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   478
type2C :: TypeDecl -> State RenderState (Doc -> Doc)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   479
type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   480
type2C t = do
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   481
    r <- type2C' t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   482
    rt <- resolveType t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   483
    modify (\st -> st{lastType = rt})
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   484
    return r
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   485
    where
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   486
    type2C' VoidType = return (text "void" <+>)
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   487
    type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   488
    type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct __" <> i <+> text "*" <+> a) $ id2C IODeferred i
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   489
    type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   490
    type2C' (RecordType tvs union) = do
6843
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   491
        t <- withState' id $ mapM (tvar2C False) tvs
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   492
        u <- unions
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   493
        return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   494
        where
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   495
            unions = case union of
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   496
                     Nothing -> return empty
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   497
                     Just a -> do
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   498
                         structs <- mapM struct2C a
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   499
                         return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   500
            struct2C tvs = do
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   501
                t <- withState' id $ mapM (tvar2C False) tvs
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   502
                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
6894
555a8d8db228 Some more progress with pas2c
unc0rr
parents: 6893
diff changeset
   503
    type2C' (RangeType r) = return (text "int" <+>)
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   504
    type2C' (Sequence ids) = do
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   505
        is <- mapM (id2C IOInsert . setBaseType bt) ids
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   506
        return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [1..]) <+>)
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   507
        where
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   508
            bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
6894
555a8d8db228 Some more progress with pas2c
unc0rr
parents: 6893
diff changeset
   509
    type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   510
    type2C' (ArrayDecl (Just r) t) = do
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   511
        t' <- type2C t
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   512
        r' <- initExpr2C (InitRange r)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   513
        return $ \i -> t' i <> brackets r'
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   514
    type2C' (Set t) = return (text "<<set>>" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   515
    type2C' (FunctionType returnType params) = do
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   516
        t <- type2C returnType
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   517
        p <- withState' id $ functionParams2C params
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   518
        return (\i -> t empty <+> i <> parens p)
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   519
    type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   520
    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   521
    type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   522
    type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   523
    type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   524
    type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   525
    type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   526
    type2C' (DeriveType r@(InitReference {})) = do
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   527
        initExpr2C r
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   528
        t <- gets lastType
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   529
        return (baseType2C (show r) t <+>)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   530
    type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   531
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   532
phrase2C :: Phrase -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   533
phrase2C (Phrases p) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   534
    ps <- mapM phrase2C p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   535
    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   536
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   537
phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   538
phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   539
    r <- ref2C ref
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   540
    ps <- mapM expr2C params
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   541
    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   542
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   543
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   544
    p1 <- (phrase2C . wrapPhrase) phrase1
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   545
    el <- elsePart
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   546
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   547
        text "if" <> parens e $+$ p1 $+$ el
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   548
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   549
    elsePart | isNothing mphrase2 = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   550
             | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   551
phrase2C (Assignment ref expr) = do
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   552
    r <- ref2C ref
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   553
    t <- gets lastType
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   554
    e <- case (t, expr) of
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   555
         (BTFunction _, (Reference r')) -> ref2C r'
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   556
         _ -> expr2C expr
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   557
    return $ r <+> text "=" <+> e <> semi
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   558
phrase2C (WhileCycle expr phrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   559
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   560
    p <- phrase2C $ wrapPhrase phrase
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   561
    return $ text "while" <> parens e $$ p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   562
phrase2C (SwitchCase expr cases mphrase) = do
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
    cs <- mapM case2C cases
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   565
    d <- dflt
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   566
    return $ 
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   567
        text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   568
    where
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   569
    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   570
    case2C (e, p) = do
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   571
        ies <- mapM range2C e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   572
        ph <- phrase2C p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   573
        return $ 
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   574
             vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   575
    dflt | isNothing mphrase = return []
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   576
         | otherwise = do
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   577
             ph <- mapM phrase2C $ fromJust mphrase
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   578
             return [text "default:" <+> nest 4 (vcat ph)]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   579
                                         
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   580
phrase2C wb@(WithBlock ref p) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   581
    r <- ref2C ref 
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   582
    t <- gets lastType
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   583
    case t of
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   584
        (BTRecord rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   585
        a -> do
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   586
            ns <- gets currentScope
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   587
            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
   588
phrase2C (ForCycle i' e1' e2' p) = do
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   589
    i <- id2C IOLookup i'
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   590
    e1 <- expr2C e1'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   591
    e2 <- expr2C e2'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   592
    ph <- phrase2C (wrapPhrase p)
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   593
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   594
        text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i])
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   595
        $$
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   596
        ph
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   597
phrase2C (RepeatCycle e' p') = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   598
    e <- expr2C e'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   599
    p <- phrase2C (Phrases p')
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   600
    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   601
phrase2C NOP = return $ text ";"
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   602
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   603
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = return $ text "return" <> semi
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   604
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <> e <> semi) $ expr2C e
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   605
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   606
phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   607
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   608
phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   609
phrase2C a = error $ "phrase2C: " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   610
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   611
wrapPhrase p@(Phrases _) = p
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   612
wrapPhrase p = Phrases [p]
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   613
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   614
expr2C :: Expression -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   615
expr2C (Expression s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   616
expr2C (BinOp op expr1 expr2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   617
    e1 <- expr2C expr1
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   618
    t1 <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   619
    e2 <- expr2C expr2
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   620
    t2 <- gets lastType
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   621
    case (op2C op, t1, t2) of
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   622
        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString))
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   623
        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction BTString))
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   624
        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction BTString))
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   625
        ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool))
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   626
        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool))
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   627
        ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   628
        ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   629
        (o, _, _) | o `elem` boolOps -> do
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   630
                        modify(\s -> s{lastType = BTBool})
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   631
                        return $ parens e1 <+> text o <+> parens e2
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   632
                  | otherwise -> return $ parens e1 <+> text o <+> parens e2
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   633
    where
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   634
        boolOps = ["==", "!=", "<", ">", "<=", ">="]
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   635
expr2C (NumberLiteral s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   636
expr2C (FloatLiteral s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   637
expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   638
expr2C (StringLiteral [a]) = do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   639
    modify(\s -> s{lastType = BTChar})
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   640
    return . quotes $ text [a]
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   641
expr2C (StringLiteral s) = addStringConst s
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   642
expr2C (Reference ref) = ref2CF ref
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   643
expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr)
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   644
expr2C Null = return $ text "NULL"
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   645
expr2C (CharCode a) = do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   646
    modify(\s -> s{lastType = BTChar})
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   647
    return $ quotes $ text "\\x" <> text (showHex (read a) "")
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   648
expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a)
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   649
expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   650
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   651
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   652
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   653
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   654
expr2C (BuiltInFunCall params ref) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   655
    r <- ref2C ref 
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   656
    t <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   657
    ps <- mapM expr2C params
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   658
    case t of
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   659
        BTFunction t' -> do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   660
            modify (\s -> s{lastType = t'})
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   661
        _ -> error $ "BuiltInFunCall lastType: " ++ show t
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   662
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   663
        r <> parens (hsep . punctuate (char ',') $ ps)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   664
expr2C a = error $ "Don't know how to render " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   665
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   666
ref2CF :: Reference -> State RenderState Doc
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   667
ref2CF (SimpleReference name) = do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   668
    i <- id2C IOLookup name
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   669
    t <- gets lastType
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   670
    case t of
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   671
         BTFunction _ -> return $ i <> parens empty
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   672
         _ -> return $ i
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   673
ref2CF r = ref2C r
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   674
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   675
ref2C :: Reference -> State RenderState Doc
6854
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
   676
-- rewrite into proper form
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   677
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   678
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   679
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   680
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   681
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
   682
-- conversion routines
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   683
ref2C ae@(ArrayElement [expr] ref) = do
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   684
    e <- expr2C expr
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   685
    r <- ref2C ref 
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   686
    t <- gets lastType
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   687
    ns <- gets currentScope
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   688
    case t of
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   689
         (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
6967
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   690
         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   691
         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   692
         (BTString) -> modify (\st -> st{lastType = BTChar})
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   693
         (BTPointerTo t) -> do
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   694
                t'' <- fromPointer (show t) =<< gets lastType
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   695
                case t'' of
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   696
                     BTChar -> modify (\st -> st{lastType = BTChar})
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
   697
                     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
   698
         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns)
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   699
    case t of
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   700
         BTString ->  return $ r <> text ".s" <> brackets e
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   701
         _ -> return $ r <> brackets e
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   702
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
   703
ref2C rf@(RecordField (Dereference ref1) ref2) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   704
    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
   705
    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
   706
    ns <- gets currentScope
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   707
    r2 <- case t of
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   708
        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
   709
        BTUnit -> withLastIdNamespace $ ref2C ref2
59da15acb2f2 Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents: 6838
diff changeset
   710
        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
   711
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   712
        r1 <> text "->" <> r2
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   713
ref2C rf@(RecordField ref1 ref2) = do
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   714
    r1 <- ref2C ref1
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   715
    t <- gets lastType
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   716
    ns <- gets currentScope
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   717
    r2 <- case t of
6967
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   718
        BTFunctionReturn s (BTRecord rs) -> withRecordNamespace "" rs $ ref2C ref2       
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   719
        BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2
6967
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   720
        BTUnit -> withLastIdNamespace $ ref2C ref2        
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   721
        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
   722
    return $ 
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   723
        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
   724
ref2C d@(Dereference ref) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   725
    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
   726
    t <- fromPointer (show d) =<< gets lastType
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   727
    modify (\st -> st{lastType = t})
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   728
    return $ (parens $ text "*" <> r)
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   729
ref2C f@(FunCall params ref) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   730
    r <- ref2C ref
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   731
    t <- gets lastType
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   732
    case t of
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   733
        BTFunction t' -> do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   734
            ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   735
            modify (\s -> s{lastType = t'})
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   736
            return $ r <> ps
6967
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   737
        BTFunctionReturn r t' -> do
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   738
            ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   739
            modify (\s -> s{lastType = t'})
1224c6fb36c3 Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents: 6965
diff changeset
   740
            return $ text r <> ps
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   741
        _ -> case (ref, params) of
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   742
                  (SimpleReference i, [p]) -> ref2C $ TypeCast i p
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   743
                  _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   744
        
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   745
ref2C (Address ref) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   746
    r <- ref2C ref
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   747
    return $ text "&" <> parens r
6902
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   748
ref2C (TypeCast t'@(Identifier i _) expr) = do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   749
    case map toLower i of
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   750
        "pchar" -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   751
        a -> do
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   752
            e <- expr2C expr
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   753
            t <- id2C IOLookup t'    
7d4e5ce73b98 Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents: 6896
diff changeset
   754
            return $ parens t <> e
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   755
ref2C (RefExpression expr) = expr2C expr
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   756
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   757
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   758
op2C :: String -> String
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   759
op2C "or" = "|"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   760
op2C "and" = "&"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   761
op2C "not" = "!"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   762
op2C "xor" = "^"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   763
op2C "div" = "/"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   764
op2C "mod" = "%"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   765
op2C "shl" = "<<"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   766
op2C "shr" = ">>"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   767
op2C "<>" = "!="
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   768
op2C "=" = "=="
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   769
op2C a = a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   770