author  alfadur 
Sat, 16 Oct 2021 04:06:47 +0300  
changeset 15825  e48c3333c404 
parent 15754  aa011799cb63 
permissions  rwrr 
6858  1 
{# LANGUAGE ScopedTypeVariables #} 
6273  2 
module Pas2C where 
3 

13819
db1b680bd8d3
Resolve ambiguity of <> in Pas2C.hs
Wuzzy <Wuzzy2@mail.ru>
parents:
13344
diff
changeset

4 
import Prelude hiding ((<>)) 
6273  5 
import Text.PrettyPrint.HughesPJ 
6 
import Data.Maybe 

6277  7 
import Data.Char 
6511  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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

16 
import Data.List (find, stripPrefix) 
6858  17 
import Numeric 
6273  18 

10245  19 
import PascalParser 
6467  20 
import PascalUnitSyntaxTree 
6273  21 

6618  22 

7315  23 
data InsertOption = 
6663  24 
IOInsert 
7511  25 
 IOInsertWithType Doc 
6663  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  29 
 IODeferred 
30 

7511  31 
data Record = Record 
32 
{ 

33 
lcaseId :: String, 

34 
baseType :: BaseType, 

35 
typeDecl :: Doc 

36 
} 

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  39 
data RenderState = RenderState 
6516  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  43 
lastType :: BaseType, 
8020  44 
isFunctionType :: Bool,  set to true if the current function parameter is functiontype 
7511  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  49 
enums :: [(String, [String])],  store all declared enums 
7033  50 
currentUnit :: String, 
7134  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  53 
} 
7315  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  56 
rec2Records = map (\(a, b) > Record a b empty) 
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  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  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  69 
strs < gets stringConsts 
70 
let a = find ((==) str . snd) strs 

71 
if isJust a then 

6923  72 
do 
73 
modify (\s > s{lastType = BTString}) 

6921  74 
return . text . fst . fromJust $ a 
75 
else 

76 
do 

77 
i < getUniq 

78 
let sn = "__str" ++ show i 

79 
modify (\s > s{lastType = BTString, stringConsts = (sn, str) : strs}) 

80 
return $ text sn 

7315  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  90 
strInit :: String > Doc 
91 
strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a)) 

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  96 

6836  97 
docToLower :: Doc > Doc 
98 
docToLower = text . map toLower . render 

6512  99 

9982  100 
pas2C :: String > String > String > String > [String] > IO () 
101 
pas2C fn inputPath outputPath alternateInputPath symbols = do 

6455  102 
s < flip execStateT initState $ f fn 
7953  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  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  113 
fc' < liftIO 
114 
$ tryJust (guard . isDoesNotExistError) 

9982  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  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  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  132 

6514  133 

7953  134 
renderCFiles :: Map.Map String PascalUnit > String > IO () 
135 
renderCFiles units outputPath = do 

6514  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  138 
hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) 
6853  139 
writeFile "pas2c.log" $ unlines . map (\t > show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss 
7953  140 
mapM_ (toCFiles outputPath nss) u 
6516  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  143 
toNamespace nss (System tvs) = 
7069  144 
currentScope $ execState f (emptyState nss) 
145 
where 

146 
f = do 

147 
checkDuplicateFunDecls tvs 

15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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 reimplemented, 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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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  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  159 
withState' :: (RenderState > RenderState) > State RenderState a > State RenderState a 
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  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  168 
return a 
6827  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  174 

7511  175 
withRecordNamespace :: String > [Record] > State RenderState Doc > State RenderState Doc 
6859  176 
withRecordNamespace _ [] = error "withRecordNamespace: empty record" 
177 
withRecordNamespace prefix recs = withState' f 

6827  178 
where 
7039  179 
f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} 
7511  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  184 
toCFiles :: String > Map.Map String Records > (String, PascalUnit) > IO () 
185 
toCFiles _ _ (_, System _) = return () 

186 
toCFiles _ _ (_, Redo _) = return () 

10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

187 
toCFiles outputPath ns pu@(fileName, _) = do 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

188 
hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..." 
13887  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  192 
toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p 
7033  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  196 
enumDecl = (renderEnum2Strs (enums s) False) 
197 
enumImpl = (renderEnum2Strs (enums s) True) 

198 
writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl 

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  203 
render2C :: RenderState > State RenderState Doc > String 
8020  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  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  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  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  213 
enum2strBlock en = 
8020  214 
text "{" 
215 
$+$ 

216 
(nest 4 $ 

217 
text "switch(enumvar){" 

218 
$+$ 

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) 

220 
$+$ 

221 
text "default: assert(0);" 

222 
$+$ 

223 
(nest 4 $ text "return fpcrtl_make_string(\"nonsense\");") 

224 
$+$ 

225 
text "}" 

226 
) 

227 
$+$ 

228 
text "}" 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

229 

6467  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  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  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  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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

242 
main < liftM head $ tvar2C True False True True False 
10245  243 
(FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) 
244 
[VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing 

245 
, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] 

246 
(Just (TypesAndVars [], Phrases [mainResultInit, mainFunction]))) 

8020  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  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  256 
u < uses2C uses 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

257 
tv < typesAndVars2C True True True False tvars 
6965  258 
r < renderStringConsts 
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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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  265 

6512  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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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  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  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  278 
initMap = Map.empty 
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  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 

15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

286 
typesAndVars2C :: Bool > Bool > Bool > Bool > TypesAndVars > State RenderState Doc 
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

289 
liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False static) ts 
6273  290 

