tools/pas2c/Pas2C.hs
author alfadur
Wed, 21 Sep 2022 06:55:31 +0300
branch1.0.0
changeset 15896 fac577eb8756
parent 15895 f8a3f204242d
child 15912 5e8d2a8eb473
permissions -rw-r--r--
fix the other 2 pred/succ conversions
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
13842
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
    16
import Data.List (find, stripPrefix)
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   148
            mapM_ (tvar2C True False True False False) tvs
7429
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   154
            mapM_ (tvar2C True False True False 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 ++ "'..."
13914
5988e73080a3 Make converter for uLandTemplates into yaml
unc0rr
parents: 13899
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   242
    main <- liftM head $ tvar2C True False True True False
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   257
    tv <- typesAndVars2C True True True False 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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   262
    tv <- typesAndVars2C True False 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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   269
    tv <- typesAndVars2C True False True 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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   286
typesAndVars2C :: Bool -> Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   287
typesAndVars2C b externVar includeType static (TypesAndVars ts) = do
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
   288
    checkDuplicateFunDecls ts
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   289
    liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False static) 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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   462
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True False) 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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   521
        ph <- liftM2 ($+$) (typesAndVars2C False False True False 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)
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   558
tvar2C :: Bool -> Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
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 []
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   576
tvar2C _ externVar includeType ignoreInit static (VarDeclaration _ isConst (ids, t) mInitExpr) = do
15886
c63d0ea4907d Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents: 14378
diff changeset
   577
    t' <- liftM ((declDetails <+>) . ) $ type2C t
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   578
    ie <- initExpr mInitExpr
6979
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   579
    lt <- gets lastType
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   580
    case (isConst, lt, ids, mInitExpr) of
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   581
         (True, BTInt _, [i], Just _) -> do
6979
cd28fe36170a Declare const ints as enums
unc0rr
parents: 6967
diff changeset
   582
             i' <- id2CTyped t i
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   583
             return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
7002
5d817ba976f7 Render float consts into defines
unc0rr
parents: 6980
diff changeset
   584
         (True, BTFloat, [i], Just e) -> do
