tools/pas2c/Pas2C.hs
author Wuzzy <Wuzzy2@mail.ru>
Sat, 16 May 2020 01:36:44 +0200
changeset 15564 732b82f44c83
parent 14357 3baee596a989
child 15750 036263d63b05
permissions -rw-r--r--
Hats webpage: Many improvements and fixes (2nd try) * Fix static hats not being animated properly * Make widges more user-friendly * Add local mode to hats webpage to make testing easier (IS_LOCAL variable) * Cleanup code * Update themes list * Update list of local hats
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
13819
db1b680bd8d3 Resolve ambiguity of <> in Pas2C.hs
Wuzzy <Wuzzy2@mail.ru>
parents: 13344
diff changeset
     4
import Prelude hiding ((<>))
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
     5
import Text.PrettyPrint.HughesPJ
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
     6
import Data.Maybe
6277
627b5752733a A try to improve parser move (has regressions)
unc0rr
parents: 6275
diff changeset
     7
import Data.Char
6511
bc6e67598dde Ok, State monad instead
unc0rr
parents: 6509
diff changeset
     8
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
     9
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
    10
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
    11
import PascalPreprocessor
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    12
import Control.Exception
eae5900fd8a4 Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents: 6399
diff changeset
    13
import System.IO.Error
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
    14
import qualified Data.Map as Map
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
    15
import qualified Data.Set as Set
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    16
import Data.List (find)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
    17
import Numeric
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
    18
10245
3ccc054c3c3e Fix some pas2c engine warnings
unc0rr
parents: 10240
diff changeset
    19
import PascalParser
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
    20
import PascalUnitSyntaxTree
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
    21
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    22
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
    23
data InsertOption =
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    24
    IOInsert
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    25
    | IOInsertWithType Doc
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    26
    | IOLookup
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
    27
    | IOLookupLast
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
    28
    | IOLookupFunction Int
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    29
    | IODeferred
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
    30
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    31
data Record = Record
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    32
    {
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    33
        lcaseId :: String,
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    34
        baseType :: BaseType,
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    35
        typeDecl :: Doc
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    36
    }
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    37
    deriving Show
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
    38
type Records = Map.Map String [Record]
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
    39
data RenderState = RenderState
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    40
    {
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
    41
        currentScope :: Records,
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
    42
        lastIdentifier :: String,
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
    43
        lastType :: BaseType,
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
    44
        isFunctionType :: Bool, -- set to true if the current function parameter is functiontype
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,
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
    49
        enums :: [(String, [String])], -- store all declared enums
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
    50
        currentUnit :: String,
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
    51
        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
    52
        namespaces :: Map.Map String Records
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
    53
    }
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
    54
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
    55
rec2Records :: [(String, BaseType)] -> [Record]
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    56
rec2Records = map (\(a, b) -> Record a b empty)
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
    57
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
    58
emptyState :: Map.Map String Records -> RenderState
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
    59
emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    60
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    61
getUniq :: State RenderState Int
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    62
getUniq = do
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    63
    i <- gets uniqCounter
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    64
    modify(\s -> s{uniqCounter = uniqCounter s + 1})
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    65
    return i
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
    66
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    67
addStringConst :: String -> State RenderState Doc
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    68
addStringConst str = do
6921
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    69
    strs <- gets stringConsts
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    70
    let a = find ((==) str . snd) strs
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    71
    if isJust a then
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
    72
        do
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
    73
        modify (\s -> s{lastType = BTString})
6921
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    74
        return . text . fst . fromJust $ a
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    75
    else
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    76
        do
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    77
        i <- getUniq
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    78
        let sn = "__str" ++ show i
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    79
        modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
e6033fe39b7f Don't add duplicates into string consts
unc0rr
parents: 6902
diff changeset
    80
        return $ text sn
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
    81
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    82
escapeStr :: String -> String
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    83
escapeStr = foldr escapeChar []
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    84
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    85
escapeChar :: Char -> ShowS
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    86
escapeChar '"' s = "\\\"" ++ s
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
    87
escapeChar '\\' s = "\\\\" ++ s
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    88
escapeChar a s = a : s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    89
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    90
strInit :: String -> Doc
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    91
strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
    92
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
    93
renderStringConsts :: State RenderState Doc
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
    94
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
    95
    $ gets stringConsts
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
    96
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    97
docToLower :: Doc -> Doc
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
    98
docToLower = text . map toLower . render
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
    99
9982
24ea101fdc7f '-d' option to pas2c
unc0rr
parents: 9964
diff changeset
   100
pas2C :: String -> String -> String -> String -> [String] -> IO ()
24ea101fdc7f '-d' option to pas2c
unc0rr
parents: 9964
diff changeset
   101
pas2C fn inputPath outputPath alternateInputPath symbols = do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
   102
    s <- flip execStateT initState $ f fn
7953
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   103
    renderCFiles s outputPath
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
   104
    where
7265
3f96073156e1 Output log to stdout instead of stderr
unc0rr
parents: 7151
diff changeset
   105
    printLn = liftIO . hPutStrLn stdout
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   106
    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
   107
    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
   108
    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
   109
    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
   110
        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
   111
        unless processed $ do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   112
            print' ("Preprocessing '" ++ fileName ++ ".pas'... ")
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   113
            fc' <- liftIO
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   114
                $ tryJust (guard . isDoesNotExistError)
9982
24ea101fdc7f '-d' option to pas2c
unc0rr
parents: 9964
diff changeset
   115
                $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
6425
1ef4192aa80d - Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents: 6417
diff changeset
   116
            case fc' of
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   117
                (Left _) -> do
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   118
                    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
   119
                    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
   120
                (Right fc) -> do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   121
                    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
   122
                    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
   123
                    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
   124
                         (Left a) -> do
10240
bfae7354d42f Support OR operator in $IFDEF. Fixes pas2c builds.
unc0rr
parents: 10142
diff changeset
   125
                            liftIO $ writeFile (outputPath ++ fileName ++ "preprocess.out") fc
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
   126
                            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
   127
                            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
   128
                         (Right a) -> do
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
   129
                            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
   130
                            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
   131
                            mapM_ f (usesFiles a)
6455
d2b13364eddd More verbose progress log, dump the result
unc0rr
parents: 6453
diff changeset
   132
6514
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
   133
7953
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   134
renderCFiles :: Map.Map String PascalUnit -> String -> IO ()
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   135
renderCFiles units outputPath = do
6514
8ba891d34eba - Fix type2C id2C call
unc0rr
parents: 6512
diff changeset
   136
    let u = Map.toList units
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   137
    let nss = Map.map (toNamespace nss) units
7265
3f96073156e1 Output log to stdout instead of stderr
unc0rr
parents: 7151
diff changeset
   138
    --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   139
    --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
7953
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   140
    mapM_ (toCFiles outputPath nss) u
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   141
    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
   142
    toNamespace :: Map.Map String Records -> PascalUnit -> Records
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   143
    toNamespace nss (System tvs) =