6816  291 
setBaseType :: BaseType > Identifier > Identifier 
292 
setBaseType bt (Identifier i _) = Identifier i bt 

293 

6512  294 
uses2C :: Uses > State RenderState Doc 
6516  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  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  299 
mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds 
6516  300 
return $ vcat . map (\i > text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses 
301 
where 

11840  302 
injectNamespace :: Identifier > State RenderState () 
6517  303 
injectNamespace (Identifier i _) = do 
6516  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  308 
uses2List (Uses ids) = map (\(Identifier i _) > i) ids 
6273  309 

6509  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  312 
setLastIdValues vv = (\s > s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) 
313 

6663  314 
id2C :: InsertOption > Identifier > State RenderState Doc 
7511  315 
id2C IOInsert i = id2C (IOInsertWithType empty) i 
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  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  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  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  337 
else 
338 
let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in 

7511  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  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  346 
if (isNothing v) then 
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

347 
modify (\s > s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) 
6663  348 
else 
7511  349 
let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 
6512  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  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  358 
else 
7511  359 
let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 
7315  360 

361 

8020  362 

6653  363 
id2CTyped :: TypeDecl > Identifier > State RenderState Doc 
7511  364 
id2CTyped = id2CTyped2 Nothing 
365 

366 
id2CTyped2 :: Maybe Doc > TypeDecl > Identifier > State RenderState Doc 

367 
id2CTyped2 md t (Identifier i _) = do 

6653  368 
tb < resolveType t 
7315  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  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  377 
id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) 
378 
_ > case md of 

379 
Nothing > id2C IOInsert (Identifier i tb) 

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  382 
typeVarDecl2BaseType :: [TypeVarDeclaration] > State RenderState [(Bool, BaseType)] 
383 
typeVarDecl2BaseType d = do 

384 
st < get 

385 
result < sequence $ concat $ map resolveType' d 

386 
put st  restore state (not sure if necessary) 

387 
return result 

388 
where 

389 
resolveType' :: TypeVarDeclaration > [State RenderState (Bool, BaseType)] 

390 
resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar) 

391 
resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration" 

392 
resolveTypeHelper' :: State RenderState BaseType > Bool > State RenderState (Bool, BaseType) 

393 
resolveTypeHelper' st b = do 

394 
bt < st 

395 
return (b, bt) 

10015  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  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  403 
f "uinteger" = BTInt False 
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  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  412 
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) 
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  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  418 
f :: TypeVarDeclaration > State RenderState [(String, BaseType)] 
7317  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  421 
resolveType (ArrayDecl (Just i) t) = do 
422 
t' < resolveType t 

8020  423 
return $ BTArray i (BTInt True) t' 
424 
resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t 

425 
resolveType (FunctionType t a) = do 

10015  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  428 
resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) 
429 
resolveType (DeriveType (InitNumber _)) = return (BTInt True) 

6835  430 
resolveType (DeriveType (InitFloat _)) = return BTFloat 
431 
resolveType (DeriveType (InitString _)) = return BTString 

8020  432 
resolveType (DeriveType (InitBinOp {})) = return (BTInt True) 
7151  433 
resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType 
8020  434 
resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) 
6835  435 
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool  TODO: derive from actual type 
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  438 
resolveType AString = return BTAString 
6826  439 
resolveType VoidType = return BTVoid 
6653  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  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  444 

6834  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  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 nonpointer type " ++ show t ++ "\n" ++ s 
6834  459 

7315  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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

462 
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True False) params 
6834  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  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  470 
hasPassByReference :: [TypeVarDeclaration] > Bool 
471 
hasPassByReference = or . map isVar 

472 
where 

473 
isVar (VarDeclaration v _ (_, _) _) = v 

474 
isVar _ = error $ "hasPassByReference called not on function parameters" 

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  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  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  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  497 
let decor = if overload then text "__attribute__((overloadable))" else empty 
498 
return [t empty <+> decor <+> text n <> parens p] 

7315  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  501 
let isVoid = case returnType of 
502 
VoidType > True 

503 
_ > False 

7315  504 

8020  505 
let res = docToLower $ text rv <> if isVoid then empty else text "_result" 
506 
t < type2C returnType 

507 
t' < gets lastType 

508 

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  511 
notDeclared < liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope 
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  514 
let resultId = if isVoid 
515 
then n  void type doesn't have result, solving recursive procedure calls 

516 
else (render res) 

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  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 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

521 
ph < liftM2 ($+$) (typesAndVars2C False False True False tvars) (phrase2C' phrase) 
6827  522 
return (p, ph) 
7315  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  529 
let inlineDecor = if inline then case notDeclared of 
530 
True > text "static inline" 

531 
False > text "inline" 

532 
else empty 

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  535 
define 
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  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  540 
text "{" 
541 
$+$ 

6836  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  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  553 
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv 
6618  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) 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

558 
tvar2C :: Bool > Bool > Bool > Bool > Bool > TypeVarDeclaration > State RenderState [Doc] 
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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 [] 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

562 
tvar2C _ _ includeType _ _ (TypeDeclaration i' t) = do 
6653  563 
i < id2CTyped t i' 
7039  564 
tp < type2C t 
8020  565 
let res = if includeType then [text "typedef" <+> tp i] else [] 
566 
case t of 

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  569 
return res 
570 
_ > return res 

7315  571 

15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
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  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 

15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

576 
tvar2C _ externVar includeType ignoreInit static (VarDeclaration _ isConst (ids, t) mInitExpr) = do 
15750
036263d63b05
Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents:
14357
diff
changeset

577 
t' < liftM ((declDetails <+>) . ) $ type2C t 
6980  578 
ie < initExpr mInitExpr 
6979  579 
lt < gets lastType 
580 
case (isConst, lt, ids, mInitExpr) of 

8020  581 
(True, BTInt _, [i], Just _) > do 
6979  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  584 
(True, BTFloat, [i], Just e) > do 
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  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  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}}") 
15750
036263d63b05
Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents:
14357
diff
changeset

