author  Wuzzy <almikes@aol.com> 
Fri, 06 May 2016 17:26:06 +0200  
changeset 11814  8eccc307ca1e 
parent 11398  c3a535886806 
child 11840  24f309d75da8 
permissions  rwrr 
6858  1 
{# LANGUAGE ScopedTypeVariables #} 
11398  2 
{# LANGUAGE FlexibleContexts #} 
6273  3 
module Pas2C where 
4 

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 
6512  16 
import Data.List (find) 
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 

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

148 
mapM_ (tvar2C True False True False) tvs 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

149 
toNamespace nss (Redo tvs) =  functions that are 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 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

154 
mapM_ (tvar2C True False True False) tvs 
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset

155 
toNamespace _ (Program {}) = Map.empty 
7315  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 ++ "'..." 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

189 
toCFiles' pu 
6474
42e9773eedfd
 Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset

190 
where 
7953  191 
toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p 
7033  192 
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

193 
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

194 
(a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} 
8020  195 
enumDecl = (renderEnum2Strs (enums s) False) 
196 
enumImpl = (renderEnum2Strs (enums s) True) 

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

198 
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

199 
toCFiles' _ = undefined  just pleasing compiler to not warn us 
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset

200 
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

201 

6516  202 
render2C :: RenderState > State RenderState Doc > String 
8020  203 
render2C st p = 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

204 
let (a, _) = runState p st in 
8020  205 
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

206 

8020  207 
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

208 
renderEnum2Strs enums' implement = 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

209 
render $ foldl ($+$) empty $ map (\en > let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums' 
8020  210 
where 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

211 
decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar") 
10015  212 
enum2strBlock en = 
8020  213 
text "{" 
214 
$+$ 

215 
(nest 4 $ 

216 
text "switch(enumvar){" 

217 
$+$ 

218 
(foldl ($+$) empty $ map (\e > text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en) 

219 
$+$ 

220 
text "default: assert(0);" 

221 
$+$ 

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

223 
$+$ 

224 
text "}" 

225 
) 

226 
$+$ 

227 
text "}" 

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

228 

6467  229 
usesFiles :: PascalUnit > [String] 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

230 
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

231 
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 
6512  232 
usesFiles (System {}) = [] 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

233 
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

234 

6512  235 
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

236 
pascal2C (Unit _ interface implementation _ _) = 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

237 
liftM2 ($+$) (interface2C interface True) (implementation2C implementation) 
7315  238 

6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset

239 
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

240 
impl < implementation2C implementation 
10245  241 
[main] < tvar2C True False True True 
242 
(FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) 

243 
[VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing 

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

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

8020  246 

6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset

247 
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

248 

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

249 
pascal2C _ = error "pascal2C: pattern not matched" 
7315  250 

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

251 
 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

252 
 that will be inserted into implementation files 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

253 
interface2C :: Interface > Bool > State RenderState Doc 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

254 
interface2C (Interface uses tvars) True = do 
6965  255 
u < uses2C uses 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

256 
tv < typesAndVars2C True True True tvars 
6965  257 
r < renderStringConsts 
258 
return (u $+$ r $+$ tv) 

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

259 
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

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

261 
tv < typesAndVars2C True False False tvars 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

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

263 
return tv 
7315  264 

6512  265 
implementation2C :: Implementation > State RenderState Doc 
6896
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset

266 
implementation2C (Implementation uses tvars) = do 
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset

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

268 
tv < typesAndVars2C True False True tvars 
6896
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset

269 
r < renderStringConsts 
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset

270 
return (u $+$ r $+$ tv) 
6273  271 

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

272 
checkDuplicateFunDecls :: [TypeVarDeclaration] > State RenderState () 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

273 
checkDuplicateFunDecls tvs = 
7069  274 
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

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

276 
initMap :: Map.Map String Int 
7069  277 
initMap = Map.empty 
278 
initMap = Map.fromList [("reset", 2)] 

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

279 
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

280 
ins _ m = m 
6273  281 

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

282 
 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

283 
 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

284 

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

285 
typesAndVars2C :: Bool > Bool > Bool > TypesAndVars > State RenderState Doc 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

286 
typesAndVars2C b externVar includeType(TypesAndVars ts) = do 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

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

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

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

292 

6512  293 
uses2C :: Uses > State RenderState Doc 
6516  294 
uses2C uses@(Uses unitIds) = do 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

295 

6516  296 
mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

297 
mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds) 
6816  298 
mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds 
6516  299 
return $ vcat . map (\i > text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses 
300 
where 

6517  301 
injectNamespace (Identifier i _) = do 
6516  302 
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

303 
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

304 

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

305 
uses2List :: Uses > [String] 
6489  306 
uses2List (Uses ids) = map (\(Identifier i _) > i) ids 
6273  307 

6509  308 

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

309 
setLastIdValues :: Record > RenderState > RenderState 
7511  310 
setLastIdValues vv = (\s > s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) 
311 

6663  312 
id2C :: InsertOption > Identifier > State RenderState Doc 
7511  313 
id2C IOInsert i = id2C (IOInsertWithType empty) i 
314 
id2C (IOInsertWithType d) (Identifier i t) = do 

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

315 
tom < gets (Set.member n . toMangle) 
7033  316 
cu < gets currentUnit 
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

317 
let (i', t') = case (t, tom) of 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

318 
(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

319 
(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

320 
(BTVarParam t'', _) > ('(' : '*' : i ++ ")" , t'') 
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

321 
_ > (i, t) 
7511  322 
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

323 
return $ text i' 
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset

324 
where 
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset

325 
n = map toLower i 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

326 

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

327 
id2C IOLookup i = id2CLookup head i 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

328 
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

329 
id2C (IOLookupFunction params) (Identifier i _) = do 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

330 
let i' = map toLower i 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

331 
v < gets $ Map.lookup i' . currentScope 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

332 
lt < gets lastType 
7315  333 
if isNothing v then 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

334 
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v 
7315  335 
else 
336 
let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in 

7511  337 
modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

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

339 
checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

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

341 
id2C IODeferred (Identifier i _) = do 
6663  342 
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

343 
v < gets $ Map.lookup i' . currentScope 
6663  344 
if (isNothing v) then 
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a nonstruct type
unc0rr
parents:
7033
diff
changeset

345 
modify (\s > s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) 
6663  346 
else 
7511  347 
let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 
6512  348 

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

349 
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

350 
id2CLookup f (Identifier i _) = do 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

351 
let i' = map toLower i 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

352 
v < gets $ Map.lookup i' . currentScope 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

353 
lt < gets lastType 
7315  354 
if isNothing v then 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

355 
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt 
7315  356 
else 
7511  357 
let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) 
7315  358 

359 

8020  360 

6653  361 
id2CTyped :: TypeDecl > Identifier > State RenderState Doc 
7511  362 
id2CTyped = id2CTyped2 Nothing 
363 

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

365 
id2CTyped2 md t (Identifier i _) = do 

6653  366 
tb < resolveType t 
7315  367 
case (t, tb) of 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

368 
(_, 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

369 
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

370 
(SimpleType {}, BTRecord _ r) > do 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

371 
ts < type2C t 
7511  372 
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

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

374 
ts < type2C t 
7511  375 
id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) 
376 
_ > case md of 

377 
Nothing > id2C IOInsert (Identifier i tb) 

378 
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

379 

8020  380 
typeVarDecl2BaseType :: [TypeVarDeclaration] > State RenderState [(Bool, BaseType)] 
381 
typeVarDecl2BaseType d = do 

382 
st < get 

383 
result < sequence $ concat $ map resolveType' d 

384 
put st  restore state (not sure if necessary) 

385 
return result 

386 
where 

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

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

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

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

391 
resolveTypeHelper' st b = do 

392 
bt < st 

393 
return (b, bt) 

10015  394 

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

395 
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

396 
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

397 
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

398 
v < gets $ Map.lookup i' . currentScope 
7511  399 
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

400 
where 
8020  401 
f "uinteger" = BTInt False 
402 
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

403 
f "pointer" = BTPointerTo BTVoid 
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset

404 
f "boolean" = BTBool 
6649
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset

405 
f "float" = BTFloat 
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset

406 
f "char" = BTChar 
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset

407 
f "string" = BTString 
10120  408 
f "ansistring" = BTAString 
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset

409 
f _ = error $ "Unknown system type: " ++ show st 
6827  410 
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) 
411 
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

412 
resolveType (RecordType tv mtvs) = do 
6827  413 
tvs < mapM f (concat $ tv : fromMaybe [] mtvs) 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

414 
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

415 
where 
6827  416 
f :: TypeVarDeclaration > State RenderState [(String, BaseType)] 
7317  417 
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

418 
f _ = error "resolveType f: pattern not matched" 
6893  419 
resolveType (ArrayDecl (Just i) t) = do 
420 
t' < resolveType t 

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

423 
resolveType (FunctionType t a) = do 

10015  424 
bts < typeVarDecl2BaseType a 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

425 
liftM (BTFunction False False bts) $ resolveType t 
8020  426 
resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) 
427 
resolveType (DeriveType (InitNumber _)) = return (BTInt True) 

6835  428 
resolveType (DeriveType (InitFloat _)) = return BTFloat 
429 
resolveType (DeriveType (InitString _)) = return BTString 

8020  430 
resolveType (DeriveType (InitBinOp {})) = return (BTInt True) 
7151  431 
resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType 
8020  432 
resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) 
6835  433 
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool  TODO: derive from actual type 
434 
resolveType (DeriveType _) = return BTUnknown 

10111
459bc720cea1
Drop support for other string types than string255
unc0rr
parents:
10015
diff
changeset

435 
resolveType String = return BTString 
10120  436 
resolveType AString = return BTAString 
6826  437 
resolveType VoidType = return BTVoid 
6653  438 
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

439 
resolveType (RangeType _) = return $ BTVoid 
6653  440 
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

441 
resolveType (VarParamType t) = liftM BTVarParam $ resolveType t 
7315  442 

6834  443 

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

444 
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

445 
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

446 
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

447 
if isJust v then 
7511  448 
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

449 
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

450 
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

451 
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

452 

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

454 
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

455 
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

456 
error $ "Dereferencing from nonpointer type " ++ show t ++ "\n" ++ s 
6834  457 

7315  458 

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

459 
functionParams2C :: [TypeVarDeclaration] > State RenderState Doc 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

460 
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params 
6834  461 

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

462 
numberOfDeclarations :: [TypeVarDeclaration] > Int 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

463 
numberOfDeclarations = sum . map cnt 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

464 
where 
7317  465 
cnt (VarDeclaration _ _ (ids, _) _) = length ids 
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

466 
cnt _ = 1 
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset

467 

7317  468 
hasPassByReference :: [TypeVarDeclaration] > Bool 
469 
hasPassByReference = or . map isVar 

470 
where 

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

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

473 

7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

474 
toIsVarList :: [TypeVarDeclaration] > [Bool] 
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

475 
toIsVarList = concatMap isVar 
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

476 
where 
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

477 
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

478 
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

479 

8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

480 

8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

481 
funWithVarsToDefine :: String > [TypeVarDeclaration] > Doc 
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

482 
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

483 
where 
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

484 
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

485 
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

486 
ps = zip ['a'..] (toIsVarList params) 
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset

487 

6880  488 
fun2C :: Bool > String > TypeVarDeclaration > State RenderState [Doc] 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

489 
fun2C _ _ (FunctionDeclaration name _ overload external returnType params Nothing) = do 
7315  490 
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

491 
t'< gets lastType 
8020  492 
bts < typeVarDecl2BaseType params 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

493 
p < withState' id $ functionParams2C params 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

494 
n < liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name 
8020  495 
let decor = if overload then text "__attribute__((overloadable))" else empty 
496 
return [t empty <+> decor <+> text n <> parens p] 

7315  497 

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

498 
fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do 
7134  499 
let isVoid = case returnType of 
500 
VoidType > True 

501 
_ > False 

7315  502 

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

505 
t' < gets lastType 

506 

507 
bts < typeVarDecl2BaseType params 

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

508 
cu < gets currentUnit 
8020  509 
notDeclared < liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope 
510 

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

511 
n < liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name 
8020  512 
let resultId = if isVoid 
513 
then n  void type doesn't have result, solving recursive procedure calls 

514 
else (render res) 

515 

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

516 
(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  517 
, currentFunctionResult = if isVoid then [] else render res}) $ do 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

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

519 
ph < liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) 
6827  520 
return (p, ph) 
7315  521 

10497
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset

522 
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

523 
(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

524 
_ > False 
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset

525 
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

526 
let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty 
8020  527 
let inlineDecor = if inline then case notDeclared of 
528 
True > text "static inline" 

529 
False > text "inline" 

530 
else empty 

531 
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

532 
return [ 
8020  533 
define 
534 
 $+$ 

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

535 
(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ 
8020  536 
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

537 
$+$ 
7315  538 
text "{" 
539 
$+$ 

6836  540 
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

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

542 
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

543 
where 
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset

544 
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

545 
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

546 
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

547 
un _ _ = error "fun2C u: pattern not matched" 
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

548 
hasVars = hasPassByReference params 
7315  549 

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

550 
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = error $ "nested functions not allowed: " ++ name 
6880  551 
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv 
6618  552 

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

553 
 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

554 
 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

555 
 the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

556 
tvar2C :: Bool > Bool > Bool > Bool > TypeVarDeclaration > State RenderState [Doc] 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

557 
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

558 
t < fun2C b name f 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

559 
if includeType then return t else return [] 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

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

565 
(Sequence ids) > do 

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

566 
modify(\s > s{enums = (render i, map (\(Identifier id' _) > id') ids) : enums s}) 
8020  567 
return res 
568 
_ > return res 

7315  569 

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

570 
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

571 
t' < liftM ((empty <+>) . ) $ type2C t 
7511  572 
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

573 

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

574 
tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do 
8442  575 
t' < liftM (((if isConst then text "static const" else if externVar 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

576 
then text "extern" 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

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

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

8020  582 
(True, BTInt _, [i], Just _) > do 
6979  583 
i' < id2CTyped t i 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

584 
return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] 
7002  585 
(True, BTFloat, [i], Just e) > do 
586 
i' < id2CTyped t i 

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

587 
ie' < initExpr2C e 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

588 
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

589 
(_, 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

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

591 
i' < id2CTyped t i 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

592 
ie' < return $ case (r, mInitExpr, ignoreInit) of 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

593 
(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

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

595 
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

596 
case (r, ignoreInit) of 
8442  597 
(RangeInfinite, False) > 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

598 
 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

599 
return $ [dimDecl] ++ result 
8442  600 
where 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

601 
arrayDimStr = show $ arrayDimension t 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

602 
arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}") 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

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

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

605 
(_, _) > return result 
8442  606 

7511  607 
_ > liftM (map(\i > varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids 
6355  608 
where 
6509  609 
initExpr Nothing = return $ empty 
610 
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

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

612 
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

613 
varDeclDecision False False varStr expStr = varStr <+> expStr 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

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

615 
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

616 
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

617 
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

618 
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

619 
_ > 0 
7315  620 

7513  621 
tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do 
6880  622 
r < op2CTyped op (extractTypes params) 
10129
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

623 
fun2C f i (FunctionDeclaration r inline False False ret params body) 
6355  624 

7315  625 

6880  626 
op2CTyped :: String > [TypeDecl] > State RenderState Identifier 
627 
op2CTyped op t = do 

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

628 
t' < liftM (render . hcat . punctuate (char '_') . map (\txt > txt empty)) $ mapM type2C t 
6880  629 
bt < gets lastType 
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

630 
return $ Identifier (t' ++ "_op_" ++ opStr) bt 
7315  631 
where 
6880  632 
opStr = case op of 
633 
"+" > "add" 

634 
"" > "sub" 

635 
"*" > "mul" 

636 
"/" > "div" 

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

637 
"/(float)" > "div" 
6880  638 
"=" > "eq" 
639 
"<" > "lt" 

640 
">" > "gt" 

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

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

6880  644 
extractTypes :: [TypeVarDeclaration] > [TypeDecl] 
645 
extractTypes = concatMap f 

646 
where 

7317  647 
f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t 
6880  648 
f a = error $ "extractTypes: can't extract from " ++ show a 
649 

7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

650 
initExpr2C, initExpr2C' :: InitExpression > State RenderState Doc 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

651 
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

652 
initExpr2C a = initExpr2C' a 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

653 
initExpr2C' InitNull = return $ text "NULL" 
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

654 
initExpr2C' (InitAddress expr) = do 
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

655 
ie < initExpr2C' expr 
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset

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

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

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

659 
_ > return $ text "&" <> ie 
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

660 
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

661 
initExpr2C' (InitBinOp op expr1 expr2) = do 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

662 
e1 < initExpr2C' expr1 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

663 
e2 < initExpr2C' expr2 
6860  664 
return $ parens $ e1 <+> text (op2C op) <+> e2 
8020  665 
initExpr2C' (InitNumber s) = do 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

666 
modify(\st > st{lastType = (BTInt True)}) 
10015  667 
return $ text s 
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

668 
initExpr2C' (InitFloat s) = return $ text s 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

669 
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

670 
initExpr2C' (InitString [a]) = return . quotes $ text [a] 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

671 
initExpr2C' (InitString s) = return $ strInit s 
10747
07ade56c3b4a
backporting some build system fixes and pas2c tweaks
sheepluva
parents:
10688
diff
changeset

672 
initExpr2C' (InitPChar s) = return $ doubleQuotes (text $ escapeStr s) 
9964  673 
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

674 
initExpr2C' (InitReference i) = id2C IOLookup i 
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

675 
initExpr2C' (InitRecord fields) = do 
6858  676 
(fs :: [Doc]) < mapM (\(Identifier a _, b) > liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields 
6886  677 
return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace 
9954  678 
initExpr2C' (InitArray [InitRecord fields]) = do 
679 
 e < initExpr2C $ InitRecord fields 

680 
 return $ braces $ e 

7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

681 
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

682 
void $ id2C IOLookup i 
6891
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset

683 
t < gets lastType 
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset

684 
case t of 
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset

685 
BTEnum s > return . int $ length s 
8020  686 
BTInt _ > case i' of 
6891
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset

687 
"byte" > return $ int 256 
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset

688 
_ > error $ "InitRange identifier: " ++ i' 
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset

689 
_ > error $ "InitRange: " ++ show r 
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

690 
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

691 
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

692 
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

693 
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

694 
initExpr2C' (InitSet _) = return $ text "<<set>>" 
7315  695 
initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ 
6887  696 
case e of 
697 
(Identifier "LongInt" _) > int (2^31) 

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

7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

700 
initExpr2C' (BuiltInFunction "high" [e]) = do 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

701 
void $ initExpr2C e 
6893  702 
t < gets lastType 
703 
case t of 

7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

704 
(BTArray i _ _) > initExpr2C' $ BuiltInFunction "pred" [InitRange i] 
6893  705 
a > error $ "BuiltInFunction 'high': " ++ show a 
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset

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

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

708 
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

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

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

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

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

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

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

6887  717 

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

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

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

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

6391  723 

6980  724 
baseType2C :: String > BaseType > Doc 
725 
baseType2C _ BTFloat = text "float" 

726 
baseType2C _ BTBool = text "bool" 

727 
baseType2C _ BTString = text "string255" 

10120  728 
baseType2C _ BTAString = text "astring" 
6980  729 
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s 
730 

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

731 
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

732 
type2C (SimpleType i) = liftM (\i' a > i' <+> a) $ id2C IOLookup i 
6838  733 
type2C t = do 
734 
r < type2C' t 

735 
rt < resolveType t 

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

737 
return r 

738 
where 

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

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

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

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

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

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

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

746 
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

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

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

749 
type2C' (PointerTo t) = liftM (\tx a > tx (parens $ text "*" <> a)) $ type2C t 
6838  750 
type2C' (RecordType tvs union) = do 
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

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

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

755 
f s = s{currentUnit = ""} 
6886  756 
unions = case union of 
757 
Nothing > return empty 

758 
Just a > do 

759 
structs < mapM struct2C a 

760 
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

761 
struct2C stvs = do 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

762 
txts < withState' f $ mapM (tvar2C False False True False) stvs 
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset

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

766 
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

767 
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

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

769 
bt = BTEnum $ map (\(Identifier i _) > map toLower i) ids 
6894  770 
type2C' (ArrayDecl Nothing t) = type2C (PointerTo t) 
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset

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

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

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

775 
 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

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

777 
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

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

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

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

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

782 
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

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

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

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

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

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

790 
type2C' (DeriveType (InitString {})) = return (text "string255" <+>) 
6980  791 
type2C' (DeriveType r@(InitReference {})) = do 
792 
initExpr2C r 

793 
t < gets lastType 

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

6858  795 
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

796 
type2C' a = error $ "type2C: unknown type " ++ show a 
6273  797 

6512  798 
phrase2C :: Phrase > State RenderState Doc 
6509  799 
phrase2C (Phrases p) = do 
800 
ps < mapM phrase2C p 

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

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

8020  803 
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

804 
phrase2C (ProcCall _ _) = error $ "ProcCall"{do 
6509  805 
r < ref2C ref 
806 
ps < mapM expr2C params 

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

810 
p1 < (phrase2C . wrapPhrase) phrase1 

811 
el < elsePart 

7315  812 
return $ 
6509  813 
text "if" <> parens e $+$ p1 $+$ el 
6273  814 
where 
6509  815 
elsePart  isNothing mphrase2 = return $ empty 
816 
 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

817 
phrase2C asgn@(Assignment ref expr) = do 
6923  818 
r < ref2C ref 
819 
t < gets lastType 

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

820 
case (t, expr) of 
10142  821 
(_, Reference r')  ref == r' > do 
822 
e < ref2C r' 

823 
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

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

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

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

828 
void $ expr2C expr 
7134  829 
lt < gets lastType 
830 
case lt of 

831 
 assume pointer to char for simplicity 

832 
BTPointerTo _ > do 

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

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

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

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

7134  838 
BTString > do 
839 
e < expr2C expr 

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

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

843 
void $ expr2C expr 

844 
lt < gets lastType 

845 
case lt of 

846 
 assume pointer to char for simplicity 

847 
BTPointerTo _ > do 

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

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

850 
BTString > do 

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

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

853 
BTAString > do 

854 
e < expr2C expr 

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

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

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

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

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

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

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

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

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

864 
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

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

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

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

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

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

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

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

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

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

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

875 

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

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

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

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

879 
return $ r <+> text "=" <+> e <> semi 
6509  880 
phrase2C (WhileCycle expr phrase) = do 
881 
e < expr2C expr 

882 
p < phrase2C $ wrapPhrase phrase 

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

884 
phrase2C (SwitchCase expr cases mphrase) = do 

885 
e < expr2C expr 

886 
cs < mapM case2C cases 

6874  887 
d < dflt 
7315  888 
return $ 
6895  889 
text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) 
6273  890 
where 
6512  891 
case2C :: ([InitExpression], Phrase) > State RenderState Doc 
6509  892 
case2C (e, p) = do 
6874  893 
ies < mapM range2C e 
6509  894 
ph < phrase2C p 
7315  895 
return $ 
6874  896 
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

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

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

7315  901 

6845  902 
phrase2C wb@(WithBlock ref p) = do 
7315  903 
r < ref2C ref 
6845  904 
t < gets lastType 
905 
case t of 

7511  906 
(BTRecord _ rs) > withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p 
6845  907 
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

908 
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

909 
phrase2C (ForCycle i' e1' e2' p up) = do 
6663  910 
i < id2C IOLookup i' 
7511  911 
iType < gets lastIdTypeDecl 
6509  912 
e1 < expr2C e1' 
913 
e2 < expr2C e2' 

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

914 
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

915 
ph < phrase2C $ wrapPhrase p 
7511  916 
return . braces $ 
917 
i <+> text "=" <+> e1 <> semi 

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

919 
iType <+> iEnd <+> text "=" <+> e2 <> semi 
10015  920 
$$ 
8020  921 
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

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

925 
appendPhrase _ _ = error "illegal appendPhrase call" 
6509  926 
phrase2C (RepeatCycle e' p') = do 
927 
e < expr2C e' 

928 
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

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

6509  931 
phrase2C NOP = return $ text ";" 
6355  932 

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

935 
if null f then 

936 
return $ text "return" <> semi 

937 
else 

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

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

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

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

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

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

6273  947 

6307  948 
wrapPhrase p@(Phrases _) = p 
949 
wrapPhrase p = Phrases [p] 

6273  950 

6512  951 
expr2C :: Expression > State RenderState Doc 
6509  952 
expr2C (Expression s) = return $ text s 
10120  953 
expr2C bop@(BinOp op expr1 expr2) = do 
6509  954 
e1 < expr2C expr1 
6860  955 
t1 < gets lastType 
6509  956 
e2 < expr2C expr2 
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with Wall (clang).
unc0rr
parents:
6896
diff
changeset

957 
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

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

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

960 
("+", BTAString, BTChar) > expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2 BTAString)) 
cd2a64a1f4aa
 Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset

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

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

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

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

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

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

970 
 for function/procedure comparision 

971 
("==", BTVoid, _) > procCompare expr1 expr2 "==" 

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

972 
("==", BTFunction _ _ _ _, _) > procCompare expr1 expr2 "==" 
8020  973 

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

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

975 
("!=", BTFunction _ _ _ _, _) > procCompare expr1 expr2 "!=" 
8020  976 

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

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

978 
("!=", BTString, _) > expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2 BTBool)) 
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with Wall (clang).
unc0rr
parents:
6896
diff
changeset

979 
("&", BTBool, _) > return $ parens e1 <+> text "&&" <+> parens e2 
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with Wall (clang).
unc0rr
parents:
6896
diff
changeset

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

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

982 
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

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

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

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

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

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

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

992 
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

993 
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

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

997 
return $ parens e1 <+> text o <+> parens e2 

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

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

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

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

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

1002 
e1' < return $ case (o, t1, t2) of 
8020  1003 
("", BTInt False, BTInt False) > parens $ text "(int64_t)" <+> parens e1 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

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

1005 
e2' < return $ case (o, t1, t2) of 
8020  1006 
("", BTInt False, BTInt False) > parens $ text "(int64_t)" <+> parens e2 
7429
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

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

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

1010 
fff t1 t2 = BTFunction False False [(False, t1), (False, t2)] 
6923  1011 
boolOps = ["==", "!=", "<", ">", "<=", ">="] 
8020  1012 
procCompare expr1 expr2 op = 
1013 
case (expr1, expr2) of 

1014 
(Reference r1, Reference r2) > do 

1015 
id1 < ref2C r1 

1016 
id2 < ref2C r2 

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

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

1019 

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

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

1022 
return $ text s 
6509  1023 
expr2C (FloatLiteral s) = return $ text s 
1024 
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

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

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

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

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

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

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

1031 
expr2C (StringLiteral s) = addStringConst s 
7072  1032 
expr2C (PCharLiteral s) = return . doubleQuotes $ text s 
8020  1033 
expr2C (Reference ref) = do 
1034 
isfunc < gets isFunctionType 

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

1036 
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

1037 
expr2C (PrefixOp op expr) = do 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

1038 
e < expr2C expr 
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset

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

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

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

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

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

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

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

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

1047 
_ > text (op2C op) 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1048 
return $ o <> parens e 
fcf13e40d6b6
Changes to pas2c  unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset

1049 
_ > return $ text (op2C op) <> parens e 
6509  1050 
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

1051 
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

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

1056 

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

1059 
lt < gets lastType 

1060 
case lt of 

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

1061 
BTEnum _> return $ int 0 
8020  1062 
BTInt _ > case e' of 
7036  1063 
"longint" > return $ int (2147483648) 
1064 
BTArray {} > return $ int 0 

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

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

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

1068 
lt < gets lastType 

1069 
case lt of 

1070 
BTEnum a > return . int $ length a  1 

8020  1071 
BTInt _ > case e' of 
7036  1072 
"longint" > return $ int (2147483647) 
1073 
BTString > return $ int 255 

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

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

1076 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e 
6895  1077 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e 
8020  1078 
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do 
1079 
e'< expr2C e 

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

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

1083 
lt < gets lastType 

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

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

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

1093 
e2' < expr2C e2 

1094 
e' < expr2C e 

1095 
lt < gets lastType 

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

1097 
case lt of 

1098 
BTString > f "fpcrtl_copy" 

1099 
BTAString > f "fpcrtl_copyA" 

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

1101 

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

1104 
t < gets lastType 
6509  1105 
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

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

1107 
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

1108 
modify (\s > s{lastType = t'}) 
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with Wall (clang).
unc0rr
parents:
6896
diff
changeset

1109 
_ > error $ "BuiltInFunCall lastType: " ++ show t 
7315  1110 
return $ 
6509  1111 
r <> parens (hsep . punctuate (char ',') $ ps) 
6858  1112 
expr2C a = error $ "Don't know how to render " ++ show a 
6273  1113 

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

1116 
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

1117 
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

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

1119 
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

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

1122 
_ > return $ i 
8020  1123 
ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do 
7055  1124 
i < ref2C r 
1125 
t < gets lastType 

1126 
case t of 

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

1127 
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

1128 
modify(\s > s{lastType = rt}) 
10015  1129 
return $ if addParens then i <> parens empty else i 
7055  1130 
_ > return $ i 
8020  1131 
ref2CF r _ = ref2C r 
6307  1132 

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

1134 
 rewrite into proper form 
6858  1135 
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) 
1136 
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) 

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

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

1139 
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

1140 
 conversion routines 
6895  1141 
ref2C ae@(ArrayElement [expr] ref) = do 
1142 
e < expr2C expr 

7315  1143 
r < ref2C ref 
6827  1144 
t < gets lastType 
1145 
case t of 

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

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

1148 
 (BTFunctionReturn _ (BTString)) > modify (\st > st{lastType = BTChar}) 
10120  1149 
BTString > modify (\st > st{lastType = BTChar}) 
1150 
BTAString > modify (\st > st{lastType = BTChar}) 

6872  1151 
(BTPointerTo t) > do 
1152 
t'' < fromPointer (show t) =<< gets lastType 

1153 
case t'' of 

1154 
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

1155 
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

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

10127  1159 
BTAString > return $ r <> text ".s" <> brackets e 
6895  1160 
_ > return $ r <> brackets e 
6663  1161 
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

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

1164 
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

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

1168 
a > error $ "dereferencing from " ++ show a ++ "\n" ++ show rf 
7315  1169 
return $ 
6509  1170 
r1 <> text ">" <> r2 
6618  1171 
ref2C rf@(RecordField ref1 ref2) = do 
1172 
r1 < ref2C ref1 

1173 
t < gets lastType 

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

1175 
BTRecord _ rs > do 
7511  1176 
r2 < withRecordNamespace "" (rec2Records rs) $ ref2C ref2 
7033  1177 
return $ r1 <> text "." <> r2 
7055  1178 
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

1179 
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

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

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

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

1186 
r < fref2C ref 
6826  1187 
t < gets lastType 
1188 
case t of 

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

1189 
BTFunction _ _ bts t' > do 
10015  1190 
ps < liftM (parens . hsep . punctuate (char ',')) $ 
8020  1191 
if (length params) == (length bts)  hot fix for pas2cSystem and pas2cRedo functions since they don't have params 
10015  1192 
then 
8020  1193 
mapM expr2CHelper (zip params bts) 
1194 
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

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

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

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

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

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

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

1204 
expr2CHelper (e, (_, BTFunction _ _ _ _)) = do 
8020  1205 
modify (\s > s{isFunctionType = True}) 
1206 
expr2C e 

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

7315  1208 

6509  1209 
ref2C (Address ref) = do 
1210 
r < ref2C ref 

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

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

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

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

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

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

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

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

1220 
("shortstring", BTAString) > ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString)) 
7151  1221 
("shortstring", BTPointerTo _) > ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) 
10127  1222 
("ansistring", BTPointerTo _) > ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString)) 
10121  1223 
("ansistring", BTString) > ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString)) 
7151  1224 
(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

1225 
e < expr2C expr 
7315  1226 
t < id2C IOLookup t' 
7038  1227 
return . parens $ parens t <> e 
6467  1228 
ref2C (RefExpression expr) = expr2C expr 
6355  1229 

6509  1230 

6860  1231 
op2C :: String > String 
1232 
op2C "or" = "" 

1233 
op2C "and" = "&" 

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

1234 
op2C "not" = "~" 
6860  1235 
op2C "xor" = "^" 
1236 
op2C "div" = "/" 

1237 
op2C "mod" = "%" 

1238 
op2C "shl" = "<<" 

1239 
op2C "shr" = ">>" 

1240 
op2C "<>" = "!=" 

1241 
op2C "=" = "==" 

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

1242 
op2C "/" = "/(float)" 
6860  1243 
op2C a = a 
6273  1244 