7069
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   144
        currentScope $ execState f (emptyState nss)
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   145
        where
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   146
        f = do
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   147
            checkDuplicateFunDecls tvs
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   148
            mapM_ (tvar2C True False True False) tvs
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   149
    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
   150
        currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   151
        where
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   152
        f = do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   153
            checkDuplicateFunDecls tvs
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   154
            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
   155
    toNamespace _ (Program {}) = Map.empty
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   156
    toNamespace nss (Unit (Identifier i _) interface _ _ _) =
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   157
        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
   158
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   159
withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   160
withState' f sf = do
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   161
    st <- liftM f get
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   162
    let (a, s) = runState sf st
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   163
    modify(\st' -> st'{
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   164
        lastType = lastType s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   165
        , uniqCounter = uniqCounter s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   166
        , stringConsts = stringConsts s
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   167
        })
6853
affeaba0af71 Fix withState' not returning lastType
unc0rr
parents: 6845
diff changeset
   168
    return a
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   169
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   170
withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   171
withLastIdNamespace f = do
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   172
    li <- gets lastIdentifier
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
   173
    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
   174
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   175
withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   176
withRecordNamespace _ [] = error "withRecordNamespace: empty record"
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
   177
withRecordNamespace prefix recs = withState' f
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   178
    where
7039
e7dc6ddd1e29 Handle function type differently
unc0rr
parents: 7038
diff changeset
   179
        f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   180
        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
   181
        un [a] b = a : b
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   182
        un _ _ = error "withRecordNamespace un: pattern not matched"
6817
daaf0834c4d2 - Apply unit's namespace to current scope when referencing unit name
unc0rr
parents: 6816
diff changeset
   183
7953
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   184
toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   185
toCFiles _ _ (_, System _) = return ()
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   186
toCFiles _ _ (_, Redo _) = return ()
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   187
toCFiles outputPath ns pu@(fileName, _) = do
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   188
    hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
13887
5988e73080a3 Make converter for uLandTemplates into yaml
unc0rr
parents: 13878
diff changeset
   189
    --let (fn, p) = pu in writeFile (outputPath ++ fn ++ ".dump") $ show p
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   190
    toCFiles' pu
6474
42e9773eedfd - Improve renderer a bit, disallow nested functions
unc0rr
parents: 6467
diff changeset
   191
    where
7953
97f41bdf0770 pas2C is slowely becoming parametric
koda
parents: 7949
diff changeset
   192
    toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
   193
    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
   194
        let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   195
            (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   196
            enumDecl = (renderEnum2Strs (enums s) False)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   197
            enumImpl = (renderEnum2Strs (enums s) True)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   198
        writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   199
        writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   200
    toCFiles' _ = undefined -- just pleasing compiler to not warn us
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   201
    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
   202
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   203
    render2C :: RenderState -> State RenderState Doc -> String
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   204
    render2C st p =
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   205
        let (a, _) = runState p st in
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   206
        render a
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   207
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   208
renderEnum2Strs :: [(String, [String])] -> Bool -> String
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   209
renderEnum2Strs enums' implement =
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   210
    render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums'
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   211
    where
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   212
    decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar")
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
   213
    enum2strBlock en =
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   214
            text "{"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   215
            $+$
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   216
            (nest 4 $
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   217
                text "switch(enumvar){"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   218
                $+$
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   219
                (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   220
                $+$
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   221
                text "default: assert(0);"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   222
                $+$
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   223
                (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");")
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   224
                $+$
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   225
                text "}"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   226
            )
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   227
            $+$
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   228
            text "}"
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   229
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
   230
usesFiles :: PascalUnit -> [String]
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   231
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
   232
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   233
usesFiles (System {}) = []
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   234
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
   235
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   236
pascal2C :: PascalUnit -> State RenderState Doc
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   237
pascal2C (Unit _ interface implementation _ _) =
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   238
    liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   239
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   240
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
   241
    impl <- implementation2C implementation
14357
3baee596a989 Apply Pas2C fix suggested by unC0Rr
Wuzzy <Wuzzy2@mail.ru>
parents: 14237
diff changeset
   242
    main <- liftM head $ tvar2C True False True True
10245
3ccc054c3c3e Fix some pas2c engine warnings
unc0rr
parents: 10240
diff changeset
   243
        (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) 
3ccc054c3c3e Fix some pas2c engine warnings
unc0rr
parents: 10240
diff changeset
   244
            [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing
3ccc054c3c3e Fix some pas2c engine warnings
unc0rr
parents: 10240
diff changeset
   245
            , VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] 
3ccc054c3c3e Fix some pas2c engine warnings
unc0rr
parents: 10240
diff changeset
   246
        (Just (TypesAndVars [], Phrases [mainResultInit, mainFunction])))
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   247
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   248
    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
   249
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   250
pascal2C _ = error "pascal2C: pattern not matched"
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   251
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   252
-- 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
   253
-- that will be inserted into implementation files
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   254
interface2C :: Interface -> Bool -> State RenderState Doc
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   255
interface2C (Interface uses tvars) True = do
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   256
    u <- uses2C uses
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   257
    tv <- typesAndVars2C True True True tvars
6965
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   258
    r <- renderStringConsts
5718ec36900c Rework string init macro
unc0rr
parents: 6923
diff changeset
   259
    return (u $+$ r $+$ tv)
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   260
interface2C (Interface uses tvars) False = do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   261
    void $ uses2C uses
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   262
    tv <- typesAndVars2C True False False tvars
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   263
    void $ renderStringConsts
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   264
    return tv
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   265
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   266
implementation2C :: Implementation -> State RenderState Doc
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   267
implementation2C (Implementation uses tvars) = do
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   268
    u <- uses2C uses
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   269
    tv <- typesAndVars2C True False True tvars
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   270
    r <- renderStringConsts
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
   271
    return (u $+$ r $+$ tv)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   272
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   273
checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   274
checkDuplicateFunDecls tvs =
7069
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   275
    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
   276
    where
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   277
        initMap :: Map.Map String Int
7069
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   278
        initMap = Map.empty
bcf9d8e64e92 pas2c stuff again
unc0rr
parents: 7067
diff changeset
   279
        --initMap = Map.fromList [("reset", 2)]
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   280
        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
   281
        ins _ m = m
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   282
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   283
-- 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
   284
-- 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
   285
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   286
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
   287
typesAndVars2C b externVar includeType(TypesAndVars ts) = do
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   288
    checkDuplicateFunDecls ts
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   289
    liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   290
6816
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   291
setBaseType :: BaseType -> Identifier -> Identifier
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   292
setBaseType bt (Identifier i _) = Identifier i bt
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   293
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   294
uses2C :: Uses -> State RenderState Doc
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   295
uses2C uses@(Uses unitIds) = do
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   296
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   297
    mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   298
    mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
6816
572571ea945e Fix wrong type returned from id2C
unc0rr
parents: 6663
diff changeset
   299
    mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   300
    return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   301
    where
11840
24f309d75da8 Use less weird options
unc0rr
parents: 11398
diff changeset
   302
    injectNamespace :: Identifier -> State RenderState ()
6517
67ea290ea843 Format code a bit
unc0rr
parents: 6516
diff changeset
   303
    injectNamespace (Identifier i _) = do
6516
addaeb1b9539 Further progress on dealing with namespaces
unc0rr
parents: 6514
diff changeset
   304
        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
   305
        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
   306
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
   307
uses2List :: Uses -> [String]
6489
e1f0058cfedd Add base type tags to identifiers
unc0rr
parents: 6474
diff changeset
   308
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   309
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   310
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   311
setLastIdValues :: Record -> RenderState -> RenderState
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   312
setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   313
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   314
id2C :: InsertOption -> Identifier -> State RenderState Doc
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   315
id2C IOInsert i = id2C (IOInsertWithType empty) i
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   316
id2C (IOInsertWithType d) (Identifier i t) = do
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   317
    tom <- gets (Set.member n . toMangle)
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
   318
    cu <- gets currentUnit
7323
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   319
    let (i', t') = case (t, tom) of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   320
            (BTFunction _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t)
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   321
            (BTFunction _ e _ _, _) -> ((if e then id else (++) cu) i, t)
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   322
            (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'')
7323
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   323
            _ -> (i, t)
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   324
    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
   325
    return $ text i'
6837
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   326
    where
a137733c5776 Much better types handling, work correctly with functions
unc0rr
parents: 6836
diff changeset
   327
        n = map toLower i
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   328
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   329
id2C IOLookup i = id2CLookup head i
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   330
id2C IOLookupLast i = id2CLookup last i
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   331
id2C (IOLookupFunction params) (Identifier i _) = do
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   332
    let i' = map toLower i
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   333
    v <- gets $ Map.lookup i' . currentScope
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   334
    lt <- gets lastType
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   335
    if isNothing v then
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   336
        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
   337
        else
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   338
        let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   339
            modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   340
    where
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   341
        checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   342
        checkParam _ = False
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   343
id2C IODeferred (Identifier i _) = do
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   344
    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
   345
    v <- gets $ Map.lookup i' . currentScope
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   346
    if (isNothing v) then
7034
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   347
        modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   348
        else
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   349
        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
   350
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   351
id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   352
id2CLookup f (Identifier i _) = do
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   353
    let i' = map toLower i
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   354
    v <- gets $ Map.lookup i' . currentScope
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   355
    lt <- gets lastType
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   356
    if isNothing v then
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   357
        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   358
        else
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   359
        let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   360
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   361
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   362
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   363
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   364
id2CTyped = id2CTyped2 Nothing
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   365
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   366
id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   367
id2CTyped2 md t (Identifier i _) = do
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   368
    tb <- resolveType t
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   369
    case (t, tb) of
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   370
        (_, 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
   371
            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
   372
        (SimpleType {}, BTRecord _ r) -> do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   373
            ts <- type2C t
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   374
            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
   375
        (_, BTRecord _ r) -> do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   376
            ts <- type2C t
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   377
            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   378
        _ -> case md of
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   379
                Nothing -> id2C IOInsert (Identifier i tb)
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   380
                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
   381
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   382
typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)]
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   383
typeVarDecl2BaseType d = do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   384
    st <- get
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   385
    result <- sequence $ concat $ map resolveType' d
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   386
    put st -- restore state (not sure if necessary)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   387
    return result
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   388
    where
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   389
        resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)]
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   390
        resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   391
        resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   392
        resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   393
        resolveTypeHelper' st b = do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   394
            bt <- st
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   395
            return (b, bt)
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
   396
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
   397
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
   398
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
   399
    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
   400
    v <- gets $ Map.lookup i' . currentScope
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   401
    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
   402
    where
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   403
    f "uinteger" = BTInt False
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   404
    f "integer" = BTInt True
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
   405
    f "pointer" = BTPointerTo BTVoid
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   406
    f "boolean" = BTBool