602 
dimDecl = varDeclDecision isConst includeType (declDetails <+> text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp 
8442  603 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

604 
(_, _) > return result 
8442  605 

7511  606 
_ > liftM (map(\i > varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids 
6355  607 
where 
15750
036263d63b05
Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents:
14357
diff
changeset

608 
declDetails = if isConst then text "static const" else if externVar 
036263d63b05
Fix lack of declaration decorations for dynamic arrays in Pas2C
unc0rr
parents:
14357
diff
changeset

609 
then text "extern" 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

610 
else if static then text "static" else empty 
6509  611 
initExpr Nothing = return $ empty 
612 
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

613 
varDeclDecision True True varStr expStr = varStr <+> expStr 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

614 
varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

615 
varDeclDecision False False varStr expStr = varStr <+> expStr 
13878
0ce8aad17c24
IFDEF out missing function with FIXME, revert pas2c change in 0ecf77e203c0 as suggested by unc0rr, another string annotation
nemo
parents:
13862
diff
changeset

616 
varDeclDecision True False _ _ = empty 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

617 
arrayDimension a = case a of 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

618 
ArrayDecl Nothing t' > let a' = arrayDimension t' in 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

619 
if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

620 
ArrayDecl _ _ > error "Mixed dynamic array and static array are not supported." 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

621 
_ > 0 
7315  622 

15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

623 
tvar2C f _ _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do 
6880  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  626 

7315  627 

6880  628 
op2CTyped :: String > [TypeDecl] > State RenderState Identifier 
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  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  633 
where 
6880  634 
opStr = case op of 
635 
"+" > "add" 

636 
"" > "sub" 

637 
"*" > "mul" 

638 
"/" > "div" 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

639 
"/(float)" > "div" 
6880  640 
"=" > "eq" 
641 
"<" > "lt" 

642 
">" > "gt" 

7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

643 
"<>" > "neq" 
6880  644 
_ > error $ "op2CTyped: unknown op '" ++ op ++ "'" 
7315  645 

6880  646 
extractTypes :: [TypeVarDeclaration] > [TypeDecl] 
647 
extractTypes = concatMap f 

648 
where 

7317  649 
f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t 
6880  650 
f a = error $ "extractTypes: can't extract from " ++ show a 
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  666 
return $ parens $ e1 <+> text (op2C op) <+> e2 
8020  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  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  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  678 
(fs :: [Doc]) < mapM (\(Identifier a _, b) > liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields 
6886  679 
return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace 
9954  680 
initExpr2C' (InitArray [InitRecord fields]) = do 
681 
 e < initExpr2C $ InitRecord fields 

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  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  697 
initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ 
6887  698 
case e of 
699 
(Identifier "LongInt" _) > int (2^31) 

6893  700 
(Identifier "SmallInt" _) > int (2^15) 
701 
_ > error $ "BuiltInFunction 'low': " ++ show e 

13857
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13819
diff
changeset

702 
initExpr2C' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do 
13858  703 
void $ initExpr2C e 
704 
t < gets lastType 

705 
case t of 

706 
(BTArray i _ _) > initExpr2C' $ BuiltInFunction "pred" [InitRange i] 

13857
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13819
diff
changeset

707 
BTInt _ > case e' of 
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13819
diff
changeset

708 
(Identifier "LongInt" _) > return $ int (2147483647) 
13859
885ee14fe640
Fix previous patch, add support for High(Longword)
unc0rr
parents:
13857
diff
changeset

709 
(Identifier "LongWord" _) > return $ text "4294967295" 
885ee14fe640
Fix previous patch, add support for High(Longword)
unc0rr
parents:
13857
diff
changeset

710 
_ > error $ "BuiltInFunction 'high' in initExpr: " ++ show e' 
13857
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13819
diff
changeset

711 
a > error $ "BuiltInFunction 'high' in initExpr: " ++ show a ++ ": " ++ show hi 
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

712 
initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

713 
initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

714 
initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

715 
initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text "  1") $ initExpr2C' e 
7315  716 
initExpr2C' b@(BuiltInFunction _ _) = error $ show b 
10131
4b4a043111f4
 pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset

717 
initExpr2C' (InitTypeCast t' i) = do 
4b4a043111f4
 pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset

718 
e < initExpr2C i 
4b4a043111f4
 pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset

719 
t < id2C IOLookup t' 
4b4a043111f4
 pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset

720 
return . parens $ parens t <> e 
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

721 
initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a 
6391  722 

6887  723 

6874  724 
range2C :: InitExpression > State RenderState [Doc] 
725 
range2C (InitString [a]) = return [quotes $ text [a]] 

726 
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i 

727 
range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i > quotes $ text [i]) [a..b] 

728 
range2C a = liftM (flip (:) []) $ initExpr2C a 

6391  729 

6980  730 
baseType2C :: String > BaseType > Doc 
731 
baseType2C _ BTFloat = text "float" 

732 
baseType2C _ BTBool = text "bool" 

733 
baseType2C _ BTString = text "string255" 

10120  734 
baseType2C _ BTAString = text "astring" 
6980  735 
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s 
736 

6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

737 
type2C :: TypeDecl > State RenderState (Doc > Doc) 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

738 
type2C (SimpleType i) = liftM (\i' a > i' <+> a) $ id2C IOLookup i 
6838  739 
type2C t = do 
740 
r < type2C' t 

741 
rt < resolveType t 

742 
modify (\st > st{lastType = rt}) 

743 
return r 

744 
where 

6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

745 
type2C' VoidType = return (text "void" <+>) 
10111
459bc720cea1
Drop support for other string types than string255
unc0rr
parents:
10015
diff
changeset

746 
type2C' String = return (text "string255" <+>)return (text ("string" ++ show l) <+>) 
10120  747 
type2C' AString = return (text "astring" <+>) 
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

748 
type2C' (PointerTo (SimpleType i)) = do 
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

749 
i' < id2C IODeferred i 
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

750 
lt < gets lastType 
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

751 
case lt of 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

752 
BTRecord _ _ > return $ \a > text "struct __" <> i' <+> text "*" <+> a 
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

753 
BTUnknown > return $ \a > text "struct __" <> i' <+> text "*" <+> a 
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

754 
_ > return $ \a > i' <+> text "*" <+> a 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

755 
type2C' (PointerTo t) = liftM (\tx a > tx (parens $ text "*" <> a)) $ type2C t 
6838  756 
type2C' (RecordType tvs union) = do 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

757 
t' < withState' f $ mapM (tvar2C False False True False False) tvs 
6886  758 
u < unions 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

759 
return $ \i > text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i 
6886  760 
where 
7040
4aff2da0d0b3
Render function variables in struct with no mangling. 13 C units are compilable now.
unc0rr
parents:
7039
diff
changeset

761 
f s = s{currentUnit = ""} 
6886  762 
unions = case union of 
763 
Nothing > return empty 

764 
Just a > do 

765 
structs < mapM struct2C a 

766 
return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi 

10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

767 
struct2C stvs = do 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

768 
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

769 
return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi 
6894  770 
type2C' (RangeType r) = return (text "int" <+>) 
6838  771 
type2C' (Sequence ids) = do 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

772 
is < mapM (id2C IOInsert . setBaseType bt) ids 
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

773 
return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) > a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

