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