6649
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   407
    f "float" = BTFloat
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   408
    f "char" = BTChar
7f78e8a6db69 Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents: 6635
diff changeset
   409
    f "string" = BTString
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   410
    f "ansistring" = BTAString
6635
c2fa29fe2a58 Some progress, still can't find the source of bad behavior
unc0rr
parents: 6626
diff changeset
   411
    f _ = error $ "Unknown system type: " ++ show st
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   412
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   413
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
   414
resolveType (RecordType tv mtvs) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   415
    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   416
    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
   417
    where
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   418
        f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
7317
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   419
        f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   420
        f _ = error "resolveType f: pattern not matched"
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   421
resolveType (ArrayDecl (Just i) t) = do
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   422
    t' <- resolveType t
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   423
    return $ BTArray i (BTInt True) t'
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   424
resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   425
resolveType (FunctionType t a) = do
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
   426
    bts <- typeVarDecl2BaseType a
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   427
    liftM (BTFunction False False bts) $ resolveType t
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   428
resolveType (DeriveType (InitHexNumber _)) = return (BTInt True)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   429
resolveType (DeriveType (InitNumber _)) = return (BTInt True)
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   430
resolveType (DeriveType (InitFloat _)) = return BTFloat
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   431
resolveType (DeriveType (InitString _)) = return BTString
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   432
resolveType (DeriveType (InitBinOp {})) = return (BTInt True)
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
   433
resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   434
resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True)
6835
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   435
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
00b2fd32305d Better deriving, some fixes
unc0rr
parents: 6834
diff changeset
   436
resolveType (DeriveType _) = return BTUnknown
10111
459bc720cea1 Drop support for other string types than string255
unc0rr
parents: 10015
diff changeset
   437
resolveType String = return BTString
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   438
resolveType AString = return BTAString
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
   439
resolveType VoidType = return BTVoid
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   440
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
   441
resolveType (RangeType _) = return $ BTVoid
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   442
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
   443
resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   444
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   445
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
   446
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
   447
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
   448
    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
   449
    if isJust v then
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   450
        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
   451
        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
   452
        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
   453
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
   454
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
   455
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
   456
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
   457
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
   458
    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
   459
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   460
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   461
functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   462
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
   463
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   464
numberOfDeclarations :: [TypeVarDeclaration] -> Int
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   465
numberOfDeclarations = sum . map cnt
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   466
    where
7317
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   467
        cnt (VarDeclaration _ _ (ids, _) _) = length ids
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   468
        cnt _ = 1
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   469
7317
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   470
hasPassByReference :: [TypeVarDeclaration] -> Bool
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   471
hasPassByReference = or . map isVar
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   472
    where
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   473
        isVar (VarDeclaration v _ (_, _) _) = v
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   474
        isVar _ = error $ "hasPassByReference called not on function parameters"
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   475
7323
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   476
toIsVarList :: [TypeVarDeclaration] -> [Bool]
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   477
toIsVarList = concatMap isVar
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   478
    where
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   479
        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
   480
        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
   481
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   482
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   483
funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   484
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
   485
    where
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   486
        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
   487
        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
   488
        ps = zip ['a'..] (toIsVarList params)