774 
where 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

775 
bt = BTEnum $ map (\(Identifier i _) > map toLower i) ids 
6894  776 
type2C' (ArrayDecl Nothing t) = type2C (PointerTo t) 
14236
0f8b647ea317
corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents:
14235
diff
changeset

777 
type2C' (ArrayDecl (Just r1) (ArrayDecl (Just r2) t)) = do 
0f8b647ea317
corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents:
14235
diff
changeset

778 
t' < type2C t 
0f8b647ea317
corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents:
14235
diff
changeset

779 
lt < gets lastType 
0f8b647ea317
corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents:
14235
diff
changeset

780 
r1' < initExpr2C (InitRange r1) 
0f8b647ea317
corrected parsing joined with unC0Rr's corrected generating finally gives the right result
alfadur
parents:
14235
diff
changeset

781 
r2' < initExpr2C (InitRange r2) 
14237  782 
return $ \i > t' i <> brackets r1' <> brackets r2' 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

783 
type2C' (ArrayDecl (Just r) t) = do 
6858  784 
t' < type2C t 
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

785 
lt < gets lastType 
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

786 
ft < case lt of 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

787 
 BTFunction {} > type2C (PointerTo t) 
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

788 
_ > return t' 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

789 
r' < initExpr2C (InitRange r) 
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

790 
return $ \i > ft i <> brackets r' 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

791 
type2C' (Set t) = return (text "<<set>>" <+>) 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

792 
type2C' (FunctionType returnType params) = do 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

793 
t < type2C returnType 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

794 
p < withState' id $ functionParams2C params 
7327
4e35c45d0853
Fix the function definition issue so the function pointer format now looks correct.
xymeng
parents:
7323
diff
changeset

795 
return (\i > (t empty <> (parens $ text "*" <> i) <> parens p)) 
6980  796 
type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i) 
6858  797 
type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

798 
type2C' (DeriveType (InitNumber _)) = return (text "int" <+>) 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

799 
type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>) 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

800 
type2C' (DeriveType (InitFloat _)) = return (text "float" <+>) 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

801 
type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>) 
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

802 
type2C' (DeriveType (InitString {})) = return (text "string255" <+>) 
6980  803 
type2C' (DeriveType r@(InitReference {})) = do 
804 
initExpr2C r 

805 
t < gets lastType 

806 
return (baseType2C (show r) t <+>) 

6858  807 
type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

808 
type2C' a = error $ "type2C: unknown type " ++ show a 
6273  809 

6512  810 
phrase2C :: Phrase > State RenderState Doc 
6509  811 
phrase2C (Phrases p) = do 
812 
ps < mapM phrase2C p 

813 
return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" 

814 
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f 

8020  815 
phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

816 
phrase2C (ProcCall _ _) = error $ "ProcCall"{do 
6509  817 
r < ref2C ref 
818 
ps < mapM expr2C params 

6923  819 
return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi } 
6509  820 
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do 
821 
e < expr2C expr 

822 
p1 < (phrase2C . wrapPhrase) phrase1 

823 
el < elsePart 

7315  824 
return $ 
6509  825 
text "if" <> parens e $+$ p1 $+$ el 
6273  826 
where 
6509  827 
elsePart  isNothing mphrase2 = return $ empty 
828 
 otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) 