5d817ba976f7 Render float consts into defines
unc0rr
parents: 6980
diff changeset
   585
             i' <- id2CTyped t i
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   586
             ie' <- initExpr2C e
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   587
             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
   588
         (_, 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
   589
         (_, BTArray r _ _, [i], _) -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   590
            i' <- id2CTyped t i
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   591
            ie' <- return $ case (r, mInitExpr, ignoreInit) of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   592
                (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
   593
                (_, _, _) -> ie
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   594
            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
   595
            case (r, ignoreInit) of
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   596
                (RangeInfinite, False) ->
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   597
                    -- 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
   598
                    return $ [dimDecl] ++ result
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   599
                    where
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   600
                        arrayDimStr = show $ arrayDimension t
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   601
                        arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
15886
c63d0ea4907d Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents: 14378
diff changeset
   602
                        dimDecl = varDeclDecision isConst includeType (declDetails <+> text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   603
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   604
                (_, _) -> return result
8442
535a00ca0d35 whitespaces and tabs again
koda
parents: 7529
diff changeset
   605
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   606
         _ -> 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
   607
    where
15886
c63d0ea4907d Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents: 14378
diff changeset
   608
    declDetails = if isConst then text "static const" else if externVar
c63d0ea4907d Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents: 14378
diff changeset
   609
                                                            then text "extern"
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   610
                                                            else if static then text "static" else empty
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
13899
0ce8aad17c24 IFDEF out missing function with FIXME, revert pas2c change in 0ecf77e203c0 as suggested by unc0rr, another string annotation
nemo
parents: 13883
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
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
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
13878
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13842
diff changeset
   702
initExpr2C' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do
13879
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13877
diff changeset
   703
    void $ initExpr2C e
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13877
diff changeset
   704
    t <- gets lastType
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13877
diff changeset
   705
    case t of
84b2191efde9 Backed out changeset aed7ee68305a
Wuzzy <Wuzzy2@mail.ru>
parents: 13877
diff changeset
   706
         (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
13878
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13842
diff changeset
   707
         BTInt _ -> case e' of
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13842
diff changeset
   708
                  (Identifier "LongInt" _) -> return $ int (2147483647)
13880
885ee14fe640 Fix previous patch, add support for High(Longword)
unc0rr
parents: 13878
diff changeset
   709
                  (Identifier "LongWord" _) -> return $ text "4294967295"
885ee14fe640 Fix previous patch, add support for High(Longword)
unc0rr
parents: 13878
diff changeset
   710
                  _ -> error $ "BuiltInFunction 'high' in initExpr: " ++ show e'
13878
bc90a932a4b3 Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents: 13842
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
15896
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
   714
initExpr2C' (BuiltInFunction "succ" [e]) = 
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
   715
    liftM (parens . (<> text " + 1")) $ initExpr2C' e
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
   716
initExpr2C' (BuiltInFunction "pred" [e]) = 
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
   717
    liftM (parens . (<> text " - 1")) $ initExpr2C' e
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   718
initExpr2C' b@(BuiltInFunction _ _) = error $ show b
10131
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   719
initExpr2C' (InitTypeCast t' i) = do
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   720
    e <- initExpr2C i
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   721
    t <- id2C IOLookup t'
4b4a043111f4 - pas2c recognizes typecasts in initialization expressions
unc0rr
parents: 10129
diff changeset
   722
    return . parens $ parens t <> e
7052
cefb73639f70 Be more wise about constant initialization expressions being not arrays
unc0rr
parents: 7046
diff changeset
   723
initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   724
6887
19d77932ea91 Render some builtin functions
unc0rr
parents: 6886
diff changeset
   725
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   726
range2C :: InitExpression -> State RenderState [Doc]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   727
range2C (InitString [a]) = return [quotes $ text [a]]
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   728
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   729
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
   730
range2C a = liftM (flip (:) []) $ initExpr2C a
6391
bd5851ab3157 - Parse sets initialization
unc0rr
parents: 6355
diff changeset
   731
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   732
baseType2C :: String -> BaseType -> Doc
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   733
baseType2C _ BTFloat = text "float"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   734
baseType2C _ BTBool = text "bool"
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   735
baseType2C _ BTString = text "string255"
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   736
baseType2C _ BTAString = text "astring"
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   737
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   738
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   739
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
   740
type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   741
type2C t = do
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   742
    r <- type2C' t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   743
    rt <- resolveType t
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   744
    modify (\st -> st{lastType = rt})
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   745
    return r
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   746
    where
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   747
    type2C' VoidType = return (text "void" <+>)
10111
459bc720cea1 Drop support for other string types than string255
unc0rr
parents: 10015
diff changeset
   748
    type2C' String = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   749
    type2C' AString = return (text "astring" <+>)
7034
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   750
    type2C' (PointerTo (SimpleType i)) = do
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   751
        i' <- id2C IODeferred i
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   752
        lt <- gets lastType
e3639ce1d4f8 (PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents: 7033
diff changeset
   753
        case lt of
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   754
             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
   755
             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
   756
             _ -> 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
   757
    type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   758
    type2C' (RecordType tvs union) = do
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   759
        t' <- withState' f $ mapM (tvar2C False False True False False) tvs
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   760
        u <- unions
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   761
        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
   762
        where
7040
4aff2da0d0b3 Render function variables in struct with no mangling. 13 C units are compilable now.
unc0rr
parents: 7039
diff changeset
   763
            f s = s{currentUnit = ""}
6886
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   764
            unions = case union of
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   765
                     Nothing -> return empty
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   766
                     Just a -> do
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   767
                         structs <- mapM struct2C a
4463ee51c9ec Render unions
unc0rr
parents: 6883
diff changeset
   768
                         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
   769
            struct2C stvs = do
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   770
                txts <- withState' f $ mapM (tvar2C False False True False False) stvs
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   771
                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi
6894
555a8d8db228 Some more progress with pas2c
unc0rr
parents: 6893
diff changeset
   772
    type2C' (RangeType r) = return (text "int" <+>)
6838
b1a0e7a52c04 More clean namespace, some fixes
unc0rr
parents: 6837
diff changeset
   773
    type2C' (Sequence ids) = do
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   774
        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
   775
        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
   776
        where
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   777
            bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
6894
555a8d8db228 Some more progress with pas2c
unc0rr
parents: 6893
diff changeset
   778
    type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
14257
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14256
diff changeset
   779
    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: 14256
diff changeset
   780
        t' <- type2C t
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14256
diff changeset
   781
        lt <- gets lastType
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14256
diff changeset
   782
        r1' <- initExpr2C (InitRange r1)
0f8b647ea317 corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents: 14256
diff changeset
   783
        r2' <- initExpr2C (InitRange r2)
14258
81fba21495a5 was a wrong copy apparently
alfadur
parents: 14257
diff changeset
   784
        return $ \i -> t' i <> brackets r1' <> brackets r2'
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   785
    type2C' (ArrayDecl (Just r) t) = do
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   786
        t' <- type2C t
7066
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   787
        lt <- gets lastType
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   788
        ft <- case lt of
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   789
                -- 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
   790
                _ -> return t'
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   791
        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
   792
        return $ \i -> ft i <> brackets r'
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   793
    type2C' (Set t) = return (text "<<set>>" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   794
    type2C' (FunctionType returnType params) = do
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   795
        t <- type2C returnType
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   796
        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
   797
        return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   798
    type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   799
    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
6878
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   800
    type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   801
    type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   802
    type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   803
    type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
0af34406b83d Improve rendering of function types, arrays, and more
unc0rr
parents: 6875
diff changeset
   804
    type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
6980
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   805
    type2C' (DeriveType r@(InitReference {})) = do
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   806
        initExpr2C r
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   807
        t <- gets lastType
07a710e22846 Better type deriving
unc0rr
parents: 6979
diff changeset
   808
        return (baseType2C (show r) t <+>)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
   809
    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
   810
    type2C' a = error $ "type2C: unknown type " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   811
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   812
phrase2C :: Phrase -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   813
phrase2C (Phrases p) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   814
    ps <- mapM phrase2C p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   815
    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   816
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   817
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
   818
phrase2C (ProcCall _ _) = error $ "ProcCall"{-do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   819
    r <- ref2C ref
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   820
    ps <- mapM expr2C params
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   821
    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   822
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   823
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   824
    p1 <- (phrase2C . wrapPhrase) phrase1
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   825
    el <- elsePart
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   826
    return $
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   827
        text "if" <> parens e $+$ p1 $+$ el
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   828
    where
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   829
    elsePart | isNothing mphrase2 = return $ empty
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   830
             | 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
   831
phrase2C asgn@(Assignment ref expr) = do
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   832
    r <- ref2C ref
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
   833
    t <- gets lastType
7066
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   834
    case (t, expr) of
10142
adb804cb2638 Reduce number of warnings in pas2c-generated code
unc0rr
parents: 10131
diff changeset
   835
        (_, Reference r') | ref == r' -> do
adb804cb2638 Reduce number of warnings in pas2c-generated code
unc0rr
parents: 10131
diff changeset
   836
            e <- ref2C r'
adb804cb2638 Reduce number of warnings in pas2c-generated code
unc0rr
parents: 10131
diff changeset
   837
            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
   838
        (BTFunction {}, (Reference r')) -> do
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   839
            e <- ref2C r'
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   840
            return $ r <+> text "=" <+> e <> semi
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   841
        (BTString, _) -> do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   842
            void $ expr2C expr
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   843
            lt <- gets lastType
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   844
            case lt of
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   845
                -- assume pointer to char for simplicity
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   846
                BTPointerTo _ -> do
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   847
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   848
                    return $ r <+> text "=" <+> e <> semi
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   849
                BTAString -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   850
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown))
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   851
                    return $ r <+> text "=" <+> e <> semi
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   852
                BTString -> do
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   853
                    e <- expr2C expr
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   854
                    return $ r <+> text "=" <+> e <> semi
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   855
                _ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   856
        (BTAString, _) -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   857
            void $ expr2C expr
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   858
            lt <- gets lastType
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   859
            case lt of
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   860
                -- assume pointer to char for simplicity
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   861
                BTPointerTo _ -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   862
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown))
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   863
                    return $ r <+> text "=" <+> e <> semi
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   864
                BTString -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   865
                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown))
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   866
                    return $ r <+> text "=" <+> e <> semi
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   867
                BTAString -> do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   868
                    e <- expr2C expr
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   869
                    return $ r <+> text "=" <+> e <> semi
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   870
                _ -> 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
   871
        (BTArray _ _ _, _) -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   872
            case expr of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   873
                Reference er -> do
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
   874
                    void $ ref2C er
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   875
                    exprT <- gets lastType
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   876
                    case exprT of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   877
                        BTArray RangeInfinite _ _ ->
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   878
                            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
   879
                        BTArray _ _ _ -> phrase2C $
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   880
                                ProcCall (FunCall
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   881
                                    [
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   882
                                    Reference $ ref
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   883
                                    , Reference $ RefExpression expr
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   884
                                    , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" 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
                                    (SimpleReference (Identifier "memcpy" BTUnknown))
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: 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
   889
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
   890
                _ -> 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
   891
        _ -> do
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   892
            e <- expr2C expr
12cc2bd84b0b Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents: 7062
diff changeset
   893
            return $ r <+> text "=" <+> e <> semi
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   894
phrase2C (WhileCycle expr phrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   895
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   896
    p <- phrase2C $ wrapPhrase phrase
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   897
    return $ text "while" <> parens e $$ p
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   898
phrase2C (SwitchCase expr cases mphrase) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   899
    e <- expr2C expr
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   900
    cs <- mapM case2C cases
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   901
    d <- dflt
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   902
    return $
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
   903
        text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   904
    where
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   905
    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   906
    case2C (e, p) = do
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   907
        ies <- mapM range2C e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   908
        ph <- phrase2C p
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   909
        return $
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   910
             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
   911
    dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
6874
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   912
         | otherwise = do
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   913
             ph <- mapM phrase2C $ fromJust mphrase
b9e2e509a42d Better handle switch statement
unc0rr
parents: 6872
diff changeset
   914
             return [text "default:" <+> nest 4 (vcat ph)]
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   915
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   916
phrase2C wb@(WithBlock ref p) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
   917
    r <- ref2C ref
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   918
    t <- gets lastType
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   919
    case t of
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   920
        (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
6845
3cbfc35f6c2e - Handle multidimensional arrays better
unc0rr
parents: 6843
diff changeset
   921
        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
   922
            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
   923
phrase2C (ForCycle i' e1' e2' p up) = do
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
   924
    i <- id2C IOLookup i'
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   925
    -- hackishly strip 'static' from type declaration to workaround the use of global variables in 'for' cycles in uLandGenMaze
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   926
    iType <- liftM (text . maybeStripPrefix "static " . show) $ gets lastIdTypeDecl
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   927
    e1 <- expr2C e1'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   928
    e2 <- expr2C e2'
7529
058fcb451b37 Check if 'for' cycle body is executed at least once
unc0rr
parents: 7513
diff changeset
   929
    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
   930
    ph <- phrase2C $ wrapPhrase p
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   931
    return . braces $
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   932
        i <+> text "=" <+> e1 <> semi
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   933
        $$
7529
058fcb451b37 Check if 'for' cycle body is executed at least once
unc0rr
parents: 7513
diff changeset
   934
        iType <+> iEnd <+> text "=" <+> e2 <> semi
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
   935
        $$
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   936
        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
   937
        text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   938
    where
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
   939
        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
   940
        appendPhrase _ _ = error "illegal appendPhrase call"
15887
6b10b0cdbeab Mark global variables in implementation section static
unC0Rr
parents: 15886
diff changeset
   941
        maybeStripPrefix prefix a = fromMaybe a $ stripPrefix prefix a
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   942
phrase2C (RepeatCycle e' p') = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   943
    e <- expr2C e'
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   944
    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
   945
    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   946
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   947
phrase2C NOP = return $ text ";"
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
   948
7134
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   949
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   950
    f <- gets currentFunctionResult
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   951
    if null f then
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   952
        return $ text "return" <> semi
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   953
        else
beb16926ae5c Some improvements to pas2c
unc0rr
parents: 7075
diff changeset
   954
        return $ text "return" <+> text f <> semi
7038
d853e4385241 Some more definitions and slight fixes
unc0rr
parents: 7037
diff changeset
   955
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
   956
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
7037
7edce323558f uAmmos.c now compiles (3 warnings though)
unc0rr
parents: 7036
diff changeset
   957
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
   958
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
   959
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
   960
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
   961
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
   962
phrase2C a = error $ "phrase2C: " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   963
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   964
wrapPhrase p@(Phrases _) = p
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
   965
wrapPhrase p = Phrases [p]
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
   966
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
   967
expr2C :: Expression -> State RenderState Doc
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   968
expr2C (Expression s) = return $ text s
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   969
expr2C bop@(BinOp op expr1 expr2) = do
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   970
    e1 <- expr2C expr1
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
   971
    t1 <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
   972
    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
   973
    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
   974
    case (op2C op, t1, t2) of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   975
        ("+", 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
   976
        ("+", 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
   977
        ("+", 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
   978
        ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2  BTBool))
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   979
        (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
   980
        (_, _, 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
   981
        ("+", 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
   982
        ("+", 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
   983
        ("+", 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
   984
        ("+", 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
   985
        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2  BTBool))
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   986
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   987
        -- for function/procedure comparision
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   988
        ("==", BTVoid, _) -> procCompare expr1 expr2 "=="
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   989
        ("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "=="
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   990
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   991
        ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   992
        ("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!="
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
   993
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
   994
        ("==", 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
   995
        ("!=", 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
   996
        ("&", 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
   997
        ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   998
        (_, BTRecord t1 _, BTRecord t2 _) -> do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
   999
            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
  1000
            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1001
        (_, BTRecord t1 _, BTInt _) -> do
7056
2884c7be6691 Recognize (hwFloat op int) expressions
unc0rr
parents: 7055
diff changeset
  1002
            -- aw, "LongInt" here is hwengine-specific hack
2884c7be6691 Recognize (hwFloat op int) expressions
unc0rr
parents: 7055
diff changeset
  1003
            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
2884c7be6691 Recognize (hwFloat op int) expressions
unc0rr
parents: 7055
diff changeset
  1004
            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1005
        ("in", _, _) ->
7057
c3eba84d1a98 Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents: 7056
diff changeset
  1006
            case expr2 of
c3eba84d1a98 Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents: 7056
diff changeset
  1007
                 SetExpression set -> do
c3eba84d1a98 Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents: 7056
diff changeset
  1008
                     ids <- mapM (id2C IOLookup) set
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1009
                     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
  1010
                     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
  1011
                 _ -> error "'in' against not set expression"
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1012
        (o, _, _) | o `elem` boolOps -> do
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1013
                        modify(\s -> s{lastType = BTBool})
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1014
                        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
  1015
                  | otherwise -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1016
                        o' <- return $ case o of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1017
                            "/(float)" -> text "/(float)" -- pascal returns real value
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1018
                            _ -> text o
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1019
                        e1' <- return $ case (o, t1, t2) of
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1020
                                ("-", 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
  1021
                                _ -> parens e1
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1022
                        e2' <- return $ case (o, t1, t2) of
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1023
                                ("-", 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
  1024
                                _ -> parens e2
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1025
                        return $ e1' <+> o' <+> e2'
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1026
    where
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1027
        fff t1 t2 = BTFunction False False [(False, t1), (False, t2)]
6923
d2405a6a86f5 uCommands compiles
unc0rr
parents: 6921
diff changeset
  1028
        boolOps = ["==", "!=", "<", ">", "<=", ">="]
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1029
        procCompare expr1 expr2 op =
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1030
            case (expr1, expr2) of
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1031
                (Reference r1, Reference r2) -> do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1032
                    id1 <- ref2C r1
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1033
                    id2 <- ref2C r2
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1034
                    return $ (parens id1) <+> text op <+> (parens id2)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1035
                (_, _) -> 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
  1036
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1037
expr2C (NumberLiteral s) = do
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1038
    modify(\s -> s{lastType = BTInt True})
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1039
    return $ text s
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1040
expr2C (FloatLiteral s) = return $ text s
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1041
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
  1042
{-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
  1043
    modify(\s -> s{lastType = BTChar})
7043
7c080e5ac8d0 Some work to make more units compile after conversion to c
unc0rr
parents: 7042
diff changeset
  1044
    return . quotes . text $ escape a
7c080e5ac8d0 Some work to make more units compile after conversion to c
unc0rr
parents: 7042
diff changeset
  1045
    where
7c080e5ac8d0 Some work to make more units compile after conversion to c
unc0rr
parents: 7042
diff changeset
  1046
        escape '\'' = "\\\'"
7067
f98ec3aecf4e A solution to char vs string problem: mark single-letter strings with _S macro
unc0rr
parents: 7066
diff changeset
  1047
        escape a = [a]-}
6896
23b38e530967 Move all strings into constants to make them of string255 type
unc0rr
parents: 6895
diff changeset
  1048
expr2C (StringLiteral s) = addStringConst s
7072
159616c24bb8 More magic
unc0rr
parents: 7069
diff changeset
  1049
expr2C (PCharLiteral s) = return . doubleQuotes $ text s
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1050
expr2C (Reference ref) = do
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1051
   isfunc <- gets isFunctionType
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1052
   modify(\s -> s{isFunctionType = False}) -- reset
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1053
   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
  1054
expr2C (PrefixOp op expr) = do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1055
    e <- expr2C expr
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1056
    lt <- gets lastType
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1057
    case lt of
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1058
        BTRecord t _ -> do
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1059
            i <- op2CTyped op [SimpleType (Identifier t undefined)]
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1060
            ref2C $ FunCall [expr] (SimpleReference i)
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1061
        BTBool -> do
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1062
            o <- return $ case op of
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1063
                     "not" -> text "!"
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1064
                     _ -> text (op2C op)
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1065
            return $ o <> parens e
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1066
        _ -> return $ text (op2C op) <> parens e
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1067
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
  1068
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
  1069
    modify(\s -> s{lastType = BTChar})
9964
12b0ed9910cd Render chars as hex numbers
unc0rr
parents: 9954
diff changeset
  1070
    return $ text "0x" <> text (showHex (read a) "")
7075
6bd7e5ad3f2b '\xd7af' -> 0xd7af
unc0rr
parents: 7072
diff changeset
  1071
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
  1072
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
  1073
7036
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1074
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1075
    e' <- liftM (map toLower . render) $ expr2C e
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1076
    lt <- gets lastType
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1077
    case lt of
10113
b26c2772e754 Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents: 10111
diff changeset
  1078
         BTEnum _-> return $ int 0
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1079
         BTInt _ -> case e' of
7036
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1080
                  "longint" -> return $ int (-2147483648)
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1081
         BTArray {} -> return $ int 0
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1082
         _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1083
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1084
    e' <- liftM (map toLower . render) $ expr2C e
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1085
    lt <- gets lastType
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1086
    case lt of
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1087
         BTEnum a -> return . int $ length a - 1
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1088
         BTInt _ -> case e' of
7036
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1089
                  "longint" -> return $ int (2147483647)
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1090
         BTString -> return $ int 255
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1091
         BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
d99934a827f0 Implement built-in functions Low() and High()
unc0rr
parents: 7034
diff changeset
  1092
         _ -> 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
  1093
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
15896
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
  1094
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = 
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
  1095
    liftM (parens . (<> text " + 1")) $ expr2C e
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
  1096
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = 
fac577eb8756 fix the other 2 pred/succ conversions
alfadur
parents: 15895
diff changeset
  1097
    liftM (parens . (<> text " - 1") . ((text "(int)") <>) . parens) $ expr2C e
7062
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1098
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1099
    e' <- expr2C e
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1100
    lt <- gets lastType
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1101
    modify (\s -> s{lastType = BTInt True})
7062
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1102
    case lt of
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1103
         BTString -> return $ text "fpcrtl_Length" <> parens e'
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1104
         BTAString -> return $ text "fpcrtl_LengthA" <> parens e'
7335
3c6f08af7dac - Don't call Length() on variable size arrays
unc0rr
parents: 7333
diff changeset
  1105
         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
  1106
         BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
7062
7efe16575779 Recognize length on arrays as a separate function
unc0rr
parents: 7060
diff changeset
  1107
         _ -> error $ "length() called on " ++ show lt
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1108
expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1109
    e1' <- expr2C e1
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1110
    e2' <- expr2C e2
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1111
    e' <- expr2C e
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1112
    lt <- gets lastType
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1113
    let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2'])
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1114
    case lt of
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1115
         BTString -> f "fpcrtl_copy"
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1116
         BTAString -> f "fpcrtl_copyA"
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1117
         _ -> error $ "copy() called on " ++ show lt
13306
806347b3c978 Improve error message a bit
unc0rr
parents: 11840
diff changeset
  1118
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1119
expr2C (BuiltInFunCall params ref) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1120
    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
  1121
    t <- gets lastType
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1122
    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
  1123
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1124
        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
  1125
            modify (\s -> s{lastType = t'})
13306
806347b3c978 Improve error message a bit
unc0rr
parents: 11840
diff changeset
  1126
        _ -> error $ "BuiltInFunCall `" ++ show ref ++ "`, lastType: " ++ show t
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1127
    return $
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1128
        r <> parens (hsep . punctuate (char ',') $ ps)
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1129
expr2C a = error $ "Don't know how to render " ++ show a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
  1130
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1131
ref2CF :: Reference -> Bool -> State RenderState Doc
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1132
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
  1133
    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
  1134
    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
  1135
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1136
         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
  1137
             modify(\s -> s{lastType = rt})
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1138
             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
  1139
         _ -> return $ i
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1140
ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1141
    i <- ref2C r
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1142
    t <- gets lastType
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1143
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1144
         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
  1145
             modify(\s -> s{lastType = rt})
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
  1146
             return $ if addParens then i <> parens empty else i
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1147
         _ -> return $ i
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1148
ref2CF r _ = ref2C r
6307
25cfd9f4a567 Even more improvements to the parser and converter
unc0rr
parents: 6277
diff changeset
  1149
6512
0df7f6697939 "System" unit to help converter
unc0rr
parents: 6511
diff changeset
  1150
ref2C :: Reference -> State RenderState Doc
6854
873929cbd54b Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents: 6853
diff changeset
  1151
-- rewrite into proper form
6858
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1152
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1153
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1154
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1155
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
608c8b057c3b Improve rendering into C
unc0rr
parents: 6855
diff changeset
  1156
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
  1157
-- conversion routines
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1158
ref2C ae@(ArrayElement [expr] ref) = do
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1159
    e <- expr2C expr
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1160
    r <- ref2C ref
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
  1161
    t <- gets lastType
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
  1162
    case t of
6893
69cc0166be8d - Track array size to use for High function
unc0rr
parents: 6891
diff changeset
  1163
         (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1164
--         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1165
--         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1166
         BTString -> modify (\st -> st{lastType = BTChar})
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1167
         BTAString -> modify (\st -> st{lastType = BTChar})
6872
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1168
         (BTPointerTo t) -> do
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1169
                t'' <- fromPointer (show t) =<< gets lastType
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1170
                case t'' of
0f6eef4a07c8 Better support for strings
unc0rr
parents: 6860
diff changeset
  1171
                     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
  1172
                     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
  1173
         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1174
    case t of
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1175
         BTString ->  return $ r <> text ".s" <> brackets e
10127
7f29a65aa1e4 It compiles \o/
unc0rr
parents: 10124
diff changeset
  1176
         BTAString ->  return $ r <> text ".s" <> brackets e
6895
31def088a870 Many small improvements to pas2c
unc0rr
parents: 6894
diff changeset
  1177
         _ -> return $ r <> brackets e
6663
2c4151afad0c Workaround pointers to not yet defined types
unc0rr
parents: 6653
diff changeset
  1178
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
  1179
ref2C rf@(RecordField (Dereference ref1) ref2) = do
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1180
    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
  1181
    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
  1182
    r2 <- case t of
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
  1183
        BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1184
        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
  1185
        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1186
    return $
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1187
        r1 <> text "->" <> r2
6618
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
  1188
ref2C rf@(RecordField ref1 ref2) = do
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
  1189
    r1 <- ref2C ref1
2d3232069c4b Propagate types on identifiers
unc0rr
parents: 6552
diff changeset
  1190
    t <- gets lastType
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
  1191
    case t of
7042
de20086a6bcc Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents: 7040
diff changeset
  1192
        BTRecord _ rs -> do
7511
1841d5cf899f More mess in pas2c:
unc0rr
parents: 7429
diff changeset
  1193
            r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
7033
583049a98113 Prepend unit name to function identifiers
unc0rr
parents: 7032
diff changeset
  1194
            return $ r1 <> text "." <> r2
7055
4c495c8f02da Convert "unit.function()" properly
unc0rr
parents: 7054
diff changeset
  1195
        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
  1196
        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
  1197
ref2C d@(Dereference ref) = do
6827
a0e152e68337 Dig into namespaces even more
unc0rr
parents: 6826
diff changeset
  1198
    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
  1199
    t <- fromPointer (show d) =<< gets lastType
6834
2af81d3b176d Resolve deferred type on dereference
unc0rr
parents: 6827
diff changeset
  1200
    modify (\st -> st{lastType = t})
6859
cd0697c7e88b Unwind 'with' construction
unc0rr
parents: 6858
diff changeset
  1201
    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
  1202
ref2C f@(FunCall params ref) = do
7032
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1203
    r <- fref2C ref
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
  1204
    t <- gets lastType
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
  1205
    case t of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1206
        BTFunction _ _ bts t' -> do
10015
4feced261c68 partial merge of the webgl branch
koda
parents: 9982
diff changeset
  1207
            ps <- liftM (parens . hsep . punctuate (char ',')) $
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1208
                    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
  1209
                    then
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1210
                        mapM expr2CHelper (zip params bts)
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1211
                    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
  1212
            modify (\s -> s{lastType = t'})
6826
8fadeefdd352 Just some further work
unc0rr
parents: 6817
diff changeset
  1213
            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
  1214
        _ -> 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
  1215
                  (SimpleReference i, [p]) -> ref2C $ TypeCast i p
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1216
                  _ -> 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
  1217
    where
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1218
    fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
5685ca1ec9bf Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents: 7019
diff changeset
  1219
    fref2C a = ref2C a
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1220
    expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1221
    expr2CHelper (e, (_, BTFunction _ _ _ _)) = do
8020
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1222
        modify (\s -> s{isFunctionType = True})
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1223
        expr2C e
00b1facf2805 merge xymeng pas2c
koda
parents: 8001
diff changeset
  1224
    expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1225
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1226
ref2C (Address ref) = do
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1227
    r <- ref2C ref
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
  1228
    lt <- gets lastType
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
  1229
    case lt of
10129
cd2a64a1f4aa - Pas2C: make use of 'external' function decorator
unc0rr
parents: 10127
diff changeset
  1230
        BTFunction True _ _ _ -> return $ text "&" <> parens r
7333
520a16a14747 Properly convert taking address of function with var parameters
unc0rr
parents: 7329
diff changeset
  1231
        _ -> 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
  1232
ref2C (TypeCast t'@(Identifier i _) expr) = do
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1233
    lt <- expr2C expr >> gets lastType
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1234
    case (map toLower i, lt) of
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1235
        ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
10120
b7f632c12784 Pas2C recognizes ansistrings
unc0rr
parents: 10113
diff changeset
  1236
        ("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
  1237
        ("shortstring", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString))
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1238
        ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
10127
7f29a65aa1e4 It compiles \o/
unc0rr
parents: 10124
diff changeset
  1239
        ("ansistring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString))
10121
8b65699beb56 Implement a bit of astring
unc0rr
parents: 10120
diff changeset
  1240
        ("ansistring", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString))
7151
ec15d9e1a7e3 pas2c stuff
unc0rr
parents: 7134
diff changeset
  1241
        (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
  1242
            e <- expr2C expr
7315
59b5b19e6604 Remove trailing spaces
unc0rr
parents: 7265
diff changeset
  1243
            t <- id2C IOLookup t'
7038
d853e4385241 Some more definitions and slight fixes
unc0rr
parents: 7037
diff changeset
  1244
            return . parens $ parens t <> e
6467
090269e528df - Improve parsing of prefix operators
unc0rr
parents: 6455
diff changeset
  1245
ref2C (RefExpression expr) = expr2C expr
6355
734fed7aefd3 Introduce initialization expressions
unc0rr
parents: 6317
diff changeset
  1246
6509
648caa66991b Convert into Reader monad
unc0rr
parents: 6499
diff changeset
  1247
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1248
op2C :: String -> String
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1249
op2C "or" = "|"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1250
op2C "and" = "&"
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1251
op2C "not" = "~"
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1252
op2C "xor" = "^"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1253
op2C "div" = "/"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1254
op2C "mod" = "%"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1255
op2C "shl" = "<<"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1256
op2C "shr" = ">>"
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1257
op2C "<>" = "!="
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1258
op2C "=" = "=="
7429
fcf13e40d6b6 Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents: 7335
diff changeset
  1259
op2C "/" = "/(float)"
6860
f4238c683ec7 Convert some operators
unc0rr
parents: 6859
diff changeset
  1260
op2C a = a
6273
13262c6e5027 Starting pas2C using library called 'pretty'
unc0rr
parents:
diff changeset
  1261