8490a4f439a5 Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents: 7317
diff changeset
   489
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   490
fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   491
fun2C _ _ (FunctionDeclaration name _ overload external returnType params Nothing) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   492
    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
   493
    t'<- gets lastType
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   494
    bts <- typeVarDecl2BaseType params
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   495
    p <- withState' id $ functionParams2C params
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   496
    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   497
    let decor = if overload then text "__attribute__((overloadable))" else empty
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   498
    return [t empty <+> decor <+> text n <> parens p]
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   499
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   500
fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   501
    let isVoid = case returnType of
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   502
            VoidType -> True
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   503
            _ -> False
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   504
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   505
    let res = docToLower $ text rv <> if isVoid then empty else text "_result"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   506
    t <- type2C returnType
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   507
    t' <- gets lastType
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   508
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   509
    bts <- typeVarDecl2BaseType params
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   510
    --cu <- gets currentUnit
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   511
    notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   512
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   513
    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   514
    let resultId = if isVoid
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   515
                    then n -- void type doesn't have result, solving recursive procedure calls
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   516
                    else (render res)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   517
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   518
    (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else t') empty] $ currentScope st
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   519
            , currentFunctionResult = if isVoid then [] else render res}) $ do
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   520
        p <- functionParams2C params
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   521
        ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
   522
        return (p, ph)
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   523
10497
c7c50f165946 [PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents: 10245
diff changeset
   524
    let isTrivialReturn = case phrase of
c7c50f165946 [PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents: 10245
diff changeset
   525
         (Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True
c7c50f165946 [PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents: 10245
diff changeset
   526
         _ -> False
c7c50f165946 [PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents: 10245
diff changeset
   527
    let phrasesBlock = if isVoid || isTrivialReturn then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   528
    --let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   529
    let inlineDecor = if inline then case notDeclared of
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   530
                                    True -> text "static inline"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   531
                                    False -> text "inline"
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   532
                          else empty
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   533
        overloadDecor = if overload then text "__attribute__((overloadable))" else empty
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   534
    return [
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   535
        --define
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   536
        -- $+$
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   537
        --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   538
        inlineDecor <+> t empty <+> overloadDecor <+> text 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
   539
        $+$
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   540
        text "{"
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   541
        $+$
6836
42382794b73f - Treat strings as arrays of chars
unc0rr
parents: 6835
diff changeset
   542
        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
   543
        $+$
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   544
        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
   545
    where
6499
33180b479efa Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents: 6489
diff changeset
   546
    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
   547
    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
   548
    un [a] b = a : b
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   549
    un _ _ = error "fun2C u: pattern not matched"
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
   550
    hasVars = hasPassByReference params
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   551
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   552
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   553
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
   554
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   555
-- 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
   556
-- 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
   557
-- 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
   558
tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   559
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
   560
    t <- fun2C b name f
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   561
    if includeType then return t else return []
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   562
tvar2C _ _ includeType _ (TypeDeclaration i' t) = do
6653
d45b6dbd2ad6 Move a bit further
unc0rr
parents: 6649
diff changeset
   563
    i <- id2CTyped t i'
7039
e7dc6ddd1e29 Handle function type differently
unc0rr
parents: 7038
diff changeset
   564
    tp <- type2C t
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   565
    let res = if includeType then [text "typedef" <+> tp i] else []
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   566
    case t of
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   567
        (Sequence ids) -> do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   568
            modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s})
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   569
            return res
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   570
        _ -> return res
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   571
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   572
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
   573
    t' <- liftM ((empty <+>) . ) $ type2C t
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   574
    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
   575
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   576
tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   577
    t' <- liftM (((if isConst then text "static const" else if externVar
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   578
                                                                then text "extern"
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   579
                                                                else empty)
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   580
                   <+>) . ) $ type2C t
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   581
    ie <- initExpr mInitExpr
6979
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   582
    lt <- gets lastType
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   583
    case (isConst, lt, ids, mInitExpr) of
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   584
         (True, BTInt _, [i], Just _) -> do
6979
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   585
             i' <- id2CTyped t i
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   586
             return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
7002
5d817ba976f7 Render float consts into defines
unc0rr
parents: 6980
diff changeset
   587
         (True, BTFloat, [i], Just e) -> do
5d817ba976f7 Render float consts into defines
unc0rr
parents: 6980
diff changeset
   588
             i' <- id2CTyped t i
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   589
             ie' <- initExpr2C e
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   590
             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
   591
         (_, 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
   592
         (_, BTArray r _ _, [i], _) -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   593
            i' <- id2CTyped t i
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   594
            ie' <- return $ case (r, mInitExpr, ignoreInit) of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   595
                (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
   596
                (_, _, _) -> ie
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   597
            result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   598
            case (r, ignoreInit) of
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   599
                (RangeInfinite, False) ->
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   600
                    -- 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
   601
                    return $ [dimDecl] ++ result
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   602
                    where
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   603
                        arrayDimStr = show $ arrayDimension t
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   604
                        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
   605
                        dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   606
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   607
                (_, _) -> return result
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   608
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   609
         _ -> 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
   610
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   611
    initExpr Nothing = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   612
    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
   613
    varDeclDecision True True varStr expStr = varStr <+> expStr
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   614
    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
   615
    varDeclDecision False False varStr expStr = varStr <+> expStr
13878
0ce8aad17c24 IFDEF out missing function with FIXME, revert pas2c change in 0ecf77e203c0 as suggested by unc0rr, another string annotation
nemo
parents: 13862
diff changeset
   616
    varDeclDecision True False _ _ = empty
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   617
    arrayDimension a = case a of
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   618
        ArrayDecl Nothing t' -> let a' = arrayDimension t' in 
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   619
                                   if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a'
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   620
        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
   621
        _ -> 0
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   622
7513
39866eb9e4a6 Keep inlining
unc0rr
parents: 7511
diff changeset
   623
tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   624
    r <- op2CTyped op (extractTypes params)
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   625
    fun2C f i (FunctionDeclaration r inline False False ret params body)
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   626
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   627
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   628
op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   629
op2CTyped op t = do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   630
    t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   631
    bt <- gets lastType
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   632
    return $ Identifier (t' ++ "_op_" ++ opStr) bt
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   633
    where
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   634
    opStr = case op of
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   635
                    "+" -> "add"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   636
                    "-" -> "sub"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   637
                    "*" -> "mul"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   638
                    "/" -> "div"
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   639
                    "/(float)" -> "div"
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   640
                    "=" -> "eq"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   641
                    "<" -> "lt"
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   642
                    ">" -> "gt"
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   643
                    "<>" -> "neq"
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   644
                    _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   645
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   646
extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   647
extractTypes = concatMap f
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   648
    where
7317
3534a264b27a Prepare to handle passing by reference
unc0rr
parents: 7315
diff changeset
   649
        f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
6880
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   650
        f a = error $ "extractTypes: can't extract from " ++ show a
34d3bc7bd8b1 Support operators declarations
unc0rr
parents: 6878
diff changeset
   651
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   652
initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   653
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
   654
initExpr2C a = initExpr2C' a
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   655
initExpr2C' InitNull = return $ text "NULL"
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
   656
initExpr2C' (InitAddress expr) = do
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
   657
    ie <- initExpr2C' expr
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
   658
    lt <- gets lastType
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
   659
    case lt of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   660
        BTFunction True _ _ _ -> return $ text "&" <> ie -- <> text "__vars"
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
   661
        _ -> return $ text "&" <> ie
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   662
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
   663
initExpr2C' (InitBinOp op expr1 expr2) = do
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   664
    e1 <- initExpr2C' expr1
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   665
    e2 <- initExpr2C' expr2
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   666
    return $ parens $ e1 <+> text (op2C op) <+> e2
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   667
initExpr2C' (InitNumber s) = do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   668
                                modify(\st -> st{lastType = (BTInt True)})
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
   669
                                return $ text s
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   670
initExpr2C' (InitFloat s) = return $ text s
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   671
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
   672
initExpr2C' (InitString [a]) = return . quotes $ text [a]
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   673
initExpr2C' (InitString s) = return $ strInit s
10747
07ade56c3b4a backporting some build system fixes and pas2c tweaks
sheepluva
parents: 10688
diff changeset
   674
initExpr2C' (InitPChar s) = return $ doubleQuotes (text $ escapeStr s)
9964
12b0ed9910cd Render chars as hex numbers
unc0rr
parents: 9954
diff changeset
   675
initExpr2C' (InitChar a) = return $ text "0x" <> text (showHex (read a) "")
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   676
initExpr2C' (InitReference i) = id2C IOLookup i
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   677
initExpr2C' (InitRecord fields) = do
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   678
    (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   679
    return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
9954
bf51bc7e2808 - Fix build via pas2c
unc0rr
parents: 8446
diff changeset
   680
--initExpr2C' (InitArray [InitRecord fields]) = do
bf51bc7e2808 - Fix build via pas2c
unc0rr
parents: 8446
diff changeset
   681
--    e <- initExpr2C $ InitRecord fields
bf51bc7e2808 - Fix build via pas2c
unc0rr
parents: 8446
diff changeset
   682
--    return $ braces $ e
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   683
initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   684
    void $ id2C IOLookup i
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   685
    t <- gets lastType
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   686
    case t of
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   687
         BTEnum s -> return . int $ length s
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   688
         BTInt _ -> case i' of
6891
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   689
                       "byte" -> return $ int 256
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   690
                       _ -> error $ "InitRange identifier: " ++ i'
ab9843957664 Improve rendering of function types, ranges, and more
unc0rr
parents: 6887
diff changeset
   691
         _ -> error $ "InitRange: " ++ show r
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   692
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
   693
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
   694
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
   695
initExpr2C' (InitSet []) = return $ text "0"
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   696
initExpr2C' (InitSet _) = return $ text "<<set>>"
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   697
initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   698
    case e of
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   699
         (Identifier "LongInt" _) -> int (-2^31)
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   700
         (Identifier "SmallInt" _) -> int (-2^15)
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
   701
         _ -> error $ "BuiltInFunction 'low': " ++ show e
13857
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13819
diff changeset
   702
initExpr2C' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do
13858
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13856
diff changeset
   703
    void $ initExpr2C e
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13856
diff changeset
   704
    t <- gets lastType
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13856
diff changeset
   705
    case t of
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13856
diff changeset
   706
         (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
13857
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13819
diff changeset
   707
         BTInt _ -> case e' of
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13819
diff changeset
   708
                  (Identifier "LongInt" _) -> return $ int (2147483647)
13859
885ee14fe640 Fix previous patch, add support for High(Longword)
unc0rr
parents: 13857
diff changeset
   709
                  (Identifier "LongWord" _) -> return $ text "4294967295"
885ee14fe640 Fix previous patch, add support for High(Longword)
unc0rr
parents: 13857
diff changeset
   710
                  _ -> error $ "BuiltInFunction 'high' in initExpr: " ++ show e'
13857
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13819
diff changeset
   711
         a -> error $ "BuiltInFunction 'high' in initExpr: " ++ show a ++ ": " ++ show hi
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   712
initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   713
initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   714
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
   715
initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   716
initExpr2C' b@(BuiltInFunction _ _) = error $ show b
10131
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   717
initExpr2C' (InitTypeCast t' i) = do
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   718
    e <- initExpr2C i
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   719
    t <- id2C IOLookup t'
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   720
    return . parens $ parens t <> e
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   721
initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   722
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   723
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   724
range2C :: InitExpression -> State RenderState [Doc]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   725
range2C (InitString [a]) = return [quotes $ text [a]]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   726
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   727
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
   728
range2C a = liftM (flip (:) []) $ initExpr2C a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   729
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   730
baseType2C :: String -> BaseType -> Doc
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   731
baseType2C _ BTFloat = text "float"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   732
baseType2C _ BTBool = text "bool"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   733
baseType2C _ BTString = text "string255"
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   734
baseType2C _ BTAString = text "astring"
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   735
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   736
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   737
type2C :: TypeDecl -> State RenderState (Doc -> Doc)
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   738
type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   739
type2C t = do
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   740
    r <- type2C' t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   741
    rt <- resolveType t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   742
    modify (\st -> st{lastType = rt})
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   743
    return r
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   744
    where
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   745
    type2C' VoidType = return (text "void" <+>)
10111
459bc720cea1 Drop support for other string types than string255
unc0rr
parents: 10015
diff changeset
   746
    type2C' String = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   747
    type2C' AString = return (text "astring" <+>)
7034
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   748
    type2C' (PointerTo (SimpleType i)) = do
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   749
        i' <- id2C IODeferred i
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   750
        lt <- gets lastType
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   751
        case lt of
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   752
             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
   753
             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
   754
             _ -> return $ \a -> i' <+> text "*" <+> a
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   755
    type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   756
    type2C' (RecordType tvs union) = do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   757
        t' <- withState' f $ mapM (tvar2C False False True False) tvs
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   758
        u <- unions
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   759
        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
   760
        where
7040
4aff2da0d0b3 Render function variables in struct with no mangling. 13 C units are compilable now.
unc0rr
parents: 7039
diff changeset
   761
            f s = s{currentUnit = ""}
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   762
            unions = case union of
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   763
                     Nothing -> return empty
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   764
                     Just a -> do
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   765
                         structs <- mapM struct2C a
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   766
                         return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   767
            struct2C stvs = do
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   768
                txts <- withState' f $ mapM (tvar2C False False True False) stvs
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   769
                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi
6894
555a8d8db228 Some more progress with pas2c
unc0rr
parents: 6893
diff changeset
   770
    type2C' (RangeType r) = return (text "int" <+>)
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   771
    type2C' (Sequence ids) = do
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   772
        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
   773
        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
   774
        where
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   775
            bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
6894
555a8d8db228 Some more progress with pas2c
unc0rr
parents: 6893
diff changeset
   776
    type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
14236
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14235
diff changeset
   777
    type2C' (ArrayDecl (Just r1) (ArrayDecl (Just r2) t)) = do
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14235
diff changeset
   778
        t' <- type2C t
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14235
diff changeset
   779
        lt <- gets lastType
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14235
diff changeset
   780
        r1' <- initExpr2C (InitRange r1)
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14235
diff changeset
   781
        r2' <- initExpr2C (InitRange r2)
14237
81fba21495a5 was a wrong copy apparently
alfadur
parents: 14236
diff changeset
   782
        return $ \i -> t' i <> brackets r1' <> brackets r2'
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   783
    type2C' (ArrayDecl (Just r) t) = do
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   784
        t' <- type2C t
7066
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   785
        lt <- gets lastType
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   786
        ft <- case lt of
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   787
                -- 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
   788
                _ -> return t'
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   789
        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
   790
        return $ \i -> ft i <> brackets r'
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   791
    type2C' (Set t) = return (text "<<set>>" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   792
    type2C' (FunctionType returnType params) = do
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   793
        t <- type2C returnType
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   794
        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
   795
        return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   796
    type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   797
    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   798
    type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   799
    type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   800
    type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   801
    type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   802
    type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   803
    type2C' (DeriveType r@(InitReference {})) = do
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   804
        initExpr2C r
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   805
        t <- gets lastType
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   806
        return (baseType2C (show r) t <+>)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   807
    type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   808
    type2C' a = error $ "type2C: unknown type " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   809
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   810
phrase2C :: Phrase -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   811
phrase2C (Phrases p) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   812
    ps <- mapM phrase2C p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   813
    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   814
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   815
phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   816
phrase2C (ProcCall _ _) = error $ "ProcCall"{-do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   817
    r <- ref2C ref
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   818
    ps <- mapM expr2C params
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   819
    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   820
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   821
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   822
    p1 <- (phrase2C . wrapPhrase) phrase1
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   823
    el <- elsePart
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   824
    return $
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   825
        text "if" <> parens e $+$ p1 $+$ el
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   826
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   827
    elsePart | isNothing mphrase2 = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   828
             | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
8446
c18ba8726f5a Fix sources so pas2c written in haskell could render them again
unc0rr
parents: 8444
diff changeset
   829
phrase2C asgn@(Assignment ref expr) = do
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   830
    r <- ref2C ref
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   831
    t <- gets lastType
7066
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   832
    case (t, expr) of
10142
adb804cb2638 Reduce number of warnings in pas2c-generated code
unc0rr
parents: 10131
diff changeset
   833
        (_, Reference r') | ref == r' -> do
adb804cb2638 Reduce number of warnings in pas2c-generated code
unc0rr
parents: 10131
diff changeset
   834
            e <- ref2C r'
adb804cb2638 Reduce number of warnings in pas2c-generated code
unc0rr
parents: 10131
diff changeset
   835
            return $ text "UNUSED" <+> parens e <> semi
7066
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   836
        (BTFunction {}, (Reference r')) -> do
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   837
            e <- ref2C r'
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   838
            return $ r <+> text "=" <+> e <> semi
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   839
        (BTString, _) -> do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   840
            void $ expr2C expr
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   841
            lt <- gets lastType
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   842
            case lt of
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   843
                -- assume pointer to char for simplicity
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   844
                BTPointerTo _ -> do
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   845
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   846
                    return $ r <+> text "=" <+> e <> semi
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   847
                BTAString -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   848
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown))
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   849
                    return $ r <+> text "=" <+> e <> semi
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   850
                BTString -> do
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   851
                    e <- expr2C expr
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   852
                    return $ r <+> text "=" <+> e <> semi
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   853
                _ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   854
        (BTAString, _) -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   855
            void $ expr2C expr
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   856
            lt <- gets lastType
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   857
            case lt of
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   858
                -- assume pointer to char for simplicity
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   859
                BTPointerTo _ -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   860
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown))
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   861
                    return $ r <+> text "=" <+> e <> semi
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   862
                BTString -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   863
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown))
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   864
                    return $ r <+> text "=" <+> e <> semi
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   865
                BTAString -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   866
                    e <- expr2C expr
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   867
                    return $ r <+> text "=" <+> e <> semi
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   868
                _ -> error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   869
        (BTArray _ _ _, _) -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   870
            case expr of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   871
                Reference er -> do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   872
                    void $ ref2C er
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   873
                    exprT <- gets lastType
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   874
                    case exprT of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   875
                        BTArray RangeInfinite _ _ ->
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   876
                            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
   877
                        BTArray _ _ _ -> phrase2C $
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   878
                                ProcCall (FunCall
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   879
                                    [
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   880
                                    Reference $ ref
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   881
                                    , Reference $ RefExpression expr
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   882
                                    , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   883
                                    ]
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   884
                                    (SimpleReference (Identifier "memcpy" BTUnknown))
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   885
                                    ) []
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   886
                        _ -> 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
   887
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   888
                _ -> 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
   889
        _ -> do
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   890
            e <- expr2C expr
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   891
            return $ r <+> text "=" <+> e <> semi
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   892
phrase2C (WhileCycle expr phrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   893
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   894
    p <- phrase2C $ wrapPhrase phrase
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   895
    return $ text "while" <> parens e $$ p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   896
phrase2C (SwitchCase expr cases mphrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   897
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   898
    cs <- mapM case2C cases
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   899
    d <- dflt
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   900
    return $
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   901
        text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   902
    where
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   903
    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   904
    case2C (e, p) = do
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   905
        ies <- mapM range2C e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   906
        ph <- phrase2C p
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   907
        return $
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   908
             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
   909
    dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   910
         | otherwise = do
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   911
             ph <- mapM phrase2C $ fromJust mphrase
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   912
             return [text "default:" <+> nest 4 (vcat ph)]
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   913
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   914
phrase2C wb@(WithBlock ref p) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   915
    r <- ref2C ref
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   916
    t <- gets lastType
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   917
    case t of
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   918
        (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   919
        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
   920
            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
   921
phrase2C (ForCycle i' e1' e2' p up) = do
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   922
    i <- id2C IOLookup i'
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   923
    iType <- gets lastIdTypeDecl
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   924
    e1 <- expr2C e1'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   925
    e2 <- expr2C e2'
7529
058fcb451b37 Check if 'for' cycle body is executed at least once
unc0rr
parents: 7513
diff changeset
   926
    let iEnd = i <> text "__end__"
10688
9459c45b5190 dark magic: make "continue" statement work in pas2c-parsed for-loops. (would skip iteration and lead to infinite loops before)
sheepluva
parents: 10497
diff changeset
   927
    ph <- phrase2C $ wrapPhrase p
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   928
    return . braces $
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   929
        i <+> text "=" <+> e1 <> semi
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   930
        $$
7529
058fcb451b37 Check if 'for' cycle body is executed at least once
unc0rr
parents: 7513
diff changeset
   931
        iType <+> iEnd <+> text "=" <+> e2 <> semi
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
   932
        $$
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   933
        text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+>
10688
9459c45b5190 dark magic: make "continue" statement work in pas2c-parsed for-loops. (would skip iteration and lead to infinite loops before)
sheepluva
parents: 10497
diff changeset
   934
        text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   935
    where
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   936
        appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
10497
c7c50f165946 [PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents: 10245
diff changeset
   937
        appendPhrase _ _ = error "illegal appendPhrase call"
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   938
phrase2C (RepeatCycle e' p') = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   939
    e <- expr2C e'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   940
    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
   941
    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   942
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   943
phrase2C NOP = return $ text ";"
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   944
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   945
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   946
    f <- gets currentFunctionResult
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   947
    if null f then
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   948
        return $ text "return" <> semi
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   949
        else
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   950
        return $ text "return" <+> text f <> semi
7038
d853e4385241 Some more definitions and slight fixes
unc0rr
parents: 7037
diff changeset
   951
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
   952
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
7037
7edce323558f uAmmos.c now compiles (3 warnings though)
unc0rr
parents: 7036
diff changeset
   953
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
   954
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
   955
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
   956
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
   957
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
   958
phrase2C a = error $ "phrase2C: " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   959
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   960
wrapPhrase p@(Phrases _) = p
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   961
wrapPhrase p = Phrases [p]
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   962
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   963
expr2C :: Expression -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   964
expr2C (Expression s) = return $ text s
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   965
expr2C bop@(BinOp op expr1 expr2) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   966
    e1 <- expr2C expr1
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   967
    t1 <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   968
    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
   969
    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
   970
    case (op2C op, t1, t2) of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   971
        ("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString))
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   972
        ("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2  BTAString))
13344
4f9108f82879 Pas2C: Add support for char + ansistring (for real this time)
Wuzzy <Wuzzy2@mail.ru>
parents: 13306
diff changeset
   973
        ("+", BTChar, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprependA" (fff t1 t2  BTAString))
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   974
        ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2  BTBool))
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   975
        (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   976
        (_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   977
        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2  BTString))
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   978
        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2  BTString))
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   979
        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2  BTString))
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   980
        ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2  BTString))
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   981
        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2  BTBool))
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   982
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   983
        -- for function/procedure comparision
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   984
        ("==", BTVoid, _) -> procCompare expr1 expr2 "=="
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   985
        ("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "=="
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   986
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   987
        ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   988
        ("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!="
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   989
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   990
        ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2  BTBool))
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   991
        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2  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
   992
        ("&", 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
   993
        ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   994
        (_, BTRecord t1 _, BTRecord t2 _) -> do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   995
            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
   996
            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   997
        (_, BTRecord t1 _, BTInt _) -> do
7056
2884c7be6691 Recognize (hwFloat op int) expressions
unc0rr
parents: 7055
diff changeset
   998
            -- aw, "LongInt" here is hwengine-specific hack
2884c7be6691 Recognize (hwFloat op int) expressions
unc0rr
parents: 7055
diff changeset
   999
            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
2884c7be6691 Recognize (hwFloat op int) expressions
unc0rr
parents: 7055
diff changeset
  1000
            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1001
        ("in", _, _) ->
7057
c3eba84d1a98 Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents: 7056
diff changeset
  1002
            case expr2 of
c3eba84d1a98 Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents: 7056
diff changeset
  1003
                 SetExpression set -> do
c3eba84d1a98 Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents: 7056
diff changeset
  1004
                     ids <- mapM (id2C IOLookup) set
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1005
                     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
  1006
                     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
  1007
                 _ -> error "'in' against not set expression"
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1008
        (o, _, _) | o `elem` boolOps -> do
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1009
                        modify(\s -> s{lastType = BTBool})
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1010
                        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
  1011
                  | otherwise -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1012
                        o' <- return $ case o of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1013
                            "/(float)" -> text "/(float)" -- pascal returns real value
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1014
                            _ -> text o
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1015
                        e1' <- return $ case (o, t1, t2) of
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1016
                                ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1017
                                _ -> parens e1
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1018
                        e2' <- return $ case (o, t1, t2) of
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1019
                                ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1020
                                _ -> parens e2
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1021
                        return $ e1' <+> o' <+> e2'
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1022
    where
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1023
        fff t1 t2 = BTFunction False False [(False, t1), (False, t2)]
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1024
        boolOps = ["==", "!=", "<", ">", "<=", ">="]
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1025
        procCompare expr1 expr2 op =
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1026
            case (expr1, expr2) of
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1027
                (Reference r1, Reference r2) -> do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1028
                    id1 <- ref2C r1
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1029
                    id2 <- ref2C r2
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1030
                    return $ (parens id1) <+> text op <+> (parens id2)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1031
                (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1032
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1033
expr2C (NumberLiteral s) = do
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1034
    modify(\s -> s{lastType = BTInt True})
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1035
    return $ text s
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1036
expr2C (FloatLiteral s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1037
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
  1038
{-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
  1039
    modify(\s -> s{lastType = BTChar})
7043
7c080e5ac8d0 Some work to make more units compile after conversion to c
unc0rr
parents: 7042
diff changeset
  1040
    return . quotes . text $ escape a
7c080e5ac8d0 Some work to make more units compile after conversion to c
unc0rr
parents: 7042
diff changeset
  1041
    where
7c080e5ac8d0 Some work to make more units compile after conversion to c
unc0rr
parents: 7042
diff changeset
  1042
        escape '\'' = "\\\'"
7067
f98ec3aecf4e A solution to char vs string problem: mark single-letter strings with _S macro
unc0rr
parents: 7066
diff changeset
  1043
        escape a = [a]-}
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
  1044
expr2C (StringLiteral s) = addStringConst s
7072
159616c24bb8 More magic
unc0rr
parents: 7069
diff changeset
  1045
expr2C (PCharLiteral s) = return . doubleQuotes $ text s
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1046
expr2C (Reference ref) = do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1047
   isfunc <- gets isFunctionType
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1048
   modify(\s -> s{isFunctionType = False}) -- reset
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1049
   if isfunc then ref2CF ref False else ref2CF ref True
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1050
expr2C (PrefixOp op expr) = do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1051
    e <- expr2C expr
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1052
    lt <- gets lastType
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1053
    case lt of
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1054
        BTRecord t _ -> do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1055
            i <- op2CTyped op [SimpleType (Identifier t undefined)]
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1056
            ref2C $ FunCall [expr] (SimpleReference i)
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1057
        BTBool -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1058
            o <- return $ case op of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1059
                     "not" -> text "!"
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1060
                     _ -> text (op2C op)
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1061
            return $ o <> parens e
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1062
        _ -> return $ text (op2C op) <> parens e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1063
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
  1064
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
  1065
    modify(\s -> s{lastType = BTChar})
9964
12b0ed9910cd Render chars as hex numbers
unc0rr
parents: 9954
diff changeset
  1066
    return $ text "0x" <> text (showHex (read a) "")
7075
6bd7e5ad3f2b '\xd7af' -> 0xd7af
unc0rr
parents: 7072
diff changeset
  1067
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
  1068
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
  1069
7036
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1070
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1071
    e' <- liftM (map toLower . render) $ expr2C e
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1072
    lt <- gets lastType
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1073
    case lt of
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
  1074
         BTEnum _-> return $ int 0
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1075
         BTInt _ -> case e' of
7036
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1076
                  "longint" -> return $ int (-2147483648)
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1077
         BTArray {} -> return $ int 0
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1078
         _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1079
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1080
    e' <- liftM (map toLower . render) $ expr2C e
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1081
    lt <- gets lastType
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1082
    case lt of
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1083
         BTEnum a -> return . int $ length a - 1
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1084
         BTInt _ -> case e' of
7036
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1085
                  "longint" -> return $ int (2147483647)
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1086
         BTString -> return $ int 255
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1087
         BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1088
         _ -> 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
  1089
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1090
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1091
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1092
    e'<- expr2C e
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1093
    return $ text "(int)" <> parens e' <> text " - 1"
7062
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1094
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1095
    e' <- expr2C e
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1096
    lt <- gets lastType
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1097
    modify (\s -> s{lastType = BTInt True})
7062
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1098
    case lt of
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1099
         BTString -> return $ text "fpcrtl_Length" <> parens e'
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1100
         BTAString -> return $ text "fpcrtl_LengthA" <> parens e'
7335
3c6f08af7dac - Don't call Length() on variable size arrays
unc0rr
parents: 7333
diff changeset
  1101
         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
  1102
         BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
7062
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1103
         _ -> error $ "length() called on " ++ show lt
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1104
expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1105
    e1' <- expr2C e1
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1106
    e2' <- expr2C e2
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1107
    e' <- expr2C e
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1108
    lt <- gets lastType
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1109
    let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2'])
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1110
    case lt of
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1111
         BTString -> f "fpcrtl_copy"
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1112
         BTAString -> f "fpcrtl_copyA"
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1113
         _ -> error $ "copy() called on " ++ show lt
13306
806347b3c978 Improve error message a bit
unc0rr
parents: 11840
diff changeset
  1114
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1115
expr2C (BuiltInFunCall params ref) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1116
    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
  1117
    t <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1118
    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
  1119
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1120
        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
  1121
            modify (\s -> s{lastType = t'})
13306
806347b3c978 Improve error message a bit
unc0rr
parents: 11840
diff changeset
  1122
        _ -> error $ "BuiltInFunCall `" ++ show ref ++ "`, lastType: " ++ show t
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1123
    return $
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1124
        r <> parens (hsep . punctuate (char ',') $ ps)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1125
expr2C a = error $ "Don't know how to render " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
  1126
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1127
ref2CF :: Reference -> Bool -> State RenderState Doc
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1128
ref2CF (SimpleReference name) addParens = 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
  1129
    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
  1130
    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
  1131
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1132
         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
  1133
             modify(\s -> s{lastType = rt})
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1134
             return $ if addParens then i <> parens empty else i --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
  1135
         _ -> return $ i
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1136
ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1137
    i <- ref2C r
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1138
    t <- gets lastType
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1139
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1140
         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
  1141
             modify(\s -> s{lastType = rt})
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
  1142
             return $ if addParens then i <> parens empty else i
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1143
         _ -> return $ i
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1144
ref2CF r _ = ref2C r
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
  1145
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
  1146
ref2C :: Reference -> State RenderState Doc
6854
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
  1147
-- rewrite into proper form
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1148
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1149
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1150
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1151
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1152
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
  1153
-- conversion routines
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1154
ref2C ae@(ArrayElement [expr] ref) = do
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1155
    e <- expr2C expr
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1156
    r <- ref2C ref
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
  1157
    t <- gets lastType
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
  1158
    case t of
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
  1159
         (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1160
--         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1161
--         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1162
         BTString -> modify (\st -> st{lastType = BTChar})
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1163
         BTAString -> modify (\st -> st{lastType = BTChar})
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1164
         (BTPointerTo t) -> do
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1165
                t'' <- fromPointer (show t) =<< gets lastType
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1166
                case t'' of
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1167
                     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
  1168
                     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
  1169
         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1170
    case t of
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1171
         BTString ->  return $ r <> text ".s" <> brackets e
10127
7f29a65aa1e4 It compiles \o/
unc0rr
parents: 10124
diff changeset
  1172
         BTAString ->  return $ r <> text ".s" <> brackets e
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1173
         _ -> return $ r <> brackets e
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
  1174
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
  1175
ref2C rf@(RecordField (Dereference ref1) ref2) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1176
    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
  1177
    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
  1178
    r2 <- case t of
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
  1179
        BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1180
        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
  1181
        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1182
    return $
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1183
        r1 <> text "->" <> r2
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
  1184
ref2C rf@(RecordField ref1 ref2) = do
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
  1185
    r1 <- ref2C ref1
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
  1186
    t <- gets lastType
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
  1187
    case t of
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1188
        BTRecord _ rs -> do
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
  1189
            r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
  1190
            return $ r1 <> text "." <> r2
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1191
        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
  1192
        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
  1193
ref2C d@(Dereference ref) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
  1194
    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
  1195
    t <- fromPointer (show d) =<< gets lastType
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
  1196
    modify (\st -> st{lastType = t})
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
  1197
    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
  1198
ref2C f@(FunCall params ref) = do
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1199
    r <- fref2C ref
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
  1200
    t <- gets lastType
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
  1201
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1202
        BTFunction _ _ bts t' -> do
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
  1203
            ps <- liftM (parens . hsep . punctuate (char ',')) $
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1204
                    if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
  1205
                    then
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1206
                        mapM expr2CHelper (zip params bts)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1207
                    else 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
  1208
            modify (\s -> s{lastType = t'})
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
  1209
            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
  1210
        _ -> 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
  1211
                  (SimpleReference i, [p]) -> ref2C $ TypeCast i p
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1212
                  _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1213
    where
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1214
    fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1215
    fref2C a = ref2C a
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1216
    expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1217
    expr2CHelper (e, (_, BTFunction _ _ _ _)) = do
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1218
        modify (\s -> s{isFunctionType = True})
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1219
        expr2C e
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1220
    expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1221
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1222
ref2C (Address ref) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1223
    r <- ref2C ref
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
  1224
    lt <- gets lastType
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
  1225
    case lt of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1226
        BTFunction True _ _ _ -> return $ text "&" <> parens r
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
  1227
        _ -> 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
  1228
ref2C (TypeCast t'@(Identifier i _) expr) = do
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1229
    lt <- expr2C expr >> gets lastType
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1230
    case (map toLower i, lt) of
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1231
        ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1232
        ("pchar", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pcharA" $ BTPointerTo BTChar))
10124
aabd1b75d5a3 Even more explicit type conversions and other stuff to help pas2c use ansistrings
unc0rr
parents: 10121
diff changeset
  1233
        ("shortstring", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString))
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1234
        ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
10127
7f29a65aa1e4 It compiles \o/
unc0rr
parents: 10124
diff changeset
  1235
        ("ansistring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString))
10121
8b65699beb56 Implement a bit of astring
unc0rr
parents: 10120
diff changeset
  1236
        ("ansistring", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString))
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1237
        (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
  1238
            e <- expr2C expr
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1239
            t <- id2C IOLookup t'
7038
d853e4385241 Some more definitions and slight fixes
unc0rr
parents: 7037
diff changeset
  1240
            return . parens $ parens t <> e
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
  1241
ref2C (RefExpression expr) = expr2C expr
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
  1242
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1243
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1244
op2C :: String -> String
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1245
op2C "or" = "|"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1246
op2C "and" = "&"
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1247
op2C "not" = "~"
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1248
op2C "xor" = "^"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1249
op2C "div" = "/"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1250
op2C "mod" = "%"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1251
op2C "shl" = "<<"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1252
op2C "shr" = ">>"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1253
op2C "<>" = "!="
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1254
op2C "=" = "=="
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1255
op2C "/" = "/(float)"
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1256
op2C a = a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
  1257