8446
c18ba8726f5a
Fix sources so pas2c written in haskell could render them again
unc0rr
parents:
8444
diff
changeset

829 
phrase2C asgn@(Assignment ref expr) = do 
6923  830 
r < ref2C ref 
831 
t < gets lastType 

7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

832 
case (t, expr) of 
10142  833 
(_, Reference r')  ref == r' > do 
834 
e < ref2C r' 

835 
return $ text "UNUSED" <+> parens e <> semi 

7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

836 
(BTFunction {}, (Reference r')) > do 
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

837 
e < ref2C r' 
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

838 
return $ r <+> text "=" <+> e <> semi 
7134  839 
(BTString, _) > do 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

840 
void $ expr2C expr 
7134  841 
lt < gets lastType 
842 
case lt of 

843 
 assume pointer to char for simplicity 

844 
BTPointerTo _ > do 

845 
e < expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown)) 

846 
return $ r <+> text "=" <+> e <> semi 

10120  847 
BTAString > do 
848 
e < expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown)) 

849 
return $ r <+> text "=" <+> e <> semi 

7134  850 
BTString > do 
851 
e < expr2C expr 

852 
return $ r <+> text "=" <+> e <> semi 

10120  853 
_ > error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn 
854 
(BTAString, _) > do 

855 
void $ expr2C expr 

856 
lt < gets lastType 

857 
case lt of 

858 
 assume pointer to char for simplicity 

859 
BTPointerTo _ > do 

860 
e < expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown)) 

861 
return $ r <+> text "=" <+> e <> semi 

862 
BTString > do 

863 
e < expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown)) 

864 
return $ r <+> text "=" <+> e <> semi 

865 
BTAString > do 

866 
e < expr2C expr 

867 
return $ r <+> text "=" <+> e <> semi 

868 
_ > error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

869 
(BTArray _ _ _, _) > do 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

870 
case expr of 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

871 
Reference er > do 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

872 
void $ ref2C er 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

873 
exprT < gets lastType 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

874 
case exprT of 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

875 
BTArray RangeInfinite _ _ > 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

876 
return $ text "FIXME: assign a dynamic array to an array" 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

877 
BTArray _ _ _ > phrase2C $ 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

878 
ProcCall (FunCall 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

879 
[ 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

880 
Reference $ ref 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

881 
, Reference $ RefExpression expr 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

882 
, Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown)) 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

883 
] 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

884 
(SimpleReference (Identifier "memcpy" BTUnknown)) 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

885 
) [] 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

886 
_ > return $ text "FIXME: assign a nonspecific value to an array" 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

887 

fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

888 
_ > return $ text "FIXME: dynamic array assignment 2" 
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

889 
_ > do 
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

890 
e < expr2C expr 
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset

891 
return $ r <+> text "=" <+> e <> semi 
6509  892 
phrase2C (WhileCycle expr phrase) = do 
893 
e < expr2C expr 

894 
p < phrase2C $ wrapPhrase phrase 

895 
return $ text "while" <> parens e $$ p 

896 
phrase2C (SwitchCase expr cases mphrase) = do 

897 
e < expr2C expr 

898 
cs < mapM case2C cases 

6874  899 
d < dflt 
7315  900 
return $ 
6895  901 
text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) 
6273  902 
where 
6512  903 
case2C :: ([InitExpression], Phrase) > State RenderState Doc 
6509  904 
case2C (e, p) = do 
6874  905 
ies < mapM range2C e 
6509  906 
ph < phrase2C p 
7315  907 
return $ 
6874  908 
vcat (map (\i > text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

909 
dflt  isNothing mphrase = return [text "default: break;"]  avoid compiler warning 
6874  910 
 otherwise = do 
911 
ph < mapM phrase2C $ fromJust mphrase 

912 
return [text "default:" <+> nest 4 (vcat ph)] 

7315  913 

6845  914 
phrase2C wb@(WithBlock ref p) = do 
7315  915 
r < ref2C ref 
6845  916 
t < gets lastType 
917 
case t of 

7511  918 
(BTRecord _ rs) > withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p 
6845  919 
a > do 
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset

920 
error $ "'with' block referencing nonrecord type " ++ show a ++ "\n" ++ show wb 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

921 
phrase2C (ForCycle i' e1' e2' p up) = do 
6663  922 
i < id2C IOLookup i' 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

923 
 hackishly strip 'static' from type declaration to workaround the use of global variables in 'for' cycles in uLandGenMaze 
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

924 
iType < liftM (text . maybeStripPrefix "static " . show) $ gets lastIdTypeDecl 
6509  925 
e1 < expr2C e1' 
926 
e2 < expr2C e2' 

7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
7513
diff
changeset

927 
let iEnd = i <> text "__end__" 
10688
9459c45b5190
dark magic: make "continue" statement work in pas2cparsed forloops. (would skip iteration and lead to infinite loops before)
sheepluva
parents:
10497
diff
changeset

928 
ph < phrase2C $ wrapPhrase p 
7511  929 
return . braces $ 
930 
i <+> text "=" <+> e1 <> semi 

6509  931 
$$ 
7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
7513
diff
changeset

932 
iType <+> iEnd <+> text "=" <+> e2 <> semi 
10015  933 
$$ 
8020  934 
text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> 
10688
9459c45b5190
dark magic: make "continue" statement work in pas2cparsed forloops. (would skip iteration and lead to infinite loops before)
sheepluva
parents:
10497
diff
changeset

935 
text "while" <> parens (i <> text (if up then "++" else "") <+> text "!=" <+> iEnd) <> semi 
7511  936 
where 
937 
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

938 
appendPhrase _ _ = error "illegal appendPhrase call" 
15752
f09db263bc2a
Mark global variables in implementation section static
unC0Rr
parents:
15750
diff
changeset

939 
maybeStripPrefix prefix a = fromMaybe a $ stripPrefix prefix a 
6509  940 
phrase2C (RepeatCycle e' p') = do 
941 
e < expr2C e' 

942 
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

943 
return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi 
8020  944 

6509  945 
phrase2C NOP = return $ text ";" 
6355  946 

7134  947 
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do 
948 
f < gets currentFunctionResult 

949 
if null f then 

950 
return $ text "return" <> semi 

951 
else 

952 
return $ text "return" <+> text f <> semi 

7038  953 
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

954 
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi 
7037  955 
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e > text "return" <+> e <> semi) $ expr2C e 
6895  956 
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e > text "" <> e <> semi) $ expr2C e 
957 
phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b > a <> text " = " <> b <> semi) (expr2C e1) (expr2C e2) 

