author | unc0rr |
Mon, 26 Mar 2012 23:54:12 +0400 | |
changeset 6827 | a0e152e68337 |
parent 6826 | 8fadeefdd352 |
child 6834 | 2af81d3b176d |
permissions | -rw-r--r-- |
6273 | 1 |
module Pas2C where |
2 |
||
3 |
import Text.PrettyPrint.HughesPJ |
|
4 |
import Data.Maybe |
|
6277 | 5 |
import Data.Char |
6511 | 6 |
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
|
7 |
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
|
8 |
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
|
9 |
import System.Directory |
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 Control.Monad.IO.Class |
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 |
6512 | 15 |
import Data.List (find) |
6273 | 16 |
|
6467 | 17 |
import PascalParser |
18 |
import PascalUnitSyntaxTree |
|
6273 | 19 |
|
6618 | 20 |
|
6663 | 21 |
data InsertOption = |
22 |
IOInsert |
|
23 |
| IOLookup |
|
24 |
| IODeferred |
|
25 |
||
6618 | 26 |
type Record = (String, (String, BaseType)) |
6516 | 27 |
data RenderState = RenderState |
28 |
{ |
|
6618 | 29 |
currentScope :: [Record], |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
30 |
lastIdentifier :: String, |
6618 | 31 |
lastType :: BaseType, |
32 |
namespaces :: Map.Map String [Record] |
|
6516 | 33 |
} |
6512 | 34 |
|
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
|
35 |
pas2C :: String -> IO () |
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
|
36 |
pas2C fn = do |
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
|
37 |
setCurrentDirectory "../hedgewars/" |
6455 | 38 |
s <- flip execStateT initState $ f fn |
6514 | 39 |
renderCFiles s |
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
|
40 |
where |
eae5900fd8a4
Improve parser a bit, preparation to parsing whole program at once and compiling it into single C file
unc0rr
parents:
6399
diff
changeset
|
41 |
printLn = liftIO . hPutStrLn stderr |
6455 | 42 |
print = liftIO . hPutStr stderr |
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
|
43 |
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
|
44 |
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
|
45 |
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
|
46 |
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
|
47 |
unless processed $ do |
6455 | 48 |
print ("Preprocessing '" ++ fileName ++ ".pas'... ") |
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
|
49 |
fc' <- liftIO |
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
|
50 |
$ tryJust (guard . isDoesNotExistError) |
6455 | 51 |
$ preprocess (fileName ++ ".pas") |
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
|
52 |
case fc' of |
6453
11c578d30bd3
Countless imporvements to the parser and countless help to the parser in sources.
unc0rr
parents:
6450
diff
changeset
|
53 |
(Left a) -> do |
6512 | 54 |
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
|
55 |
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
|
56 |
(Right fc) -> do |
6455 | 57 |
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
|
58 |
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
|
59 |
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
|
60 |
(Left a) -> do |
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
|
61 |
liftIO $ writeFile "preprocess.out" 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
|
62 |
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
|
63 |
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
|
64 |
(Right a) -> do |
6455 | 65 |
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
|
66 |
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
|
67 |
mapM_ f (usesFiles a) |
6455 | 68 |
|
6514 | 69 |
|
70 |
renderCFiles :: Map.Map String PascalUnit -> IO () |
|
71 |
renderCFiles units = do |
|
72 |
let u = Map.toList units |
|
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
73 |
let nss = Map.map (toNamespace nss) units |
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
74 |
mapM_ (toCFiles nss) u |
6516 | 75 |
where |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
76 |
toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
77 |
toNamespace nss (System tvs) = |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
78 |
currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] "" BTUnknown nss) |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
79 |
toNamespace _ (Program {}) = [] |
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
80 |
toNamespace nss (Unit _ interface _ _ _) = |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
81 |
currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss) |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
82 |
|
6827 | 83 |
|
84 |
withState' :: (a -> a) -> State a b -> State a b |
|
85 |
withState' f s = do |
|
86 |
st <- gets id |
|
87 |
return $ evalState s (f st) |
|
88 |
||
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
89 |
withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
90 |
withLastIdNamespace f = do |
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
91 |
li <- gets lastIdentifier |
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
92 |
nss <- gets namespaces |
6827 | 93 |
withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
94 |
||
95 |
withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
|
96 |
withRecordNamespace recs = withState' f |
|
97 |
where |
|
98 |
f st = st{currentScope = records ++ currentScope st} |
|
99 |
records = map (\(a, b) -> (map toLower a, (a, b))) recs |
|
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
100 |
|
6618 | 101 |
toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
6516 | 102 |
toCFiles _ (_, System _) = return () |
103 |
toCFiles ns p@(fn, pu) = do |
|
6474
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
104 |
hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
105 |
toCFiles' p |
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
106 |
where |
6618 | 107 |
toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
6474
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
108 |
toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
6618 | 109 |
let (a, s) = runState (interface2C interface) initialState |
6516 | 110 |
writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
111 |
writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
|
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
112 |
initialState = RenderState [] "" BTUnknown ns |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
113 |
|
6516 | 114 |
render2C :: RenderState -> State RenderState Doc -> String |
115 |
render2C a = render . flip evalState a |
|
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
116 |
|
6467 | 117 |
usesFiles :: PascalUnit -> [String] |
6512 | 118 |
usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
119 |
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
|
120 |
usesFiles (System {}) = [] |
|
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
|
121 |
|
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 |
|
6512 | 123 |
pascal2C :: PascalUnit -> State RenderState Doc |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
124 |
pascal2C (Unit _ interface implementation init fin) = |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
125 |
liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
126 |
|
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
127 |
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
|
128 |
impl <- implementation2C implementation |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
129 |
main <- tvar2C True |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
130 |
(FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
131 |
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
|
132 |
|
6467 | 133 |
|
134 |
||
6512 | 135 |
interface2C :: Interface -> State RenderState Doc |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
136 |
interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
6273 | 137 |
|
6512 | 138 |
implementation2C :: Implementation -> State RenderState Doc |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
139 |
implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
6273 | 140 |
|
141 |
||
6512 | 142 |
typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
143 |
typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
6273 | 144 |
|
6816 | 145 |
setBaseType :: BaseType -> Identifier -> Identifier |
146 |
setBaseType bt (Identifier i _) = Identifier i bt |
|
147 |
||
6512 | 148 |
uses2C :: Uses -> State RenderState Doc |
6516 | 149 |
uses2C uses@(Uses unitIds) = do |
150 |
mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
|
6816 | 151 |
mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
6516 | 152 |
return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
153 |
where |
|
6517 | 154 |
injectNamespace (Identifier i _) = do |
6516 | 155 |
getNS <- gets (flip Map.lookup . namespaces) |
156 |
let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
|
157 |
modify (\s -> s{currentScope = f $ 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
|
158 |
|
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
|
159 |
uses2List :: Uses -> [String] |
6489 | 160 |
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
6273 | 161 |
|
6509 | 162 |
|
6663 | 163 |
id2C :: InsertOption -> Identifier -> State RenderState Doc |
164 |
id2C IOInsert (Identifier i t) = do |
|
6618 | 165 |
modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
6512 | 166 |
return $ text i |
6663 | 167 |
id2C IOLookup (Identifier i t) = do |
6512 | 168 |
let i' = map toLower i |
6516 | 169 |
v <- gets $ find (\(a, _) -> a == i') . currentScope |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
170 |
ns <- gets currentScope |
6512 | 171 |
if isNothing v then |
6663 | 172 |
error $ "Not defined: '" ++ i' ++ "'\n" -- ++ show ns |
6512 | 173 |
else |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
174 |
let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
6663 | 175 |
id2C IODeferred (Identifier i t) = do |
176 |
let i' = map toLower i |
|
177 |
v <- gets $ find (\(a, _) -> a == i') . currentScope |
|
178 |
if (isNothing v) then |
|
179 |
do |
|
180 |
modify (\s -> s{currentScope = (i', (i, t)) : currentScope s}) |
|
181 |
return $ text i |
|
182 |
else |
|
183 |
return . text . fst . snd . fromJust $ v |
|
6512 | 184 |
|
6653 | 185 |
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
186 |
id2CTyped t (Identifier i _) = do |
|
187 |
tb <- resolveType t |
|
6663 | 188 |
case tb of |
189 |
BTUnknown -> do |
|
190 |
ns <- gets currentScope |
|
6826 | 191 |
error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " -- ++ show ns |
6663 | 192 |
_ -> id2C IOInsert (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
|
193 |
|
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
194 |
|
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
195 |
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
|
196 |
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
|
197 |
let i' = map toLower i |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
198 |
v <- gets $ find (\(a, _) -> a == i') . currentScope |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
199 |
if isJust v then return . snd . snd $ fromJust v else return $ f i' |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
200 |
where |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
201 |
f "integer" = BTInt |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
202 |
f "pointer" = BTPointerTo BTVoid |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
203 |
f "boolean" = BTBool |
6649
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
204 |
f "float" = BTFloat |
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
205 |
f "char" = BTChar |
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
206 |
f "string" = BTString |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
207 |
f _ = error $ "Unknown system type: " ++ show st |
6827 | 208 |
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) |
209 |
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
|
210 |
resolveType (RecordType tv mtvs) = do |
6827 | 211 |
tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
212 |
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
|
213 |
where |
6827 | 214 |
f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
215 |
f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
|
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
|
216 |
resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
217 |
resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
6826 | 218 |
resolveType (FunctionType t _) = liftM BTFunction $ 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
|
219 |
resolveType (DeriveType _) = return BTInt |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
220 |
resolveType (String _) = return BTString |
6826 | 221 |
resolveType VoidType = return BTVoid |
6653 | 222 |
resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
223 |
resolveType (RangeType _) = return $ BTInt |
|
224 |
resolveType (Set t) = liftM BTSet $ 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
|
225 |
--resolveType UnknownType = return BTUnknown |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
226 |
resolveType a = error $ "resolveType: " ++ show a |
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
227 |
|
6512 | 228 |
|
229 |
tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
|
6509 | 230 |
tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
231 |
t <- type2C returnType |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
232 |
p <- liftM hcat $ mapM (tvar2C False) params |
6663 | 233 |
n <- id2C IOInsert name |
6509 | 234 |
return $ t <+> n <> parens p <> text ";" |
6517 | 235 |
|
6509 | 236 |
tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
237 |
t <- type2C returnType |
6827 | 238 |
(p, ph) <- withState' id $ do |
239 |
p <- liftM hcat $ mapM (tvar2C False) params |
|
240 |
ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
|
241 |
return (p, ph) |
|
6663 | 242 |
n <- id2C IOInsert name |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
243 |
return $ |
6509 | 244 |
t <+> 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
|
245 |
$+$ |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
246 |
text "{" |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
247 |
$+$ |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
248 |
nest 4 ph |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
249 |
$+$ |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
250 |
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
|
251 |
where |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
252 |
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
|
253 |
phrase2C' p = phrase2C p |
6517 | 254 |
|
6489 | 255 |
tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
6618 | 256 |
|
257 |
tvar2C _ td@(TypeDeclaration i' t) = do |
|
6653 | 258 |
i <- id2CTyped t i' |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
259 |
tp <- type2C t |
6516 | 260 |
return $ text "type" <+> i <+> tp <> text ";" |
6517 | 261 |
|
6509 | 262 |
tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
263 |
t' <- type2C t |
|
6653 | 264 |
i <- mapM (id2CTyped t) ids |
6509 | 265 |
ie <- initExpr mInitExpr |
266 |
return $ if isConst then text "const" else empty |
|
267 |
<+> t' |
|
268 |
<+> (hsep . punctuate (char ',') $ i) |
|
269 |
<+> ie |
|
270 |
<> text ";" |
|
6355 | 271 |
where |
6509 | 272 |
initExpr Nothing = return $ empty |
273 |
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
|
6517 | 274 |
|
6474
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
275 |
tvar2C f (OperatorDeclaration op _ ret params body) = |
6618 | 276 |
tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") BTUnknown) ret params body) |
6355 | 277 |
|
6517 | 278 |
|
6512 | 279 |
initExpr2C :: InitExpression -> State RenderState Doc |
6509 | 280 |
initExpr2C (InitBinOp op expr1 expr2) = do |
281 |
e1 <- initExpr2C expr1 |
|
282 |
e2 <- initExpr2C expr2 |
|
283 |
o <- op2C op |
|
284 |
return $ parens $ e1 <+> o <+> e2 |
|
285 |
initExpr2C (InitNumber s) = return $ text s |
|
286 |
initExpr2C (InitFloat s) = return $ text s |
|
287 |
initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
|
288 |
initExpr2C (InitString s) = return $ doubleQuotes $ text s |
|
6663 | 289 |
initExpr2C (InitReference i) = id2C IOLookup i |
6509 | 290 |
initExpr2C _ = return $ text "<<expression>>" |
6391 | 291 |
|
292 |
||
6512 | 293 |
type2C :: TypeDecl -> State RenderState Doc |
6509 | 294 |
type2C UnknownType = return $ text "void" |
295 |
type2C (String l) = return $ text $ "string" ++ show l |
|
6663 | 296 |
type2C (SimpleType i) = id2C IOLookup i |
297 |
type2C (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
|
6509 | 298 |
type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
299 |
type2C (RecordType tvs union) = do |
|
300 |
t <- mapM (tvar2C False) tvs |
|
301 |
return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
|
302 |
type2C (RangeType r) = return $ text "<<range type>>" |
|
6520 | 303 |
type2C (Sequence ids) = do |
6663 | 304 |
mapM_ (id2C IOInsert) ids |
6520 | 305 |
return $ text "<<sequence type>>" |
6509 | 306 |
type2C (ArrayDecl r t) = return $ text "<<array type>>" |
307 |
type2C (Set t) = return $ text "<<set>>" |
|
308 |
type2C (FunctionType returnType params) = return $ text "<<function>>" |
|
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
|
309 |
type2C (DeriveType _) = return $ text "<<type derived from constant literal>>" |
6273 | 310 |
|
6512 | 311 |
phrase2C :: Phrase -> State RenderState Doc |
6509 | 312 |
phrase2C (Phrases p) = do |
313 |
ps <- mapM phrase2C p |
|
314 |
return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
|
315 |
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
|
316 |
phrase2C (ProcCall ref params) = do |
|
317 |
r <- ref2C ref |
|
318 |
ps <- mapM expr2C params |
|
319 |
return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi |
|
320 |
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
|
321 |
e <- expr2C expr |
|
322 |
p1 <- (phrase2C . wrapPhrase) phrase1 |
|
323 |
el <- elsePart |
|
324 |
return $ |
|
325 |
text "if" <> parens e $+$ p1 $+$ el |
|
6273 | 326 |
where |
6509 | 327 |
elsePart | isNothing mphrase2 = return $ empty |
328 |
| otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
|
329 |
phrase2C (Assignment ref expr) = do |
|
330 |
r <- ref2C ref |
|
331 |
e <- expr2C expr |
|
332 |
return $ |
|
333 |
r <> text " = " <> e <> semi |
|
334 |
phrase2C (WhileCycle expr phrase) = do |
|
335 |
e <- expr2C expr |
|
336 |
p <- phrase2C $ wrapPhrase phrase |
|
337 |
return $ text "while" <> parens e $$ p |
|
338 |
phrase2C (SwitchCase expr cases mphrase) = do |
|
339 |
e <- expr2C expr |
|
340 |
cs <- mapM case2C cases |
|
341 |
return $ |
|
342 |
text "switch" <> parens e <> text "of" $+$ (nest 4 . vcat) cs |
|
6273 | 343 |
where |
6512 | 344 |
case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
6509 | 345 |
case2C (e, p) = do |
346 |
ie <- mapM initExpr2C e |
|
347 |
ph <- phrase2C p |
|
348 |
return $ |
|
349 |
text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
|
350 |
phrase2C (WithBlock ref p) = do |
|
351 |
r <- ref2C ref |
|
352 |
ph <- phrase2C $ wrapPhrase p |
|
353 |
return $ text "namespace" <> parens r $$ ph |
|
354 |
phrase2C (ForCycle i' e1' e2' p) = do |
|
6663 | 355 |
i <- id2C IOLookup i' |
6509 | 356 |
e1 <- expr2C e1' |
357 |
e2 <- expr2C e2' |
|
358 |
ph <- phrase2C (wrapPhrase p) |
|
359 |
return $ |
|
360 |
text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
|
361 |
$$ |
|
362 |
ph |
|
363 |
phrase2C (RepeatCycle e' p') = do |
|
364 |
e <- expr2C e' |
|
365 |
p <- phrase2C (Phrases p') |
|
366 |
return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) |
|
367 |
phrase2C NOP = return $ text ";" |
|
6355 | 368 |
|
6273 | 369 |
|
6307 | 370 |
wrapPhrase p@(Phrases _) = p |
371 |
wrapPhrase p = Phrases [p] |
|
6273 | 372 |
|
6355 | 373 |
|
6512 | 374 |
expr2C :: Expression -> State RenderState Doc |
6509 | 375 |
expr2C (Expression s) = return $ text s |
376 |
expr2C (BinOp op expr1 expr2) = do |
|
377 |
e1 <- expr2C expr1 |
|
378 |
e2 <- expr2C expr2 |
|
379 |
o <- op2C op |
|
380 |
return $ parens $ e1 <+> o <+> e2 |
|
381 |
expr2C (NumberLiteral s) = return $ text s |
|
382 |
expr2C (FloatLiteral s) = return $ text s |
|
383 |
expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
|
384 |
expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
|
6277 | 385 |
expr2C (Reference ref) = ref2C ref |
6509 | 386 |
expr2C (PrefixOp op expr) = liftM2 (<+>) (op2C op) (expr2C expr) |
387 |
expr2C Null = return $ text "NULL" |
|
388 |
expr2C (BuiltInFunCall params ref) = do |
|
389 |
r <- ref2C ref |
|
390 |
ps <- mapM expr2C params |
|
391 |
return $ |
|
392 |
r <> parens (hsep . punctuate (char ',') $ ps) |
|
393 |
expr2C _ = return $ text "<<expression>>" |
|
6273 | 394 |
|
6307 | 395 |
|
6512 | 396 |
ref2C :: Reference -> State RenderState Doc |
6827 | 397 |
ref2C ae@(ArrayElement exprs ref) = do |
6509 | 398 |
r <- ref2C ref |
6827 | 399 |
t <- gets lastType |
400 |
case t of |
|
401 |
(BTArray _ t') -> modify (\st -> st{lastType = t'}) |
|
402 |
a -> error $ show a ++ "\n" ++ show ae |
|
6509 | 403 |
es <- mapM expr2C exprs |
404 |
return $ r <> (brackets . hcat) (punctuate comma es) |
|
6663 | 405 |
ref2C (SimpleReference name) = id2C IOLookup name |
6509 | 406 |
ref2C (RecordField (Dereference ref1) ref2) = do |
407 |
r1 <- ref2C ref1 |
|
408 |
r2 <- ref2C ref2 |
|
409 |
return $ |
|
410 |
r1 <> text "->" <> r2 |
|
6618 | 411 |
ref2C rf@(RecordField ref1 ref2) = do |
412 |
r1 <- ref2C ref1 |
|
413 |
t <- gets lastType |
|
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
414 |
r2 <- case t of |
6827 | 415 |
BTRecord rs -> withRecordNamespace rs $ ref2C ref2 |
6826 | 416 |
BTUnit -> withLastIdNamespace $ ref2C ref2 |
6618 | 417 |
a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
6509 | 418 |
return $ |
419 |
r1 <> text "." <> r2 |
|
6827 | 420 |
ref2C (Dereference ref) = do |
421 |
r <- ref2C ref |
|
422 |
t <- gets lastType |
|
423 |
case t of |
|
424 |
(BTPointerTo t') -> modify (\st -> st{lastType = t'}) |
|
425 |
a -> error $ "Dereferencing from non-pointer type " ++ show a |
|
426 |
return $ (parens $ text "*") <> r |
|
6509 | 427 |
ref2C (FunCall params ref) = do |
6826 | 428 |
ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
6509 | 429 |
r <- ref2C ref |
6826 | 430 |
t <- gets lastType |
431 |
case t of |
|
432 |
BTFunction t -> do |
|
433 |
modify (\s -> s{lastType = t}) |
|
434 |
return $ r <> ps |
|
435 |
_ -> return $ parens r <> ps |
|
436 |
||
6509 | 437 |
ref2C (Address ref) = do |
438 |
r <- ref2C ref |
|
439 |
return $ text "&" <> parens r |
|
440 |
ref2C (TypeCast t' expr) = do |
|
6663 | 441 |
t <- id2C IOLookup t' |
6509 | 442 |
e <- expr2C expr |
443 |
return $ parens t <> e |
|
6467 | 444 |
ref2C (RefExpression expr) = expr2C expr |
6355 | 445 |
|
6509 | 446 |
|
6512 | 447 |
op2C :: String -> State RenderState Doc |
6509 | 448 |
op2C "or" = return $ text "|" |
449 |
op2C "and" = return $ text "&" |
|
450 |
op2C "not" = return $ text "!" |
|
451 |
op2C "xor" = return $ text "^" |
|
452 |
op2C "div" = return $ text "/" |
|
453 |
op2C "mod" = return $ text "%" |
|
454 |
op2C "shl" = return $ text "<<" |
|
455 |
op2C "shr" = return $ text ">>" |
|
456 |
op2C "<>" = return $ text "!=" |
|
457 |
op2C "=" = return $ text "==" |
|
458 |
op2C a = return $ text a |
|
6273 | 459 |
|
460 |
maybeVoid "" = "void" |
|
461 |
maybeVoid a = a |