author | unc0rr |
Sun, 18 Nov 2018 20:18:32 +0100 (2018-11-18) | |
changeset 14233 | b01770d42517 |
parent 13892 | 5988e73080a3 |
child 14239 | 27ae2d3d04b6 |
permissions | -rw-r--r-- |
6858 | 1 |
{-# LANGUAGE ScopedTypeVariables #-} |
6273 | 2 |
module Pas2C where |
3 |
||
13824
db1b680bd8d3
Resolve ambiguity of <> in Pas2C.hs
Wuzzy <Wuzzy2@mail.ru>
parents:
13349
diff
changeset
|
4 |
import Prelude hiding ((<>)) |
6273 | 5 |
import Text.PrettyPrint.HughesPJ |
6 |
import Data.Maybe |
|
6277 | 7 |
import Data.Char |
6511 | 8 |
import Text.Parsec.Prim hiding (State) |
6417
eae5900fd8a4
Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents:
6399
diff
changeset
|
9 |
import Control.Monad.State |
eae5900fd8a4
Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents:
6399
diff
changeset
|
10 |
import System.IO |
eae5900fd8a4
Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents:
6399
diff
changeset
|
11 |
import PascalPreprocessor |
eae5900fd8a4
Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents:
6399
diff
changeset
|
12 |
import Control.Exception |
eae5900fd8a4
Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents:
6399
diff
changeset
|
13 |
import System.IO.Error |
6425
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
14 |
import qualified Data.Map as Map |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
15 |
import qualified Data.Set as Set |
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 re-implemented, add prefix to all of them |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
150 |
currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"} |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
151 |
where |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
152 |
f = do |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
153 |
checkDuplicateFunDecls tvs |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
154 |
mapM_ (tvar2C True False True False) tvs |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
155 |
toNamespace _ (Program {}) = Map.empty |
7315 | 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 ++ "'..." |
13892 | 189 |
--let (fn, p) = pu in writeFile (outputPath ++ fn ++ ".dump") $ show p |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
190 |
toCFiles' pu |
6474
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
191 |
where |
7953 | 192 |
toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
7033 | 193 |
toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
194 |
let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
195 |
(a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
8020 | 196 |
enumDecl = (renderEnum2Strs (enums s) False) |
197 |
enumImpl = (renderEnum2Strs (enums s) True) |
|
198 |
writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl |
|
199 |
writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
200 |
toCFiles' _ = undefined -- just pleasing compiler to not warn us |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
201 |
initialState = emptyState ns |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
202 |
|
6516 | 203 |
render2C :: RenderState -> State RenderState Doc -> String |
8020 | 204 |
render2C st p = |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
205 |
let (a, _) = runState p st in |
8020 | 206 |
render a |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
207 |
|
8020 | 208 |
renderEnum2Strs :: [(String, [String])] -> Bool -> String |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
209 |
renderEnum2Strs enums' implement = |
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
210 |
render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums' |
8020 | 211 |
where |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
212 |
decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar") |
10015 | 213 |
enum2strBlock en = |
8020 | 214 |
text "{" |
215 |
$+$ |
|
216 |
(nest 4 $ |
|
217 |
text "switch(enumvar){" |
|
218 |
$+$ |
|
219 |
(foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en) |
|
220 |
$+$ |
|
221 |
text "default: assert(0);" |
|
222 |
$+$ |
|
223 |
(nest 4 $ text "return fpcrtl_make_string(\"nonsense\");") |
|
224 |
$+$ |
|
225 |
text "}" |
|
226 |
) |
|
227 |
$+$ |
|
228 |
text "}" |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
229 |
|
6467 | 230 |
usesFiles :: PascalUnit -> [String] |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
231 |
usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
232 |
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 |
6512 | 233 |
usesFiles (System {}) = [] |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
234 |
usesFiles (Redo {}) = [] |
6425
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
235 |
|
6512 | 236 |
pascal2C :: PascalUnit -> State RenderState Doc |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
237 |
pascal2C (Unit _ interface implementation _ _) = |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
238 |
liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
7315 | 239 |
|
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
240 |
pascal2C (Program _ implementation mainFunction) = do |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
241 |
impl <- implementation2C implementation |
10245 | 242 |
[main] <- tvar2C True False True True |
243 |
(FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) |
|
244 |
[VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing |
|
245 |
, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] |
|
246 |
(Just (TypesAndVars [], Phrases [mainResultInit, mainFunction]))) |
|
8020 | 247 |
|
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
248 |
return $ impl $+$ main |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
249 |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
250 |
pascal2C _ = error "pascal2C: pattern not matched" |
7315 | 251 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
252 |
-- the second bool indicates whether do normal interface translation or generate variable declarations |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
253 |
-- that will be inserted into implementation files |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
254 |
interface2C :: Interface -> Bool -> State RenderState Doc |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
255 |
interface2C (Interface uses tvars) True = do |
6965 | 256 |
u <- uses2C uses |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
257 |
tv <- typesAndVars2C True True True tvars |
6965 | 258 |
r <- renderStringConsts |
259 |
return (u $+$ r $+$ tv) |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
260 |
interface2C (Interface uses tvars) False = do |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
261 |
void $ uses2C uses |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
262 |
tv <- typesAndVars2C True False False tvars |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
263 |
void $ renderStringConsts |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
264 |
return tv |
7315 | 265 |
|
6512 | 266 |
implementation2C :: Implementation -> State RenderState Doc |
6896
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset
|
267 |
implementation2C (Implementation uses tvars) = do |
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset
|
268 |
u <- uses2C uses |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
269 |
tv <- typesAndVars2C True False True tvars |
6896
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset
|
270 |
r <- renderStringConsts |
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset
|
271 |
return (u $+$ r $+$ tv) |
6273 | 272 |
|
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
273 |
checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
274 |
checkDuplicateFunDecls tvs = |
7069 | 275 |
modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs} |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
276 |
where |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
277 |
initMap :: Map.Map String Int |
7069 | 278 |
initMap = Map.empty |
279 |
--initMap = Map.fromList [("reset", 2)] |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
280 |
ins (FunctionDeclaration (Identifier i _) _ _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
281 |
ins _ m = m |
6273 | 282 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
283 |
-- the second bool indicates whether declare variable as extern or not |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
284 |
-- the third bool indicates whether include types or not |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
285 |
|
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
286 |
typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
287 |
typesAndVars2C b externVar includeType(TypesAndVars ts) = do |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
288 |
checkDuplicateFunDecls ts |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
289 |
liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts |
6273 | 290 |
|
6816 | 291 |
setBaseType :: BaseType -> Identifier -> Identifier |
292 |
setBaseType bt (Identifier i _) = Identifier i bt |
|
293 |
||
6512 | 294 |
uses2C :: Uses -> State RenderState Doc |
6516 | 295 |
uses2C uses@(Uses unitIds) = do |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
296 |
|
6516 | 297 |
mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
298 |
mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds) |
6816 | 299 |
mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
6516 | 300 |
return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
301 |
where |
|
11845 | 302 |
injectNamespace :: Identifier -> State RenderState () |
6517 | 303 |
injectNamespace (Identifier i _) = do |
6516 | 304 |
getNS <- gets (flip Map.lookup . namespaces) |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
305 |
modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s}) |
6425
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
306 |
|
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
307 |
uses2List :: Uses -> [String] |
6489 | 308 |
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
6273 | 309 |
|
6509 | 310 |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
311 |
setLastIdValues :: Record -> RenderState -> RenderState |
7511 | 312 |
setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv}) |
313 |
||
6663 | 314 |
id2C :: InsertOption -> Identifier -> State RenderState Doc |
7511 | 315 |
id2C IOInsert i = id2C (IOInsertWithType empty) i |
316 |
id2C (IOInsertWithType d) (Identifier i t) = do |
|
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
317 |
tom <- gets (Set.member n . toMangle) |
7033 | 318 |
cu <- gets currentUnit |
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
319 |
let (i', t') = case (t, tom) of |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
320 |
(BTFunction _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
321 |
(BTFunction _ e _ _, _) -> ((if e then id else (++) cu) i, t) |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
322 |
(BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'') |
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
323 |
_ -> (i, t) |
7511 | 324 |
modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n}) |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
325 |
return $ text i' |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
326 |
where |
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
327 |
n = map toLower i |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
328 |
|
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
329 |
id2C IOLookup i = id2CLookup head i |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
330 |
id2C IOLookupLast i = id2CLookup last i |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
331 |
id2C (IOLookupFunction params) (Identifier i _) = do |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
332 |
let i' = map toLower i |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
333 |
v <- gets $ Map.lookup i' . currentScope |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
334 |
lt <- gets lastType |
7315 | 335 |
if isNothing v then |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
336 |
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
7315 | 337 |
else |
338 |
let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
|
7511 | 339 |
modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
340 |
where |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
341 |
checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
342 |
checkParam _ = False |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
343 |
id2C IODeferred (Identifier i _) = do |
6663 | 344 |
let i' = map toLower i |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
345 |
v <- gets $ Map.lookup i' . currentScope |
6663 | 346 |
if (isNothing v) then |
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
347 |
modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i) |
6663 | 348 |
else |
7511 | 349 |
let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
6512 | 350 |
|
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
351 |
id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
352 |
id2CLookup f (Identifier i _) = do |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
353 |
let i' = map toLower i |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
354 |
v <- gets $ Map.lookup i' . currentScope |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
355 |
lt <- gets lastType |
7315 | 356 |
if isNothing v then |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
357 |
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
7315 | 358 |
else |
7511 | 359 |
let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv) |
7315 | 360 |
|
361 |
||
8020 | 362 |
|
6653 | 363 |
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
7511 | 364 |
id2CTyped = id2CTyped2 Nothing |
365 |
||
366 |
id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc |
|
367 |
id2CTyped2 md t (Identifier i _) = do |
|
6653 | 368 |
tb <- resolveType t |
7315 | 369 |
case (t, tb) of |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
370 |
(_, BTUnknown) -> do |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
371 |
error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
372 |
(SimpleType {}, BTRecord _ r) -> do |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
373 |
ts <- type2C t |
7511 | 374 |
id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r)) |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
375 |
(_, BTRecord _ r) -> do |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
376 |
ts <- type2C t |
7511 | 377 |
id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r)) |
378 |
_ -> case md of |
|
379 |
Nothing -> id2C IOInsert (Identifier i tb) |
|
380 |
Just ts -> id2C (IOInsertWithType ts) (Identifier i tb) |
|
6626
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
381 |
|
8020 | 382 |
typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)] |
383 |
typeVarDecl2BaseType d = do |
|
384 |
st <- get |
|
385 |
result <- sequence $ concat $ map resolveType' d |
|
386 |
put st -- restore state (not sure if necessary) |
|
387 |
return result |
|
388 |
where |
|
389 |
resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)] |
|
390 |
resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar) |
|
391 |
resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration" |
|
392 |
resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType) |
|
393 |
resolveTypeHelper' st b = do |
|
394 |
bt <- st |
|
395 |
return (b, bt) |
|
10015 | 396 |
|
6626
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
397 |
resolveType :: TypeDecl -> State RenderState BaseType |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
398 |
resolveType st@(SimpleType (Identifier i _)) = do |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
399 |
let i' = map toLower i |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
400 |
v <- gets $ Map.lookup i' . currentScope |
7511 | 401 |
if isJust v then return . baseType . head $ fromJust v else return $ f i' |
6626
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
402 |
where |
8020 | 403 |
f "uinteger" = BTInt False |
404 |
f "integer" = BTInt True |
|
6626
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
405 |
f "pointer" = BTPointerTo BTVoid |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
406 |
f "boolean" = BTBool |
6649
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
407 |
f "float" = BTFloat |
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
408 |
f "char" = BTChar |
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
409 |
f "string" = BTString |
10120 | 410 |
f "ansistring" = BTAString |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
411 |
f _ = error $ "Unknown system type: " ++ show st |
6827 | 412 |
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) |
413 |
resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t |
|
6626
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
414 |
resolveType (RecordType tv mtvs) = do |
6827 | 415 |
tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
416 |
return . BTRecord "" . concat $ tvs |
6626
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
417 |
where |
6827 | 418 |
f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
7317 | 419 |
f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
420 |
f _ = error "resolveType f: pattern not matched" |
6893 | 421 |
resolveType (ArrayDecl (Just i) t) = do |
422 |
t' <- resolveType t |
|
8020 | 423 |
return $ BTArray i (BTInt True) t' |
424 |
resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t |
|
425 |
resolveType (FunctionType t a) = do |
|
10015 | 426 |
bts <- typeVarDecl2BaseType a |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
427 |
liftM (BTFunction False False bts) $ resolveType t |
8020 | 428 |
resolveType (DeriveType (InitHexNumber _)) = return (BTInt True) |
429 |
resolveType (DeriveType (InitNumber _)) = return (BTInt True) |
|
6835 | 430 |
resolveType (DeriveType (InitFloat _)) = return BTFloat |
431 |
resolveType (DeriveType (InitString _)) = return BTString |
|
8020 | 432 |
resolveType (DeriveType (InitBinOp {})) = return (BTInt True) |
7151 | 433 |
resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType |
8020 | 434 |
resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True) |
6835 | 435 |
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
436 |
resolveType (DeriveType _) = return BTUnknown |
|
10111
459bc720cea1
Drop support for other string types than string255
unc0rr
parents:
10015
diff
changeset
|
437 |
resolveType String = return BTString |
10120 | 438 |
resolveType AString = return BTAString |
6826 | 439 |
resolveType VoidType = return BTVoid |
6653 | 440 |
resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
441 |
resolveType (RangeType _) = return $ BTVoid |
6653 | 442 |
resolveType (Set t) = liftM BTSet $ resolveType t |
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
443 |
resolveType (VarParamType t) = liftM BTVarParam $ resolveType t |
7315 | 444 |
|
6834 | 445 |
|
6967
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
446 |
resolve :: String -> BaseType -> State RenderState BaseType |
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
447 |
resolve s (BTUnresolved t) = do |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
448 |
v <- gets $ Map.lookup t . currentScope |
6967
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
449 |
if isJust v then |
7511 | 450 |
resolve s . baseType . head . fromJust $ v |
6967
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
451 |
else |
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
452 |
error $ "Unknown type " ++ show t ++ "\n" ++ s |
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
453 |
resolve _ t = return t |
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
454 |
|
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
455 |
fromPointer :: String -> BaseType -> State RenderState BaseType |
1224c6fb36c3
Support recurrent function calls. The code is kinda hackish and ugly, but I really spent a few hours thinking on a good solution.
unc0rr
parents:
6965
diff
changeset
|
456 |
fromPointer s (BTPointerTo t) = resolve s t |
6855
807156c01475
Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents:
6854
diff
changeset
|
457 |
fromPointer s t = do |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
458 |
error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
6834 | 459 |
|
7315 | 460 |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
461 |
functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
462 |
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params |
6834 | 463 |
|
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
464 |
numberOfDeclarations :: [TypeVarDeclaration] -> Int |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
465 |
numberOfDeclarations = sum . map cnt |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
466 |
where |
7317 | 467 |
cnt (VarDeclaration _ _ (ids, _) _) = length ids |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
468 |
cnt _ = 1 |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
469 |
|
7317 | 470 |
hasPassByReference :: [TypeVarDeclaration] -> Bool |
471 |
hasPassByReference = or . map isVar |
|
472 |
where |
|
473 |
isVar (VarDeclaration v _ (_, _) _) = v |
|
474 |
isVar _ = error $ "hasPassByReference called not on function parameters" |
|
475 |
||
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
476 |
toIsVarList :: [TypeVarDeclaration] -> [Bool] |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
477 |
toIsVarList = concatMap isVar |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
478 |
where |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
479 |
isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
480 |
isVar _ = error $ "toIsVarList called not on function parameters" |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
481 |
|
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
482 |
|
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
483 |
funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
484 |
funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
485 |
where |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
486 |
abc = hcat . punctuate comma . map (char . fst) $ ps |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
487 |
cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
488 |
ps = zip ['a'..] (toIsVarList params) |
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
489 |
|
6880 | 490 |
fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
491 |
fun2C _ _ (FunctionDeclaration name _ overload external returnType params Nothing) = do |
7315 | 492 |
t <- type2C returnType |
6855
807156c01475
Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents:
6854
diff
changeset
|
493 |
t'<- gets lastType |
8020 | 494 |
bts <- typeVarDecl2BaseType params |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
495 |
p <- withState' id $ functionParams2C params |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
496 |
n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name |
8020 | 497 |
let decor = if overload then text "__attribute__((overloadable))" else empty |
498 |
return [t empty <+> decor <+> text n <> parens p] |
|
7315 | 499 |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
500 |
fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do |
7134 | 501 |
let isVoid = case returnType of |
502 |
VoidType -> True |
|
503 |
_ -> False |
|
7315 | 504 |
|
8020 | 505 |
let res = docToLower $ text rv <> if isVoid then empty else text "_result" |
506 |
t <- type2C returnType |
|
507 |
t' <- gets lastType |
|
508 |
||
509 |
bts <- typeVarDecl2BaseType params |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
510 |
--cu <- gets currentUnit |
8020 | 511 |
notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope |
512 |
||
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
513 |
n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name |
8020 | 514 |
let resultId = if isVoid |
515 |
then n -- void type doesn't have result, solving recursive procedure calls |
|
516 |
else (render res) |
|
517 |
||
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
518 |
(p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else t') empty] $ currentScope st |
7134 | 519 |
, currentFunctionResult = if isVoid then [] else render res}) $ do |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
520 |
p <- functionParams2C params |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
521 |
ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) |
6827 | 522 |
return (p, ph) |
7315 | 523 |
|
10497
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset
|
524 |
let isTrivialReturn = case phrase of |
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset
|
525 |
(Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True |
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset
|
526 |
_ -> False |
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset
|
527 |
let phrasesBlock = if isVoid || isTrivialReturn then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
528 |
--let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty |
8020 | 529 |
let inlineDecor = if inline then case notDeclared of |
530 |
True -> text "static inline" |
|
531 |
False -> text "inline" |
|
532 |
else empty |
|
533 |
overloadDecor = if overload then text "__attribute__((overloadable))" else empty |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
534 |
return [ |
8020 | 535 |
--define |
536 |
-- $+$ |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
537 |
--(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$ |
8020 | 538 |
inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p |
6425
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
539 |
$+$ |
7315 | 540 |
text "{" |
541 |
$+$ |
|
6836 | 542 |
nest 4 phrasesBlock |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
543 |
$+$ |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
544 |
text "}"] |
6425
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
545 |
where |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
546 |
phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
6425
1ef4192aa80d
- Parse unions, sets, function type, packed arrays and some more imporvements to the parser. Now it parses uVariable, uConsts and even SDLh.pas
unc0rr
parents:
6417
diff
changeset
|
547 |
phrase2C' p = phrase2C p |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
548 |
un [a] b = a : b |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
549 |
un _ _ = error "fun2C u: pattern not matched" |
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
550 |
hasVars = hasPassByReference params |
7315 | 551 |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
552 |
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = error $ "nested functions not allowed: " ++ name |
6880 | 553 |
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
6618 | 554 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
555 |
-- the second bool indicates whether declare variable as extern or not |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
556 |
-- the third bool indicates whether include types or not |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
557 |
-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
558 |
tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
559 |
tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = do |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
560 |
t <- fun2C b name f |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
561 |
if includeType then return t else return [] |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
562 |
tvar2C _ _ includeType _ (TypeDeclaration i' t) = do |
6653 | 563 |
i <- id2CTyped t i' |
7039 | 564 |
tp <- type2C t |
8020 | 565 |
let res = if includeType then [text "typedef" <+> tp i] else [] |
566 |
case t of |
|
567 |
(Sequence ids) -> do |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
568 |
modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s}) |
8020 | 569 |
return res |
570 |
_ -> return res |
|
7315 | 571 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
572 |
tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
573 |
t' <- liftM ((empty <+>) . ) $ type2C t |
7511 | 574 |
liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids |
7323
8490a4f439a5
Convert function with var parameters declarations into #define + function which accepts pointers
unc0rr
parents:
7317
diff
changeset
|
575 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
576 |
tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
8442 | 577 |
t' <- liftM (((if isConst then text "static const" else if externVar |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
578 |
then text "extern" |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
579 |
else empty) |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
580 |
<+>) . ) $ type2C t |
6980 | 581 |
ie <- initExpr mInitExpr |
6979 | 582 |
lt <- gets lastType |
583 |
case (isConst, lt, ids, mInitExpr) of |
|
8020 | 584 |
(True, BTInt _, [i], Just _) -> do |
6979 | 585 |
i' <- id2CTyped t i |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
586 |
return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] |
7002 | 587 |
(True, BTFloat, [i], Just e) -> do |
588 |
i' <- id2CTyped t i |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
589 |
ie' <- initExpr2C e |
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
590 |
return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else [] |
7327
4e35c45d0853
Fix the function definition issue so the function pointer format now looks correct.
xymeng
parents:
7323
diff
changeset
|
591 |
(_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
592 |
(_, BTArray r _ _, [i], _) -> do |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
593 |
i' <- id2CTyped t i |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
594 |
ie' <- return $ case (r, mInitExpr, ignoreInit) of |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
595 |
(RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
596 |
(_, _, _) -> ie |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
597 |
result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
598 |
case (r, ignoreInit) of |
8442 | 599 |
(RangeInfinite, False) -> |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
600 |
-- if the array is dynamic, add dimension info to it |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
601 |
return $ [dimDecl] ++ result |
8442 | 602 |
where |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
603 |
arrayDimStr = show $ arrayDimension t |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
604 |
arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}") |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
605 |
dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp |
8442 | 606 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
607 |
(_, _) -> return result |
8442 | 608 |
|
7511 | 609 |
_ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids |
6355 | 610 |
where |
6509 | 611 |
initExpr Nothing = return $ empty |
612 |
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
613 |
varDeclDecision True True varStr expStr = varStr <+> expStr |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
614 |
varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
615 |
varDeclDecision False False varStr expStr = varStr <+> expStr |
13883
0ce8aad17c24
IFDEF out missing function with FIXME, revert pas2c change in 0ecf77e203c0 as suggested by unc0rr, another string annotation
nemo
parents:
13867
diff
changeset
|
616 |
varDeclDecision True False _ _ = empty |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
617 |
arrayDimension a = case a of |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
618 |
ArrayDecl Nothing t' -> let a' = arrayDimension t' in |
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
619 |
if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
620 |
ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
621 |
_ -> 0 |
7315 | 622 |
|
7513 | 623 |
tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do |
6880 | 624 |
r <- op2CTyped op (extractTypes params) |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
625 |
fun2C f i (FunctionDeclaration r inline False False ret params body) |
6355 | 626 |
|
7315 | 627 |
|
6880 | 628 |
op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
629 |
op2CTyped op t = do |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
630 |
t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t |
6880 | 631 |
bt <- gets lastType |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
632 |
return $ Identifier (t' ++ "_op_" ++ opStr) bt |
7315 | 633 |
where |
6880 | 634 |
opStr = case op of |
635 |
"+" -> "add" |
|
636 |
"-" -> "sub" |
|
637 |
"*" -> "mul" |
|
638 |
"/" -> "div" |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
639 |
"/(float)" -> "div" |
6880 | 640 |
"=" -> "eq" |
641 |
"<" -> "lt" |
|
642 |
">" -> "gt" |
|
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
643 |
"<>" -> "neq" |
6880 | 644 |
_ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" |
7315 | 645 |
|
6880 | 646 |
extractTypes :: [TypeVarDeclaration] -> [TypeDecl] |
647 |
extractTypes = concatMap f |
|
648 |
where |
|
7317 | 649 |
f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t |
6880 | 650 |
f a = error $ "extractTypes: can't extract from " ++ show a |
651 |
||
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
652 |
initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
653 |
initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
654 |
initExpr2C a = initExpr2C' a |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
655 |
initExpr2C' InitNull = return $ text "NULL" |
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
656 |
initExpr2C' (InitAddress expr) = do |
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
657 |
ie <- initExpr2C' expr |
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
658 |
lt <- gets lastType |
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
659 |
case lt of |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
660 |
BTFunction True _ _ _ -> return $ text "&" <> ie -- <> text "__vars" |
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
661 |
_ -> return $ text "&" <> ie |
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
662 |
initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
663 |
initExpr2C' (InitBinOp op expr1 expr2) = do |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
664 |
e1 <- initExpr2C' expr1 |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
665 |
e2 <- initExpr2C' expr2 |
6860 | 666 |
return $ parens $ e1 <+> text (op2C op) <+> e2 |
8020 | 667 |
initExpr2C' (InitNumber s) = do |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
668 |
modify(\st -> st{lastType = (BTInt True)}) |
10015 | 669 |
return $ text s |
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
670 |
initExpr2C' (InitFloat s) = return $ text s |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
671 |
initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
672 |
initExpr2C' (InitString [a]) = return . quotes $ text [a] |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
673 |
initExpr2C' (InitString s) = return $ strInit s |
10747
07ade56c3b4a
backporting some build system fixes and pas2c tweaks
sheepluva
parents:
10688
diff
changeset
|
674 |
initExpr2C' (InitPChar s) = return $ doubleQuotes (text $ escapeStr s) |
9964 | 675 |
initExpr2C' (InitChar a) = return $ text "0x" <> text (showHex (read a) "") |
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
676 |
initExpr2C' (InitReference i) = id2C IOLookup i |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
677 |
initExpr2C' (InitRecord fields) = do |
6858 | 678 |
(fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
6886 | 679 |
return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace |
9954 | 680 |
--initExpr2C' (InitArray [InitRecord fields]) = do |
681 |
-- e <- initExpr2C $ InitRecord fields |
|
682 |
-- return $ braces $ e |
|
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
683 |
initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
684 |
void $ id2C IOLookup i |
6891
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset
|
685 |
t <- gets lastType |
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset
|
686 |
case t of |
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset
|
687 |
BTEnum s -> return . int $ length s |
8020 | 688 |
BTInt _ -> case i' of |
6891
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset
|
689 |
"byte" -> return $ int 256 |
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset
|
690 |
_ -> error $ "InitRange identifier: " ++ i' |
ab9843957664
Improve rendering of function types, ranges, and more
unc0rr
parents:
6887
diff
changeset
|
691 |
_ -> error $ "InitRange: " ++ show r |
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
692 |
initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
693 |
initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
694 |
initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
695 |
initExpr2C' (InitSet []) = return $ text "0" |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
696 |
initExpr2C' (InitSet _) = return $ text "<<set>>" |
7315 | 697 |
initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ |
6887 | 698 |
case e of |
699 |
(Identifier "LongInt" _) -> int (-2^31) |
|
6893 | 700 |
(Identifier "SmallInt" _) -> int (-2^15) |
701 |
_ -> error $ "BuiltInFunction 'low': " ++ show e |
|
13862
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13824
diff
changeset
|
702 |
initExpr2C' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do |
13863 | 703 |
void $ initExpr2C e |
704 |
t <- gets lastType |
|
705 |
case t of |
|
706 |
(BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i] |
|
13862
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13824
diff
changeset
|
707 |
BTInt _ -> case e' of |
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13824
diff
changeset
|
708 |
(Identifier "LongInt" _) -> return $ int (2147483647) |
13864
885ee14fe640
Fix previous patch, add support for High(Longword)
unc0rr
parents:
13862
diff
changeset
|
709 |
(Identifier "LongWord" _) -> return $ text "4294967295" |
885ee14fe640
Fix previous patch, add support for High(Longword)
unc0rr
parents:
13862
diff
changeset
|
710 |
_ -> error $ "BuiltInFunction 'high' in initExpr: " ++ show e' |
13862
bc90a932a4b3
Fix pas2c not having support for High(LongInt) in init expressions
unc0rr
parents:
13824
diff
changeset
|
711 |
a -> error $ "BuiltInFunction 'high' in initExpr: " ++ show a ++ ": " ++ show hi |
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
712 |
initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
713 |
initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
714 |
initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e |
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
715 |
initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e |
7315 | 716 |
initExpr2C' b@(BuiltInFunction _ _) = error $ show b |
10131
4b4a043111f4
- pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset
|
717 |
initExpr2C' (InitTypeCast t' i) = do |
4b4a043111f4
- pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset
|
718 |
e <- initExpr2C i |
4b4a043111f4
- pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset
|
719 |
t <- id2C IOLookup t' |
4b4a043111f4
- pas2c recognizes typecasts in initialization expressions
unc0rr
parents:
10129
diff
changeset
|
720 |
return . parens $ parens t <> e |
7052
cefb73639f70
Be more wise about constant initialization expressions being not arrays
unc0rr
parents:
7046
diff
changeset
|
721 |
initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a |
6391 | 722 |
|
6887 | 723 |
|
6874 | 724 |
range2C :: InitExpression -> State RenderState [Doc] |
725 |
range2C (InitString [a]) = return [quotes $ text [a]] |
|
726 |
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i |
|
727 |
range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b] |
|
728 |
range2C a = liftM (flip (:) []) $ initExpr2C a |
|
6391 | 729 |
|
6980 | 730 |
baseType2C :: String -> BaseType -> Doc |
731 |
baseType2C _ BTFloat = text "float" |
|
732 |
baseType2C _ BTBool = text "bool" |
|
733 |
baseType2C _ BTString = text "string255" |
|
10120 | 734 |
baseType2C _ BTAString = text "astring" |
6980 | 735 |
baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s |
736 |
||
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
737 |
type2C :: TypeDecl -> State RenderState (Doc -> Doc) |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
738 |
type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i |
6838 | 739 |
type2C t = do |
740 |
r <- type2C' t |
|
741 |
rt <- resolveType t |
|
742 |
modify (\st -> st{lastType = rt}) |
|
743 |
return r |
|
744 |
where |
|
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
745 |
type2C' VoidType = return (text "void" <+>) |
10111
459bc720cea1
Drop support for other string types than string255
unc0rr
parents:
10015
diff
changeset
|
746 |
type2C' String = return (text "string255" <+>)--return (text ("string" ++ show l) <+>) |
10120 | 747 |
type2C' AString = return (text "astring" <+>) |
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
748 |
type2C' (PointerTo (SimpleType i)) = do |
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
749 |
i' <- id2C IODeferred i |
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
750 |
lt <- gets lastType |
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
751 |
case lt of |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
752 |
BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
7034
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
753 |
BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
e3639ce1d4f8
(PointerTo (SimpleType _)) could be a pointer to a non-struct type
unc0rr
parents:
7033
diff
changeset
|
754 |
_ -> return $ \a -> i' <+> text "*" <+> a |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
755 |
type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t |
6838 | 756 |
type2C' (RecordType tvs union) = do |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
757 |
t' <- withState' f $ mapM (tvar2C False False True False) tvs |
6886 | 758 |
u <- unions |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
759 |
return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i |
6886 | 760 |
where |
7040
4aff2da0d0b3
Render function variables in struct with no mangling. 13 C units are compilable now.
unc0rr
parents:
7039
diff
changeset
|
761 |
f s = s{currentUnit = ""} |
6886 | 762 |
unions = case union of |
763 |
Nothing -> return empty |
|
764 |
Just a -> do |
|
765 |
structs <- mapM struct2C a |
|
766 |
return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
767 |
struct2C stvs = do |
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
768 |
txts <- withState' f $ mapM (tvar2C False False True False) stvs |
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
769 |
return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi |
6894 | 770 |
type2C' (RangeType r) = return (text "int" <+>) |
6838 | 771 |
type2C' (Sequence ids) = do |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
772 |
is <- mapM (id2C IOInsert . setBaseType bt) ids |
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
773 |
return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
774 |
where |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
775 |
bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
6894 | 776 |
type2C' (ArrayDecl Nothing t) = type2C (PointerTo t) |
14233
b01770d42517
Special case for rendering type of two-dimensional arrays, since C is inconsistent in its syntax
unc0rr
parents:
13892
diff
changeset
|
777 |
type2C' (ArrayDecl (Just r1) (ArrayDecl (Just r2) t)) = do |
b01770d42517
Special case for rendering type of two-dimensional arrays, since C is inconsistent in its syntax
unc0rr
parents:
13892
diff
changeset
|
778 |
t' <- type2C t |
b01770d42517
Special case for rendering type of two-dimensional arrays, since C is inconsistent in its syntax
unc0rr
parents:
13892
diff
changeset
|
779 |
lt <- gets lastType |
b01770d42517
Special case for rendering type of two-dimensional arrays, since C is inconsistent in its syntax
unc0rr
parents:
13892
diff
changeset
|
780 |
r1' <- initExpr2C (InitRange r1) |
b01770d42517
Special case for rendering type of two-dimensional arrays, since C is inconsistent in its syntax
unc0rr
parents:
13892
diff
changeset
|
781 |
r2' <- initExpr2C (InitRange r2) |
b01770d42517
Special case for rendering type of two-dimensional arrays, since C is inconsistent in its syntax
unc0rr
parents:
13892
diff
changeset
|
782 |
return $ \i -> t' i <> brackets r1' <> brackets r2' |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
783 |
type2C' (ArrayDecl (Just r) t) = do |
6858 | 784 |
t' <- type2C t |
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
785 |
lt <- gets lastType |
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
786 |
ft <- case lt of |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
787 |
-- BTFunction {} -> type2C (PointerTo t) |
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
788 |
_ -> return t' |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
789 |
r' <- initExpr2C (InitRange r) |
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
790 |
return $ \i -> ft i <> brackets r' |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
791 |
type2C' (Set t) = return (text "<<set>>" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
792 |
type2C' (FunctionType returnType params) = do |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
793 |
t <- type2C returnType |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
794 |
p <- withState' id $ functionParams2C params |
7327
4e35c45d0853
Fix the function definition issue so the function pointer format now looks correct.
xymeng
parents:
7323
diff
changeset
|
795 |
return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p)) |
6980 | 796 |
type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i) |
6858 | 797 |
type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
798 |
type2C' (DeriveType (InitNumber _)) = return (text "int" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
799 |
type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
800 |
type2C' (DeriveType (InitFloat _)) = return (text "float" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
801 |
type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
802 |
type2C' (DeriveType (InitString {})) = return (text "string255" <+>) |
6980 | 803 |
type2C' (DeriveType r@(InitReference {})) = do |
804 |
initExpr2C r |
|
805 |
t <- gets lastType |
|
806 |
return (baseType2C (show r) t <+>) |
|
6858 | 807 |
type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
808 |
type2C' a = error $ "type2C: unknown type " ++ show a |
6273 | 809 |
|
6512 | 810 |
phrase2C :: Phrase -> State RenderState Doc |
6509 | 811 |
phrase2C (Phrases p) = do |
812 |
ps <- mapM phrase2C p |
|
813 |
return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
|
814 |
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
|
8020 | 815 |
phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
816 |
phrase2C (ProcCall _ _) = error $ "ProcCall"{-do |
6509 | 817 |
r <- ref2C ref |
818 |
ps <- mapM expr2C params |
|
6923 | 819 |
return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
6509 | 820 |
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
821 |
e <- expr2C expr |
|
822 |
p1 <- (phrase2C . wrapPhrase) phrase1 |
|
823 |
el <- elsePart |
|
7315 | 824 |
return $ |
6509 | 825 |
text "if" <> parens e $+$ p1 $+$ el |
6273 | 826 |
where |
6509 | 827 |
elsePart | isNothing mphrase2 = return $ empty |
828 |
| otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
|
8446
c18ba8726f5a
Fix sources so pas2c written in haskell could render them again
unc0rr
parents:
8444
diff
changeset
|
829 |
phrase2C asgn@(Assignment ref expr) = do |
6923 | 830 |
r <- ref2C ref |
831 |
t <- gets lastType |
|
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
832 |
case (t, expr) of |
10142 | 833 |
(_, Reference r') | ref == r' -> do |
834 |
e <- ref2C r' |
|
835 |
return $ text "UNUSED" <+> parens e <> semi |
|
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
836 |
(BTFunction {}, (Reference r')) -> do |
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
837 |
e <- ref2C r' |
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
838 |
return $ r <+> text "=" <+> e <> semi |
7134 | 839 |
(BTString, _) -> do |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
840 |
void $ expr2C expr |
7134 | 841 |
lt <- gets lastType |
842 |
case lt of |
|
843 |
-- assume pointer to char for simplicity |
|
844 |
BTPointerTo _ -> do |
|
845 |
e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown)) |
|
846 |
return $ r <+> text "=" <+> e <> semi |
|
10120 | 847 |
BTAString -> do |
848 |
e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown)) |
|
849 |
return $ r <+> text "=" <+> e <> semi |
|
7134 | 850 |
BTString -> do |
851 |
e <- expr2C expr |
|
852 |
return $ r <+> text "=" <+> e <> semi |
|
10120 | 853 |
_ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn |
854 |
(BTAString, _) -> do |
|
855 |
void $ expr2C expr |
|
856 |
lt <- gets lastType |
|
857 |
case lt of |
|
858 |
-- assume pointer to char for simplicity |
|
859 |
BTPointerTo _ -> do |
|
860 |
e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown)) |
|
861 |
return $ r <+> text "=" <+> e <> semi |
|
862 |
BTString -> do |
|
863 |
e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown)) |
|
864 |
return $ r <+> text "=" <+> e <> semi |
|
865 |
BTAString -> do |
|
866 |
e <- expr2C expr |
|
867 |
return $ r <+> text "=" <+> e <> semi |
|
868 |
_ -> error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
869 |
(BTArray _ _ _, _) -> do |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
870 |
case expr of |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
871 |
Reference er -> do |
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
872 |
void $ ref2C er |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
873 |
exprT <- gets lastType |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
874 |
case exprT of |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
875 |
BTArray RangeInfinite _ _ -> |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
876 |
return $ text "FIXME: assign a dynamic array to an array" |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
877 |
BTArray _ _ _ -> phrase2C $ |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
878 |
ProcCall (FunCall |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
879 |
[ |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
880 |
Reference $ ref |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
881 |
, Reference $ RefExpression expr |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
882 |
, Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown)) |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
883 |
] |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
884 |
(SimpleReference (Identifier "memcpy" BTUnknown)) |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
885 |
) [] |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
886 |
_ -> return $ text "FIXME: assign a non-specific value to an array" |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
887 |
|
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
888 |
_ -> return $ text "FIXME: dynamic array assignment 2" |
7066
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
889 |
_ -> do |
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
890 |
e <- expr2C expr |
12cc2bd84b0b
Make pas2c even more happier with uGears.c, allow assigning arrays in some cases
unc0rr
parents:
7062
diff
changeset
|
891 |
return $ r <+> text "=" <+> e <> semi |
6509 | 892 |
phrase2C (WhileCycle expr phrase) = do |
893 |
e <- expr2C expr |
|
894 |
p <- phrase2C $ wrapPhrase phrase |
|
895 |
return $ text "while" <> parens e $$ p |
|
896 |
phrase2C (SwitchCase expr cases mphrase) = do |
|
897 |
e <- expr2C expr |
|
898 |
cs <- mapM case2C cases |
|
6874 | 899 |
d <- dflt |
7315 | 900 |
return $ |
6895 | 901 |
text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) |
6273 | 902 |
where |
6512 | 903 |
case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
6509 | 904 |
case2C (e, p) = do |
6874 | 905 |
ies <- mapM range2C e |
6509 | 906 |
ph <- phrase2C p |
7315 | 907 |
return $ |
6874 | 908 |
vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
909 |
dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning |
6874 | 910 |
| otherwise = do |
911 |
ph <- mapM phrase2C $ fromJust mphrase |
|
912 |
return [text "default:" <+> nest 4 (vcat ph)] |
|
7315 | 913 |
|
6845 | 914 |
phrase2C wb@(WithBlock ref p) = do |
7315 | 915 |
r <- ref2C ref |
6845 | 916 |
t <- gets lastType |
917 |
case t of |
|
7511 | 918 |
(BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p |
6845 | 919 |
a -> do |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
920 |
error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
921 |
phrase2C (ForCycle i' e1' e2' p up) = do |
6663 | 922 |
i <- id2C IOLookup i' |
7511 | 923 |
iType <- gets lastIdTypeDecl |
6509 | 924 |
e1 <- expr2C e1' |
925 |
e2 <- expr2C e2' |
|
7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
7513
diff
changeset
|
926 |
let iEnd = i <> text "__end__" |
10688
9459c45b5190
dark magic: make "continue" statement work in pas2c-parsed for-loops. (would skip iteration and lead to infinite loops before)
sheepluva
parents:
10497
diff
changeset
|
927 |
ph <- phrase2C $ wrapPhrase p |
7511 | 928 |
return . braces $ |
929 |
i <+> text "=" <+> e1 <> semi |
|
6509 | 930 |
$$ |
7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
7513
diff
changeset
|
931 |
iType <+> iEnd <+> text "=" <+> e2 <> semi |
10015 | 932 |
$$ |
8020 | 933 |
text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> |
10688
9459c45b5190
dark magic: make "continue" statement work in pas2c-parsed for-loops. (would skip iteration and lead to infinite loops before)
sheepluva
parents:
10497
diff
changeset
|
934 |
text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi |
7511 | 935 |
where |
936 |
appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] |
|
10497
c7c50f165946
[PAS2C] Don't generate result variable for trivial functions consisting of single exit() call
unc0rr
parents:
10245
diff
changeset
|
937 |
appendPhrase _ _ = error "illegal appendPhrase call" |
6509 | 938 |
phrase2C (RepeatCycle e' p') = do |
939 |
e <- expr2C e' |
|
940 |
p <- phrase2C (Phrases p') |
|
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
941 |
return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
8020 | 942 |
|
6509 | 943 |
phrase2C NOP = return $ text ";" |
6355 | 944 |
|
7134 | 945 |
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do |
946 |
f <- gets currentFunctionResult |
|
947 |
if null f then |
|
948 |
return $ text "return" <> semi |
|
949 |
else |
|
950 |
return $ text "return" <+> text f <> semi |
|
7038 | 951 |
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
952 |
phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi |
7037 | 953 |
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e |
6895 | 954 |
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e |
955 |
phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2) |
|
956 |
phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e |
|
957 |
phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2) |
|
958 |
phrase2C a = error $ "phrase2C: " ++ show a |
|
6273 | 959 |
|
6307 | 960 |
wrapPhrase p@(Phrases _) = p |
961 |
wrapPhrase p = Phrases [p] |
|
6273 | 962 |
|
6512 | 963 |
expr2C :: Expression -> State RenderState Doc |
6509 | 964 |
expr2C (Expression s) = return $ text s |
10120 | 965 |
expr2C bop@(BinOp op expr1 expr2) = do |
6509 | 966 |
e1 <- expr2C expr1 |
6860 | 967 |
t1 <- gets lastType |
6509 | 968 |
e2 <- expr2C expr2 |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
969 |
t2 <- gets lastType |
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
970 |
case (op2C op, t1, t2) of |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
971 |
("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString)) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
972 |
("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2 BTAString)) |
13349
4f9108f82879
Pas2C: Add support for char + ansistring (for real this time)
Wuzzy <Wuzzy2@mail.ru>
parents:
13311
diff
changeset
|
973 |
("+", BTChar, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprependA" (fff t1 t2 BTAString)) |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
974 |
("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2 BTBool)) |
10120 | 975 |
(_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop |
976 |
(_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
977 |
("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2 BTString)) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
978 |
("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2 BTString)) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
979 |
("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2 BTString)) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
980 |
("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2 BTString)) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
981 |
("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2 BTBool)) |
8020 | 982 |
|
983 |
-- for function/procedure comparision |
|
984 |
("==", BTVoid, _) -> procCompare expr1 expr2 "==" |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
985 |
("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "==" |
8020 | 986 |
|
987 |
("!=", BTVoid, _) -> procCompare expr1 expr2 "!=" |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
988 |
("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!=" |
8020 | 989 |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
990 |
("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2 BTBool)) |
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
991 |
("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2 BTBool)) |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
992 |
("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
993 |
("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
994 |
(_, BTRecord t1 _, BTRecord t2 _) -> do |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
995 |
i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
996 |
ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
8020 | 997 |
(_, BTRecord t1 _, BTInt _) -> do |
7056 | 998 |
-- aw, "LongInt" here is hwengine-specific hack |
999 |
i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] |
|
1000 |
ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
|
7315 | 1001 |
("in", _, _) -> |
7057
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset
|
1002 |
case expr2 of |
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset
|
1003 |
SetExpression set -> do |
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset
|
1004 |
ids <- mapM (id2C IOLookup) set |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1005 |
modify(\s -> s{lastType = BTBool}) |
7057
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset
|
1006 |
return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids |
c3eba84d1a98
Support operator 'in', replace it with equality checks against each element of set
unc0rr
parents:
7056
diff
changeset
|
1007 |
_ -> error "'in' against not set expression" |
6923 | 1008 |
(o, _, _) | o `elem` boolOps -> do |
1009 |
modify(\s -> s{lastType = BTBool}) |
|
1010 |
return $ parens e1 <+> text o <+> parens e2 |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1011 |
| otherwise -> do |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1012 |
o' <- return $ case o of |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1013 |
"/(float)" -> text "/(float)" -- pascal returns real value |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1014 |
_ -> text o |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1015 |
e1' <- return $ case (o, t1, t2) of |
8020 | 1016 |
("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1 |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1017 |
_ -> parens e1 |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1018 |
e2' <- return $ case (o, t1, t2) of |
8020 | 1019 |
("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2 |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1020 |
_ -> parens e2 |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1021 |
return $ e1' <+> o' <+> e2' |
6923 | 1022 |
where |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1023 |
fff t1 t2 = BTFunction False False [(False, t1), (False, t2)] |
6923 | 1024 |
boolOps = ["==", "!=", "<", ">", "<=", ">="] |
8020 | 1025 |
procCompare expr1 expr2 op = |
1026 |
case (expr1, expr2) of |
|
1027 |
(Reference r1, Reference r2) -> do |
|
1028 |
id1 <- ref2C r1 |
|
1029 |
id2 <- ref2C r2 |
|
1030 |
return $ (parens id1) <+> text op <+> (parens id2) |
|
1031 |
(_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2 |
|
1032 |
||
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1033 |
expr2C (NumberLiteral s) = do |
8020 | 1034 |
modify(\s -> s{lastType = BTInt True}) |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1035 |
return $ text s |
6509 | 1036 |
expr2C (FloatLiteral s) = return $ text s |
1037 |
expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
|
7067
f98ec3aecf4e
A solution to char vs string problem: mark single-letter strings with _S macro
unc0rr
parents:
7066
diff
changeset
|
1038 |
{-expr2C (StringLiteral [a]) = do |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1039 |
modify(\s -> s{lastType = BTChar}) |
7043
7c080e5ac8d0
Some work to make more units compile after conversion to c
unc0rr
parents:
7042
diff
changeset
|
1040 |
return . quotes . text $ escape a |
7c080e5ac8d0
Some work to make more units compile after conversion to c
unc0rr
parents:
7042
diff
changeset
|
1041 |
where |
7c080e5ac8d0
Some work to make more units compile after conversion to c
unc0rr
parents:
7042
diff
changeset
|
1042 |
escape '\'' = "\\\'" |
7067
f98ec3aecf4e
A solution to char vs string problem: mark single-letter strings with _S macro
unc0rr
parents:
7066
diff
changeset
|
1043 |
escape a = [a]-} |
6896
23b38e530967
Move all strings into constants to make them of string255 type
unc0rr
parents:
6895
diff
changeset
|
1044 |
expr2C (StringLiteral s) = addStringConst s |
7072 | 1045 |
expr2C (PCharLiteral s) = return . doubleQuotes $ text s |
8020 | 1046 |
expr2C (Reference ref) = do |
1047 |
isfunc <- gets isFunctionType |
|
1048 |
modify(\s -> s{isFunctionType = False}) -- reset |
|
1049 |
if isfunc then ref2CF ref False else ref2CF ref True |
|
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1050 |
expr2C (PrefixOp op expr) = do |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1051 |
e <- expr2C expr |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1052 |
lt <- gets lastType |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1053 |
case lt of |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1054 |
BTRecord t _ -> do |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1055 |
i <- op2CTyped op [SimpleType (Identifier t undefined)] |
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1056 |
ref2C $ FunCall [expr] (SimpleReference i) |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1057 |
BTBool -> do |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1058 |
o <- return $ case op of |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1059 |
"not" -> text "!" |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1060 |
_ -> text (op2C op) |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1061 |
return $ o <> parens e |
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1062 |
_ -> return $ text (op2C op) <> parens e |
6509 | 1063 |
expr2C Null = return $ text "NULL" |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1064 |
expr2C (CharCode a) = do |
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1065 |
modify(\s -> s{lastType = BTChar}) |
9964 | 1066 |
return $ text "0x" <> text (showHex (read a) "") |
7075 | 1067 |
expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a |
6895 | 1068 |
expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1069 |
|
7036 | 1070 |
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do |
1071 |
e' <- liftM (map toLower . render) $ expr2C e |
|
1072 |
lt <- gets lastType |
|
1073 |
case lt of |
|
10113
b26c2772e754
Fix tons and tons of pas2c warnings (but still not all of them)
unc0rr
parents:
10111
diff
changeset
|
1074 |
BTEnum _-> return $ int 0 |
8020 | 1075 |
BTInt _ -> case e' of |
7036 | 1076 |
"longint" -> return $ int (-2147483648) |
1077 |
BTArray {} -> return $ int 0 |
|
1078 |
_ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt |
|
1079 |
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do |
|
1080 |
e' <- liftM (map toLower . render) $ expr2C e |
|
1081 |
lt <- gets lastType |
|
1082 |
case lt of |
|
1083 |
BTEnum a -> return . int $ length a - 1 |
|
8020 | 1084 |
BTInt _ -> case e' of |
7036 | 1085 |
"longint" -> return $ int (2147483647) |
1086 |
BTString -> return $ int 255 |
|
1087 |
BTArray (RangeFromTo _ n) _ _ -> initExpr2C n |
|
1088 |
_ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt |
|
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1089 |
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
6895 | 1090 |
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
8020 | 1091 |
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do |
1092 |
e'<- expr2C e |
|
1093 |
return $ text "(int)" <> parens e' <> text " - 1" |
|
7062 | 1094 |
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do |
1095 |
e' <- expr2C e |
|
1096 |
lt <- gets lastType |
|
8020 | 1097 |
modify (\s -> s{lastType = BTInt True}) |
7062 | 1098 |
case lt of |
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1099 |
BTString -> return $ text "fpcrtl_Length" <> parens e' |
10120 | 1100 |
BTAString -> return $ text "fpcrtl_LengthA" <> parens e' |
7335 | 1101 |
BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' |
1102 |
BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n]) |
|
7062 | 1103 |
_ -> error $ "length() called on " ++ show lt |
10120 | 1104 |
expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do |
1105 |
e1' <- expr2C e1 |
|
1106 |
e2' <- expr2C e2 |
|
1107 |
e' <- expr2C e |
|
1108 |
lt <- gets lastType |
|
1109 |
let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2']) |
|
1110 |
case lt of |
|
1111 |
BTString -> f "fpcrtl_copy" |
|
1112 |
BTAString -> f "fpcrtl_copyA" |
|
1113 |
_ -> error $ "copy() called on " ++ show lt |
|
13311 | 1114 |
|
6509 | 1115 |
expr2C (BuiltInFunCall params ref) = do |
7315 | 1116 |
r <- ref2C ref |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1117 |
t <- gets lastType |
6509 | 1118 |
ps <- mapM expr2C params |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1119 |
case t of |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1120 |
BTFunction _ _ _ t' -> do |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1121 |
modify (\s -> s{lastType = t'}) |
13311 | 1122 |
_ -> error $ "BuiltInFunCall `" ++ show ref ++ "`, lastType: " ++ show t |
7315 | 1123 |
return $ |
6509 | 1124 |
r <> parens (hsep . punctuate (char ',') $ ps) |
6858 | 1125 |
expr2C a = error $ "Don't know how to render " ++ show a |
6273 | 1126 |
|
8020 | 1127 |
ref2CF :: Reference -> Bool -> State RenderState Doc |
1128 |
ref2CF (SimpleReference name) addParens = do |
|
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1129 |
i <- id2C IOLookup name |
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1130 |
t <- gets lastType |
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1131 |
case t of |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1132 |
BTFunction _ _ _ rt -> do |
7060
861d6897917f
Properly track type in ref2CF, this fixes issues with functions returning strings used in expression (like "a" + line())
unc0rr
parents:
7057
diff
changeset
|
1133 |
modify(\s -> s{lastType = rt}) |
8020 | 1134 |
return $ if addParens then i <> parens empty else i --xymeng: removed parens |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1135 |
_ -> return $ i |
8020 | 1136 |
ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do |
7055 | 1137 |
i <- ref2C r |
1138 |
t <- gets lastType |
|
1139 |
case t of |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1140 |
BTFunction _ _ _ rt -> do |
7060
861d6897917f
Properly track type in ref2CF, this fixes issues with functions returning strings used in expression (like "a" + line())
unc0rr
parents:
7057
diff
changeset
|
1141 |
modify(\s -> s{lastType = rt}) |
10015 | 1142 |
return $ if addParens then i <> parens empty else i |
7055 | 1143 |
_ -> return $ i |
8020 | 1144 |
ref2CF r _ = ref2C r |
6307 | 1145 |
|
6512 | 1146 |
ref2C :: Reference -> State RenderState Doc |
6854
873929cbd54b
Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents:
6853
diff
changeset
|
1147 |
-- rewrite into proper form |
6858 | 1148 |
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
1149 |
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
|
1150 |
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
|
1151 |
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
|
1152 |
ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) |
|
6854
873929cbd54b
Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents:
6853
diff
changeset
|
1153 |
-- conversion routines |
6895 | 1154 |
ref2C ae@(ArrayElement [expr] ref) = do |
1155 |
e <- expr2C expr |
|
7315 | 1156 |
r <- ref2C ref |
6827 | 1157 |
t <- gets lastType |
1158 |
case t of |
|
6893 | 1159 |
(BTArray _ _ t') -> modify (\st -> st{lastType = t'}) |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
1160 |
-- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'}) |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
1161 |
-- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar}) |
10120 | 1162 |
BTString -> modify (\st -> st{lastType = BTChar}) |
1163 |
BTAString -> modify (\st -> st{lastType = BTChar}) |
|
6872 | 1164 |
(BTPointerTo t) -> do |
1165 |
t'' <- fromPointer (show t) =<< gets lastType |
|
1166 |
case t'' of |
|
1167 |
BTChar -> modify (\st -> st{lastType = BTChar}) |
|
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
1168 |
a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae |
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
1169 |
a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae |
6895 | 1170 |
case t of |
1171 |
BTString -> return $ r <> text ".s" <> brackets e |
|
10127 | 1172 |
BTAString -> return $ r <> text ".s" <> brackets e |
6895 | 1173 |
_ -> return $ r <> brackets e |
6663 | 1174 |
ref2C (SimpleReference name) = id2C IOLookup name |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
1175 |
ref2C rf@(RecordField (Dereference ref1) ref2) = do |
7315 | 1176 |
r1 <- ref2C ref1 |
6855
807156c01475
Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents:
6854
diff
changeset
|
1177 |
t <- fromPointer (show ref1) =<< gets lastType |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
1178 |
r2 <- case t of |
7511 | 1179 |
BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2 |
7055 | 1180 |
BTUnit -> error "What??" |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
1181 |
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
7315 | 1182 |
return $ |
6509 | 1183 |
r1 <> text "->" <> r2 |
6618 | 1184 |
ref2C rf@(RecordField ref1 ref2) = do |
1185 |
r1 <- ref2C ref1 |
|
1186 |
t <- gets lastType |
|
7033 | 1187 |
case t of |
7042
de20086a6bcc
Support overloaded operators on (hwFloat op hwFloat) calls
unc0rr
parents:
7040
diff
changeset
|
1188 |
BTRecord _ rs -> do |
7511 | 1189 |
r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2 |
7033 | 1190 |
return $ r1 <> text "." <> r2 |
7055 | 1191 |
BTUnit -> withLastIdNamespace $ ref2C ref2 |
7019
333afe233886
Convert namespace from list into map in preparation for implementation of overloaded functions support. Greatly improve speed of rendering as a side effect (parse + render time reduced from 5:20 to 0:20)
unc0rr
parents:
7002
diff
changeset
|
1192 |
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
6855
807156c01475
Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents:
6854
diff
changeset
|
1193 |
ref2C d@(Dereference ref) = do |
6827 | 1194 |
r <- ref2C ref |
6855
807156c01475
Finish the toughest part of the converter. Now it knows types of everything, so could correctly recognize bitwise operators and type convertions.
unc0rr
parents:
6854
diff
changeset
|
1195 |
t <- fromPointer (show d) =<< gets lastType |
6834 | 1196 |
modify (\st -> st{lastType = t}) |
6859 | 1197 |
return $ (parens $ text "*" <> r) |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1198 |
ref2C f@(FunCall params ref) = do |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
1199 |
r <- fref2C ref |
6826 | 1200 |
t <- gets lastType |
1201 |
case t of |
|
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1202 |
BTFunction _ _ bts t' -> do |
10015 | 1203 |
ps <- liftM (parens . hsep . punctuate (char ',')) $ |
8020 | 1204 |
if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params |
10015 | 1205 |
then |
8020 | 1206 |
mapM expr2CHelper (zip params bts) |
1207 |
else mapM expr2C params |
|
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1208 |
modify (\s -> s{lastType = t'}) |
6826 | 1209 |
return $ r <> ps |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1210 |
_ -> case (ref, params) of |
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1211 |
(SimpleReference i, [p]) -> ref2C $ TypeCast i p |
8020 | 1212 |
_ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t |
7032
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
1213 |
where |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
1214 |
fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
5685ca1ec9bf
Mangle overloaded functions (only different number of parameters is supported)
unc0rr
parents:
7019
diff
changeset
|
1215 |
fref2C a = ref2C a |
8020 | 1216 |
expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1217 |
expr2CHelper (e, (_, BTFunction _ _ _ _)) = do |
8020 | 1218 |
modify (\s -> s{isFunctionType = True}) |
1219 |
expr2C e |
|
1220 |
expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e |
|
7315 | 1221 |
|
6509 | 1222 |
ref2C (Address ref) = do |
1223 |
r <- ref2C ref |
|
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
1224 |
lt <- gets lastType |
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
1225 |
case lt of |
10129
cd2a64a1f4aa
- Pas2C: make use of 'external' function decorator
unc0rr
parents:
10127
diff
changeset
|
1226 |
BTFunction True _ _ _ -> return $ text "&" <> parens r |
7333
520a16a14747
Properly convert taking address of function with var parameters
unc0rr
parents:
7329
diff
changeset
|
1227 |
_ -> return $ text "&" <> parens r |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1228 |
ref2C (TypeCast t'@(Identifier i _) expr) = do |
7151 | 1229 |
lt <- expr2C expr >> gets lastType |
1230 |
case (map toLower i, lt) of |
|
1231 |
("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
|
10120 | 1232 |
("pchar", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pcharA" $ BTPointerTo BTChar)) |
10124
aabd1b75d5a3
Even more explicit type conversions and other stuff to help pas2c use ansistrings
unc0rr
parents:
10121
diff
changeset
|
1233 |
("shortstring", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString)) |
7151 | 1234 |
("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) |
10127 | 1235 |
("ansistring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString)) |
10121 | 1236 |
("ansistring", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString)) |
7151 | 1237 |
(a, _) -> do |
6902
7d4e5ce73b98
Make pas2c even smarter. Now uIO.c compiles fine, and only 1 warning when compiled with -Wall (clang).
unc0rr
parents:
6896
diff
changeset
|
1238 |
e <- expr2C expr |
7315 | 1239 |
t <- id2C IOLookup t' |
7038 | 1240 |
return . parens $ parens t <> e |
6467 | 1241 |
ref2C (RefExpression expr) = expr2C expr |
6355 | 1242 |
|
6509 | 1243 |
|
6860 | 1244 |
op2C :: String -> String |
1245 |
op2C "or" = "|" |
|
1246 |
op2C "and" = "&" |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1247 |
op2C "not" = "~" |
6860 | 1248 |
op2C "xor" = "^" |
1249 |
op2C "div" = "/" |
|
1250 |
op2C "mod" = "%" |
|
1251 |
op2C "shl" = "<<" |
|
1252 |
op2C "shr" = ">>" |
|
1253 |
op2C "<>" = "!=" |
|
1254 |
op2C "=" = "==" |
|
7429
fcf13e40d6b6
Changes to pas2c - unreviewed apart from cursory glance and compile test.
xymeng
parents:
7335
diff
changeset
|
1255 |
op2C "/" = "/(float)" |
6860 | 1256 |
op2C a = a |
6273 | 1257 |