958 
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e > text "++" <> e <> semi) $ expr2C e 

959 
phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b > a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2) 

960 
phrase2C a = error $ "phrase2C: " ++ show a 

6273  961 

6307  962 
wrapPhrase p@(Phrases _) = p 
963 
wrapPhrase p = Phrases [p] 

6273  964 

15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

965 
parensExpr2C :: Expression > State RenderState Doc 
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

966 
parensExpr2C bop@(BinOp _ _ _) = liftM parens $ expr2C bop 
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

967 
parensExpr2C set@(SetExpression _ ) = liftM parens $ expr2C set 
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

968 
parensExpr2C e = expr2C e 
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

969 

6512  970 
expr2C :: Expression > State RenderState Doc 
6509  971 
expr2C (Expression s) = return $ text s 
10120  972 
expr2C bop@(BinOp op expr1 expr2) = do 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

973 
e1 < parensExpr2C expr1 
6860  974 
t1 < gets lastType 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

975 
e2 < parensExpr2C 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

976 
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

977 
case (op2C op, t1, t2) of 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

978 
("+", 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

979 
("+", 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

980 
("+", 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

981 
("!=", BTAString, BTAString) > expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2 BTBool)) 
10120  982 
(_, BTAString, _) > error $ "unhandled bin op with ansistring on the left side: " ++ show bop 
983 
(_, _, 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

984 
("+", 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

985 
("+", 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

986 
("+", 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

987 
("+", 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

988 
("==", BTString, BTChar) > expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2 BTBool)) 
8020  989 

990 
 for function/procedure comparision 

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  993 

994 
("!=", BTVoid, _) > procCompare expr1 expr2 "!=" 

10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

995 
("!=", BTFunction _ _ _ _, _) > procCompare expr1 expr2 "!=" 
8020  996 

10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

997 
("==", 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

998 
("!=", BTString, _) > expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2 BTBool)) 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

999 
("&", BTBool, _) > return $ e1 <+> text "&&" <+> e2 
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1000 
("", BTBool, _) > return $ e1 <+> text "" <+> e2 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1001 
(_, BTRecord t1 _, BTRecord t2 _) > do 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1002 
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

1003 
ref2C $ FunCall [expr1, expr2] (SimpleReference i) 
8020  1004 
(_, BTRecord t1 _, BTInt _) > do 
7056  1005 
 aw, "LongInt" here is hwenginespecific hack 
1006 
i < op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] 

1007 
ref2C $ FunCall [expr1, expr2] (SimpleReference i) 

7315  1008 
("in", _, _) > 
7057
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset

1009 
case expr2 of 
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset

1010 
SetExpression set > do 
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset

1011 
ids < mapM (id2C IOLookup) set 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1012 
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

1013 
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

1014 
_ > error "'in' against not set expression" 
6923  1015 
(o, _, _)  o `elem` boolOps > do 
1016 
modify(\s > s{lastType = BTBool}) 

15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1017 
return $ e1 <+> text o <+> e2 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1018 
 otherwise > do 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1019 
o' < return $ case o of 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1020 
"/(float)" > text "/(float)"  pascal returns real value 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1021 
_ > text o 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1022 
e1' < return $ case (o, t1, t2) of 
8020  1023 
("", BTInt False, BTInt False) > parens $ text "(int64_t)" <+> parens e1 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1024 
_ > e1 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1025 
e2' < return $ case (o, t1, t2) of 
8020  1026 
("", BTInt False, BTInt False) > parens $ text "(int64_t)" <+> parens e2 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1027 
_ > e2 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1028 
return $ e1' <+> o' <+> e2' 
6923  1029 
where 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1030 
fff t1 t2 = BTFunction False False [(False, t1), (False, t2)] 
6923  1031 
boolOps = ["==", "!=", "<", ">", "<=", ">="] 
8020  1032 
procCompare expr1 expr2 op = 
1033 
case (expr1, expr2) of 

1034 
(Reference r1, Reference r2) > do 

1035 
id1 < ref2C r1 

1036 
id2 < ref2C r2 

1037 
return $ (parens id1) <+> text op <+> (parens id2) 

1038 
(_, _) > error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2 

1039 

7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1040 
expr2C (NumberLiteral s) = do 
8020  1041 
modify(\s > s{lastType = BTInt True}) 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1042 
return $ text s 
6509  1043 
expr2C (FloatLiteral s) = return $ text s 
1044 
expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) 

7067
f98ec3aecf4e
A solution to char vs string problem: mark singleletter strings with _S macro
unc0rr
parents:
7066
diff
changeset

1045 
{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

1046 
modify(\s > s{lastType = BTChar}) 
7043
7c080e5ac8d0
Some work to make more units compile after conversion to c
unc0rr
parents:
7042
diff
changeset

1047 
return . quotes . text $ escape a 
7c080e5ac8d0
Some work to make more units compile after conversion to c
unc0rr
parents:
7042
diff
changeset

1048 
where 
7c080e5ac8d0
Some work to make more units compile after conversion to c
unc0rr
parents:
7042
diff
changeset

1049 
escape '\'' = "\\\'" 
7067
f98ec3aecf4e
A solution to char vs string problem: mark singleletter strings with _S macro
unc0rr
parents:
7066
diff
changeset

1050 
escape a = [a]} 
6896
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset

1051 
expr2C (StringLiteral s) = addStringConst s 
7072  1052 
expr2C (PCharLiteral s) = return . doubleQuotes $ text s 
8020  1053 
expr2C (Reference ref) = do 
1054 
isfunc < gets isFunctionType 

1055 
modify(\s > s{isFunctionType = False})  reset 

1056 
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

1057 
expr2C (PrefixOp op expr) = do 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1058 
e < parensExpr2C expr 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1059 
lt < gets lastType 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1060 
case lt of 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1061 
BTRecord t _ > do 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1062 
i < op2CTyped op [SimpleType (Identifier t undefined)] 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1063 
ref2C $ FunCall [expr] (SimpleReference i) 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1064 
BTBool > do 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1065 
o < return $ case op of 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1066 
"not" > text "!" 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1067 
_ > text (op2C op) 
15754
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1068 
return $ o <> e 
aa011799cb63
Reduce the amount of parens in pas2c output for prettier result, hopefully not breaking anything
unC0Rr
parents:
15752
diff
changeset

1069 
_ > return $ text (op2C op) <> e 
6509  1070 
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

1071 
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

1072 
modify(\s > s{lastType = BTChar}) 
9964  1073 
return $ text "0x" <> text (showHex (read a) "") 
7075  1074 
expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a 
6895  1075 
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

1076 

7036  1077 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do 
1078 
e' < liftM (map toLower . render) $ expr2C e 

1079 
lt < gets lastType 

1080 
case lt of 

10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

1081 
BTEnum _> return $ int 0 
8020  1082 
BTInt _ > case e' of 
7036  1083 
"longint" > return $ int (2147483648) 
1084 
BTArray {} > return $ int 0 

1085 
_ > error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt 

1086 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do 

1087 
e' < liftM (map toLower . render) $ expr2C e 

1088 
lt < gets lastType 

1089 
case lt of 

1090 
BTEnum a > return . int $ length a  1 

8020  1091 
BTInt _ > case e' of 
7036  1092 
"longint" > return $ int (2147483647) 
1093 
BTString > return $ int 255 

1094 
BTArray (RangeFromTo _ n) _ _ > initExpr2C n 

1095 
_ > 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

1096 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e 
6895  1097 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e 
8020  1098 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do 
1099 
e'< expr2C e 

1100 
return $ text "(int)" <> parens e' <> text "  1" 

7062  1101 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do 
1102 
e' < expr2C e 

1103 
lt < gets lastType 

8020  1104 
modify (\s > s{lastType = BTInt True}) 
7062  1105 
case lt of 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1106 
BTString > return $ text "fpcrtl_Length" <> parens e' 
10120  1107 
BTAString > return $ text "fpcrtl_LengthA" <> parens e' 
7335  1108 
BTArray RangeInfinite _ _ > error $ "length() called on variable size array " ++ show e' 
1109 
BTArray (RangeFromTo _ n) _ _ > initExpr2C (BuiltInFunction "succ" [n]) 

7062  1110 
_ > error $ "length() called on " ++ show lt 
10120  1111 
expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do 
1112 
e1' < expr2C e1 

1113 
e2' < expr2C e2 

1114 
e' < expr2C e 

1115 
lt < gets lastType 

1116 
let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2']) 

1117 
case lt of 

1118 
BTString > f "fpcrtl_copy" 

1119 
BTAString > f "fpcrtl_copyA" 

1120 
_ > error $ "copy() called on " ++ show lt 

13306  1121 

6509  1122 
expr2C (BuiltInFunCall params ref) = do 
7315  1123 
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

1124 
t < gets lastType 
6509  1125 
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

1126 
case t of 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1127 
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

1128 
modify (\s > s{lastType = t'}) 
13306  1129 
_ > error $ "BuiltInFunCall `" ++ show ref ++ "`, lastType: " ++ show t 
7315  1130 
return $ 
6509  1131 
r <> parens (hsep . punctuate (char ',') $ ps) 
6858  1132 
expr2C a = error $ "Don't know how to render " ++ show a 
6273  1133 

8020  1134 
ref2CF :: Reference > Bool > State RenderState Doc 
1135 
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

1136 
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

1137 
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

1138 
case t of 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1139 
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

1140 
modify(\s > s{lastType = rt}) 
8020  1141 
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

1142 
_ > return $ i 
8020  1143 
ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do 
7055  1144 
i < ref2C r 
1145 
t < gets lastType 

1146 
case t of 

10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1147 
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

1148 
modify(\s > s{lastType = rt}) 
10015  1149 
return $ if addParens then i <> parens empty else i 
7055  1150 
_ > return $ i 
8020  1151 
ref2CF r _ = ref2C r 
6307  1152 

6512  1153 
ref2C :: Reference > State RenderState Doc 
6854
873929cbd54b
Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents:
6853
diff
changeset

1154 
 rewrite into proper form 
6858  1155 
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) 
1156 
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) 

1157 
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 

1158 
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) 

