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