1159 
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

1160 
 conversion routines 
6895  1161 
ref2C ae@(ArrayElement [expr] ref) = do 
1162 
e < expr2C expr 

7315  1163 
r < ref2C ref 
6827  1164 
t < gets lastType 
1165 
case t of 

6893  1166 
(BTArray _ _ t') > modify (\st > st{lastType = t'}) 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

1167 
 (BTFunctionReturn _ (BTArray _ _ t')) > modify (\st > st{lastType = t'}) 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

1168 
 (BTFunctionReturn _ (BTString)) > modify (\st > st{lastType = BTChar}) 
10120  1169 
BTString > modify (\st > st{lastType = BTChar}) 
1170 
BTAString > modify (\st > st{lastType = BTChar}) 

6872  1171 
(BTPointerTo t) > do 
1172 
t'' < fromPointer (show t) =<< gets lastType 

1173 
case t'' of 

1174 
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

1175 
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

1176 
a > error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae 
6895  1177 
case t of 
1178 
BTString > return $ r <> text ".s" <> brackets e 

10127  1179 
BTAString > return $ r <> text ".s" <> brackets e 
6895  1180 
_ > return $ r <> brackets e 
6663  1181 
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

1182 
ref2C rf@(RecordField (Dereference ref1) ref2) = do 
7315  1183 
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

1184 
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

1185 
r2 < case t of 
7511  1186 
BTRecord _ rs > withRecordNamespace "" (rec2Records rs) $ ref2C ref2 
7055  1187 
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

1188 
a > error $ "dereferencing from " ++ show a ++ "\n" ++ show rf 
7315  1189 
return $ 
6509  1190 
r1 <> text ">" <> r2 
6618  1191 
ref2C rf@(RecordField ref1 ref2) = do 
1192 
r1 < ref2C ref1 

1193 
t < gets lastType 

7033  1194 
case t of 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1195 
BTRecord _ rs > do 
7511  1196 
r2 < withRecordNamespace "" (rec2Records rs) $ ref2C ref2 
7033  1197 
return $ r1 <> text "." <> r2 
7055  1198 
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

1199 
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

1200 
ref2C d@(Dereference ref) = do 
6827  1201 
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

1202 
t < fromPointer (show d) =<< gets lastType 
6834  1203 
modify (\st > st{lastType = t}) 
6859  1204 
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

1205 
ref2C f@(FunCall params ref) = do 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

1206 
r < fref2C ref 
6826  1207 
t < gets lastType 
1208 
case t of 

10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1209 
BTFunction _ _ bts t' > do 
10015  1210 
ps < liftM (parens . hsep . punctuate (char ',')) $ 
8020  1211 
if (length params) == (length bts)  hot fix for pas2cSystem and pas2cRedo functions since they don't have params 
10015  1212 
then 
8020  1213 
mapM expr2CHelper (zip params bts) 
1214 
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

1215 
modify (\s > s{lastType = t'}) 
6826  1216 
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

1217 
_ > 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

1218 
(SimpleReference i, [p]) > ref2C $ TypeCast i p 
8020  1219 
_ > 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

1220 
where 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

1221 
fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

1222 
fref2C a = ref2C a 
8020  1223 
expr2CHelper :: (Expression, (Bool, BaseType)) > State RenderState Doc 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1224 
expr2CHelper (e, (_, BTFunction _ _ _ _)) = do 
8020  1225 
modify (\s > s{isFunctionType = True}) 
1226 
expr2C e 

1227 
expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e 

7315  1228 

6509  1229 
ref2C (Address ref) = do 
1230 
r < ref2C ref 

7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

1231 
lt < gets lastType 
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

1232 
case lt of 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

1233 
BTFunction True _ _ _ > return $ text "&" <> parens r 
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

1234 
_ > 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

1235 
ref2C (TypeCast t'@(Identifier i _) expr) = do 
7151  1236 
lt < expr2C expr >> gets lastType 
1237 
case (map toLower i, lt) of 

1238 
("pchar", BTString) > ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) 

10120  1239 
("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

1240 
("shortstring", BTAString) > ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString)) 
7151  1241 
("shortstring", BTPointerTo _) > ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) 
10127  1242 
("ansistring", BTPointerTo _) > ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString)) 
10121  1243 
("ansistring", BTString) > ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString)) 
7151  1244 
(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

1245 
e < expr2C expr 
7315  1246 
t < id2C IOLookup t' 
7038  1247 
return . parens $ parens t <> e 
6467  1248 
ref2C (RefExpression expr) = expr2C expr 
6355  1249 

6509  1250 

6860  1251 
op2C :: String > String 
1252 
op2C "or" = "" 

1253 
op2C "and" = "&" 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1254 
op2C "not" = "~" 
6860  1255 
op2C "xor" = "^" 
1256 
op2C "div" = "/" 

1257 
op2C "mod" = "%" 

1258 
op2C "shl" = "<<" 

1259 
op2C "shr" = ">>" 

1260 
op2C "<>" = "!=" 

1261 
op2C "=" = "==" 

7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1262 
op2C "/" = "/(float)" 
6860  1263 
op2C a = a 
6273  1264 