author | koda |
Fri, 13 Apr 2012 00:18:10 +0200 | |
changeset 6884 | 85e810230372 |
parent 6883 | 70aec33185e2 |
child 6886 | 4463ee51c9ec |
permissions | -rw-r--r-- |
6858 | 1 |
{-# LANGUAGE ScopedTypeVariables #-} |
6273 | 2 |
module Pas2C where |
3 |
||
4 |
import Text.PrettyPrint.HughesPJ |
|
5 |
import Data.Maybe |
|
6277 | 6 |
import Data.Char |
6511 | 7 |
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
|
8 |
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
|
9 |
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
|
10 |
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
|
11 |
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
|
12 |
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
|
13 |
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
|
14 |
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
|
15 |
import qualified Data.Map as Map |
6512 | 16 |
import Data.List (find) |
6858 | 17 |
import Numeric |
6273 | 18 |
|
6467 | 19 |
import PascalParser |
20 |
import PascalUnitSyntaxTree |
|
6273 | 21 |
|
6618 | 22 |
|
6663 | 23 |
data InsertOption = |
24 |
IOInsert |
|
25 |
| IOLookup |
|
26 |
| IODeferred |
|
27 |
||
6618 | 28 |
type Record = (String, (String, BaseType)) |
6516 | 29 |
data RenderState = RenderState |
30 |
{ |
|
6618 | 31 |
currentScope :: [Record], |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
32 |
lastIdentifier :: String, |
6618 | 33 |
lastType :: BaseType, |
34 |
namespaces :: Map.Map String [Record] |
|
6516 | 35 |
} |
6836 | 36 |
|
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
37 |
emptyState = RenderState [] "" BTUnknown |
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
38 |
|
6836 | 39 |
docToLower :: Doc -> Doc |
40 |
docToLower = text . map toLower . render |
|
6512 | 41 |
|
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
|
42 |
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
|
43 |
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
|
44 |
setCurrentDirectory "../hedgewars/" |
6455 | 45 |
s <- flip execStateT initState $ f fn |
6514 | 46 |
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
|
47 |
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
|
48 |
printLn = liftIO . hPutStrLn stderr |
6455 | 49 |
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
|
50 |
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
|
51 |
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
|
52 |
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
|
53 |
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
|
54 |
unless processed $ do |
6455 | 55 |
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
|
56 |
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
|
57 |
$ tryJust (guard . isDoesNotExistError) |
6455 | 58 |
$ 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
|
59 |
case fc' of |
6453
11c578d30bd3
Countless imporvements to the parser and countless help to the parser in sources.
unc0rr
parents:
6450
diff
changeset
|
60 |
(Left a) -> do |
6512 | 61 |
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
|
62 |
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
|
63 |
(Right fc) -> do |
6455 | 64 |
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
|
65 |
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
|
66 |
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
|
67 |
(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
|
68 |
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
|
69 |
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
|
70 |
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
|
71 |
(Right a) -> do |
6455 | 72 |
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
|
73 |
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
|
74 |
mapM_ f (usesFiles a) |
6455 | 75 |
|
6514 | 76 |
|
77 |
renderCFiles :: Map.Map String PascalUnit -> IO () |
|
78 |
renderCFiles units = do |
|
79 |
let u = Map.toList units |
|
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
80 |
let nss = Map.map (toNamespace nss) units |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
81 |
hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss) |
6853 | 82 |
--writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
83 |
mapM_ (toCFiles nss) u |
6516 | 84 |
where |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
85 |
toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
86 |
toNamespace nss (System tvs) = |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
87 |
currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
88 |
toNamespace _ (Program {}) = [] |
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
89 |
toNamespace nss (Unit _ interface _ _ _) = |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
90 |
currentScope $ execState (interface2C interface) (emptyState nss) |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
91 |
|
6827 | 92 |
|
6853 | 93 |
withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
94 |
withState' f sf = do |
|
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
95 |
st <- liftM f get |
6853 | 96 |
let (a, s) = runState sf st |
97 |
modify(\st -> st{lastType = lastType s}) |
|
98 |
return a |
|
6827 | 99 |
|
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
100 |
withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
101 |
withLastIdNamespace f = do |
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
102 |
li <- gets lastIdentifier |
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
103 |
nss <- gets namespaces |
6827 | 104 |
withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
105 |
||
6859 | 106 |
withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
107 |
withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
|
108 |
withRecordNamespace prefix recs = withState' f |
|
6827 | 109 |
where |
110 |
f st = st{currentScope = records ++ currentScope st} |
|
6859 | 111 |
records = map (\(a, b) -> (map toLower a, (prefix ++ a, b))) recs |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
112 |
|
6618 | 113 |
toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
6516 | 114 |
toCFiles _ (_, System _) = return () |
115 |
toCFiles ns p@(fn, pu) = do |
|
6474
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
116 |
hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
117 |
toCFiles' p |
42e9773eedfd
- Improve renderer a bit, disallow nested functions
unc0rr
parents:
6467
diff
changeset
|
118 |
where |
6618 | 119 |
toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
6854
873929cbd54b
Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents:
6853
diff
changeset
|
120 |
toCFiles' (fn, (Unit unitId interface implementation _ _)) = do |
873929cbd54b
Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents:
6853
diff
changeset
|
121 |
let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState |
6883 | 122 |
writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
123 |
writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
|
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
124 |
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
|
125 |
|
6516 | 126 |
render2C :: RenderState -> State RenderState Doc -> String |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
127 |
render2C a = render . ($+$ text "") . 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
|
128 |
|
6467 | 129 |
usesFiles :: PascalUnit -> [String] |
6512 | 130 |
usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
131 |
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
|
132 |
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
|
133 |
|
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
|
134 |
|
6512 | 135 |
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
|
136 |
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
|
137 |
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
|
138 |
|
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
139 |
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
|
140 |
impl <- implementation2C implementation |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
141 |
[main] <- tvar2C True |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
142 |
(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
|
143 |
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
|
144 |
|
6467 | 145 |
|
146 |
||
6512 | 147 |
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
|
148 |
interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
6273 | 149 |
|
6512 | 150 |
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
|
151 |
implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
6273 | 152 |
|
153 |
||
6512 | 154 |
typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
155 |
typesAndVars2C b (TypesAndVars ts) = liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts |
6273 | 156 |
|
6816 | 157 |
setBaseType :: BaseType -> Identifier -> Identifier |
158 |
setBaseType bt (Identifier i _) = Identifier i bt |
|
159 |
||
6512 | 160 |
uses2C :: Uses -> State RenderState Doc |
6516 | 161 |
uses2C uses@(Uses unitIds) = do |
162 |
mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
|
6816 | 163 |
mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
6516 | 164 |
return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
165 |
where |
|
6517 | 166 |
injectNamespace (Identifier i _) = do |
6516 | 167 |
getNS <- gets (flip Map.lookup . namespaces) |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
168 |
let f = flip (foldl (flip (:))) (fromMaybe [] (getNS i)) |
6516 | 169 |
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
|
170 |
|
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
|
171 |
uses2List :: Uses -> [String] |
6489 | 172 |
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
6273 | 173 |
|
6509 | 174 |
|
6663 | 175 |
id2C :: InsertOption -> Identifier -> State RenderState Doc |
176 |
id2C IOInsert (Identifier i t) = do |
|
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
177 |
ns <- gets currentScope |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
178 |
{-- case t of |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
179 |
BTUnknown -> do |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
180 |
ns <- gets currentScope |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
181 |
error $ "id2C IOInsert: type BTUnknown for " ++ show i ++ "\nnamespace: " ++ show (take 100 ns) |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
182 |
_ -> do --} |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
183 |
modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n}) |
6512 | 184 |
return $ text i |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
185 |
where |
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
186 |
n = map toLower i |
6663 | 187 |
id2C IOLookup (Identifier i t) = do |
6512 | 188 |
let i' = map toLower i |
6516 | 189 |
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
|
190 |
ns <- gets currentScope |
6853 | 191 |
lt <- gets lastType |
6512 | 192 |
if isNothing v then |
6853 | 193 |
error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\n" ++ show (take 100 ns) |
6512 | 194 |
else |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
195 |
let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
6663 | 196 |
id2C IODeferred (Identifier i t) = do |
197 |
let i' = map toLower i |
|
198 |
v <- gets $ find (\(a, _) -> a == i') . currentScope |
|
199 |
if (isNothing v) then |
|
200 |
return $ text i |
|
201 |
else |
|
202 |
return . text . fst . snd . fromJust $ v |
|
6512 | 203 |
|
6653 | 204 |
id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
205 |
id2CTyped t (Identifier i _) = do |
|
206 |
tb <- resolveType t |
|
6835 | 207 |
ns <- gets currentScope |
6663 | 208 |
case tb of |
209 |
BTUnknown -> do |
|
210 |
ns <- gets currentScope |
|
6835 | 211 |
error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show (take 100 ns) |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
212 |
_ -> return () |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
213 |
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
|
214 |
|
a447993f2ad7
Further work on propagating types. Now it hopefully works fully, just need to annotate namespace with types first.
unc0rr
parents:
6618
diff
changeset
|
215 |
|
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 :: 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
|
217 |
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
|
218 |
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
|
219 |
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
|
220 |
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
|
221 |
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
|
222 |
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
|
223 |
f "pointer" = BTPointerTo BTVoid |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
224 |
f "boolean" = BTBool |
6649
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
225 |
f "float" = BTFloat |
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
226 |
f "char" = BTChar |
7f78e8a6db69
Fix a bug with type declaration trying to resolve type being declared
unc0rr
parents:
6635
diff
changeset
|
227 |
f "string" = BTString |
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
228 |
f _ = error $ "Unknown system type: " ++ show st |
6827 | 229 |
resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) |
230 |
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
|
231 |
resolveType (RecordType tv mtvs) = do |
6827 | 232 |
tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
233 |
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
|
234 |
where |
6827 | 235 |
f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
236 |
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
|
237 |
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
|
238 |
resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
6826 | 239 |
resolveType (FunctionType t _) = liftM BTFunction $ resolveType t |
6835 | 240 |
resolveType (DeriveType (InitHexNumber _)) = return BTInt |
241 |
resolveType (DeriveType (InitNumber _)) = return BTInt |
|
242 |
resolveType (DeriveType (InitFloat _)) = return BTFloat |
|
243 |
resolveType (DeriveType (InitString _)) = return BTString |
|
244 |
resolveType (DeriveType (InitBinOp {})) = return BTInt |
|
245 |
resolveType (DeriveType (InitPrefixOp {})) = return BTInt |
|
246 |
resolveType (DeriveType (BuiltInFunction{})) = return BTInt |
|
247 |
resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
|
248 |
resolveType (DeriveType _) = return BTUnknown |
|
6635
c2fa29fe2a58
Some progress, still can't find the source of bad behavior
unc0rr
parents:
6626
diff
changeset
|
249 |
resolveType (String _) = return BTString |
6826 | 250 |
resolveType VoidType = return BTVoid |
6653 | 251 |
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
|
252 |
resolveType (RangeType _) = return $ BTVoid |
6653 | 253 |
resolveType (Set t) = liftM BTSet $ resolveType t |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
254 |
|
6834 | 255 |
|
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
|
256 |
fromPointer :: String -> BaseType -> State RenderState BaseType |
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
|
257 |
fromPointer s (BTPointerTo t) = f t |
6834 | 258 |
where |
259 |
f (BTUnresolved s) = do |
|
260 |
v <- gets $ find (\(a, _) -> a == s) . currentScope |
|
261 |
if isJust v then |
|
262 |
f . snd . snd . fromJust $ v |
|
263 |
else |
|
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
|
264 |
error $ "Unknown type " ++ show t ++ "\n" ++ s |
6834 | 265 |
f t = return 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
|
266 |
fromPointer s t = do |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
267 |
ns <- gets currentScope |
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
|
268 |
error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s ++ "\n\n" ++ show (take 100 ns) |
6834 | 269 |
|
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
270 |
|
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
271 |
functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params |
6834 | 272 |
|
6880 | 273 |
fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
274 |
fun2C _ _ (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
|
275 |
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
|
276 |
t'<- gets lastType |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
277 |
p <- withState' id $ functionParams2C params |
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
|
278 |
n <- id2C IOInsert $ setBaseType (BTFunction t') name |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
279 |
return [t empty <+> n <> parens p] |
6517 | 280 |
|
6880 | 281 |
fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
282 |
let res = docToLower $ text rv <> text "_result" |
|
6836 | 283 |
t <- type2C returnType |
6837
a137733c5776
Much better types handling, work correctly with functions
unc0rr
parents:
6836
diff
changeset
|
284 |
t'<- gets lastType |
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
|
285 |
n <- id2C IOInsert $ setBaseType (BTFunction t') name |
6880 | 286 |
(p, ph) <- withState' (\st -> st{currentScope = (map toLower rv, (render res, t')) : currentScope st}) $ do |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
287 |
p <- functionParams2C params |
6827 | 288 |
ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
289 |
return (p, ph) |
|
6836 | 290 |
let phrasesBlock = case returnType of |
291 |
VoidType -> ph |
|
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
292 |
_ -> t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
293 |
return [ |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
294 |
t empty <+> 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
|
295 |
$+$ |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
296 |
text "{" |
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
297 |
$+$ |
6836 | 298 |
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
|
299 |
$+$ |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
300 |
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
|
301 |
where |
6499
33180b479efa
Start converting into monadic code using Reader monad (will be used to store information about namespace)
unc0rr
parents:
6489
diff
changeset
|
302 |
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
|
303 |
phrase2C' p = phrase2C p |
6517 | 304 |
|
6880 | 305 |
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
306 |
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
|
6618 | 307 |
|
6880 | 308 |
tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
309 |
tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) = |
|
310 |
fun2C b name f |
|
6618 | 311 |
tvar2C _ td@(TypeDeclaration i' t) = do |
6653 | 312 |
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
|
313 |
tp <- type2C t |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
314 |
return [text "typedef" <+> tp i] |
6517 | 315 |
|
6509 | 316 |
tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
317 |
t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t |
6509 | 318 |
ie <- initExpr mInitExpr |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
319 |
liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids |
6355 | 320 |
where |
6509 | 321 |
initExpr Nothing = return $ empty |
322 |
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
|
6517 | 323 |
|
6880 | 324 |
tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do |
325 |
r <- op2CTyped op (extractTypes params) |
|
326 |
fun2C f i (FunctionDeclaration r ret params body) |
|
6355 | 327 |
|
6517 | 328 |
|
6880 | 329 |
op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
330 |
op2CTyped op t = do |
|
331 |
t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t |
|
332 |
bt <- gets lastType |
|
333 |
return $ case bt of |
|
334 |
BTRecord {} -> Identifier (t' ++ "_op_" ++ opStr) bt |
|
335 |
_ -> Identifier t' bt |
|
336 |
where |
|
337 |
opStr = case op of |
|
338 |
"+" -> "add" |
|
339 |
"-" -> "sub" |
|
340 |
"*" -> "mul" |
|
341 |
"/" -> "div" |
|
342 |
"=" -> "eq" |
|
343 |
"<" -> "lt" |
|
344 |
">" -> "gt" |
|
345 |
_ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" |
|
346 |
||
347 |
extractTypes :: [TypeVarDeclaration] -> [TypeDecl] |
|
348 |
extractTypes = concatMap f |
|
349 |
where |
|
350 |
f (VarDeclaration _ (ids, t) _) = replicate (length ids) t |
|
351 |
f a = error $ "extractTypes: can't extract from " ++ show a |
|
352 |
||
6512 | 353 |
initExpr2C :: InitExpression -> State RenderState Doc |
6858 | 354 |
initExpr2C InitNull = return $ text "NULL" |
355 |
initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr) |
|
6860 | 356 |
initExpr2C (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C expr) |
6509 | 357 |
initExpr2C (InitBinOp op expr1 expr2) = do |
358 |
e1 <- initExpr2C expr1 |
|
359 |
e2 <- initExpr2C expr2 |
|
6860 | 360 |
return $ parens $ e1 <+> text (op2C op) <+> e2 |
6509 | 361 |
initExpr2C (InitNumber s) = return $ text s |
362 |
initExpr2C (InitFloat s) = return $ text s |
|
363 |
initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
|
6874 | 364 |
initExpr2C (InitString [a]) = return . quotes $ text [a] |
6883 | 365 |
initExpr2C (InitString s) = return $ braces $ text ".s = " <> doubleQuotes (text s) |
6858 | 366 |
initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
6663 | 367 |
initExpr2C (InitReference i) = id2C IOLookup i |
6858 | 368 |
initExpr2C (InitRecord fields) = do |
369 |
(fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
|
370 |
return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace |
|
6859 | 371 |
initExpr2C (InitArray [value]) = initExpr2C value |
6858 | 372 |
initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
6872 | 373 |
initExpr2C (InitRange (Range i)) = id2C IOLookup i |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
374 |
initExpr2C (InitRange (RangeFromTo (InitNumber "0") (InitNumber a))) = return . text $ show (read a + 1) |
6872 | 375 |
initExpr2C (InitRange a) = return $ text "<<range>>" |
376 |
initExpr2C (InitSet []) = return $ text "0" |
|
377 |
initExpr2C (InitSet a) = return $ text "<<set>>" |
|
6858 | 378 |
initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>" |
6874 | 379 |
initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a |
6391 | 380 |
|
6874 | 381 |
range2C :: InitExpression -> State RenderState [Doc] |
382 |
range2C (InitString [a]) = return [quotes $ text [a]] |
|
383 |
range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i |
|
384 |
range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b] |
|
385 |
||
386 |
range2C a = liftM (flip (:) []) $ initExpr2C a |
|
6391 | 387 |
|
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
388 |
type2C :: TypeDecl -> State RenderState (Doc -> Doc) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
389 |
type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i |
6838 | 390 |
type2C t = do |
391 |
r <- type2C' t |
|
392 |
rt <- resolveType t |
|
393 |
modify (\st -> st{lastType = rt}) |
|
394 |
return r |
|
395 |
where |
|
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
396 |
type2C' VoidType = return (text "void" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
397 |
type2C' (String l) = return (text ("string" ++ show l) <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
398 |
type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct" <+> i <+> text "*" <+> a) $ id2C IODeferred i |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
399 |
type2C' (PointerTo t) = liftM (\t a -> t (text "*" <> a)) $ type2C t |
6838 | 400 |
type2C' (RecordType tvs union) = do |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
401 |
t <- withState' id $ mapM (tvar2C False) tvs |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
402 |
return $ \i -> text "struct" <+> lbrace $+$ (nest 4 . vcat . map (<> semi) . concat $ t) $+$ rbrace <+> i |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
403 |
type2C' (RangeType r) = return (text "<<range type>>" <+>) |
6838 | 404 |
type2C' (Sequence ids) = do |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
405 |
is <- mapM (id2C IOInsert . setBaseType bt) ids |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
406 |
return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is (iterate (*2) 1)) <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
407 |
where |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
408 |
bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
409 |
type2C' (ArrayDecl Nothing t) = do |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
410 |
t' <- type2C t |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
411 |
return $ \i -> t' i <> brackets empty |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
412 |
type2C' (ArrayDecl (Just r) t) = do |
6858 | 413 |
t' <- type2C t |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
414 |
r' <- initExpr2C (InitRange r) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
415 |
return $ \i -> t' i <> brackets r' |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
416 |
type2C' (Set t) = return (text "<<set>>" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
417 |
type2C' (FunctionType returnType params) = do |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
418 |
t <- type2C returnType |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
419 |
p <- withState' id $ functionParams2C params |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
420 |
return (\i -> t empty <+> i <> parens p) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
421 |
type2C' (DeriveType (InitBinOp {})) = return (text "int" <+>) |
6858 | 422 |
type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) |
6878
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
423 |
type2C' (DeriveType (InitNumber _)) = return (text "int" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
424 |
type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
425 |
type2C' (DeriveType (InitFloat _)) = return (text "float" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
426 |
type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
427 |
type2C' (DeriveType (InitString {})) = return (text "string255" <+>) |
0af34406b83d
Improve rendering of function types, arrays, and more
unc0rr
parents:
6875
diff
changeset
|
428 |
type2C' (DeriveType (InitReference {})) = return (text "<<some type>>" <+>) |
6858 | 429 |
type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a |
6273 | 430 |
|
6512 | 431 |
phrase2C :: Phrase -> State RenderState Doc |
6509 | 432 |
phrase2C (Phrases p) = do |
433 |
ps <- mapM phrase2C p |
|
434 |
return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
|
435 |
phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
|
436 |
phrase2C (ProcCall ref params) = do |
|
437 |
r <- ref2C ref |
|
438 |
ps <- mapM expr2C params |
|
439 |
return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi |
|
440 |
phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
|
441 |
e <- expr2C expr |
|
442 |
p1 <- (phrase2C . wrapPhrase) phrase1 |
|
443 |
el <- elsePart |
|
444 |
return $ |
|
445 |
text "if" <> parens e $+$ p1 $+$ el |
|
6273 | 446 |
where |
6509 | 447 |
elsePart | isNothing mphrase2 = return $ empty |
448 |
| otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
|
449 |
phrase2C (Assignment ref expr) = do |
|
450 |
r <- ref2C ref |
|
451 |
e <- expr2C expr |
|
452 |
return $ |
|
453 |
r <> text " = " <> e <> semi |
|
454 |
phrase2C (WhileCycle expr phrase) = do |
|
455 |
e <- expr2C expr |
|
456 |
p <- phrase2C $ wrapPhrase phrase |
|
457 |
return $ text "while" <> parens e $$ p |
|
458 |
phrase2C (SwitchCase expr cases mphrase) = do |
|
459 |
e <- expr2C expr |
|
460 |
cs <- mapM case2C cases |
|
6874 | 461 |
d <- dflt |
6509 | 462 |
return $ |
6874 | 463 |
text "switch" <> parens e <> text "of" $+$ braces (nest 4 . vcat $ cs ++ d) |
6273 | 464 |
where |
6512 | 465 |
case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
6509 | 466 |
case2C (e, p) = do |
6874 | 467 |
ies <- mapM range2C e |
6509 | 468 |
ph <- phrase2C p |
469 |
return $ |
|
6874 | 470 |
vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") |
471 |
dflt | isNothing mphrase = return [] |
|
472 |
| otherwise = do |
|
473 |
ph <- mapM phrase2C $ fromJust mphrase |
|
474 |
return [text "default:" <+> nest 4 (vcat ph)] |
|
475 |
||
6845 | 476 |
phrase2C wb@(WithBlock ref p) = do |
6509 | 477 |
r <- ref2C ref |
6845 | 478 |
t <- gets lastType |
479 |
case t of |
|
6859 | 480 |
(BTRecord rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
6845 | 481 |
a -> do |
482 |
ns <- gets currentScope |
|
483 |
error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb ++ "\nnamespace: " ++ show (take 100 ns) |
|
6509 | 484 |
phrase2C (ForCycle i' e1' e2' p) = do |
6663 | 485 |
i <- id2C IOLookup i' |
6509 | 486 |
e1 <- expr2C e1' |
487 |
e2 <- expr2C e2' |
|
488 |
ph <- phrase2C (wrapPhrase p) |
|
489 |
return $ |
|
490 |
text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
|
491 |
$$ |
|
492 |
ph |
|
493 |
phrase2C (RepeatCycle e' p') = do |
|
494 |
e <- expr2C e' |
|
495 |
p <- phrase2C (Phrases p') |
|
496 |
return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) |
|
497 |
phrase2C NOP = return $ text ";" |
|
6355 | 498 |
|
6273 | 499 |
|
6307 | 500 |
wrapPhrase p@(Phrases _) = p |
501 |
wrapPhrase p = Phrases [p] |
|
6273 | 502 |
|
6512 | 503 |
expr2C :: Expression -> State RenderState Doc |
6509 | 504 |
expr2C (Expression s) = return $ text s |
505 |
expr2C (BinOp op expr1 expr2) = do |
|
506 |
e1 <- expr2C expr1 |
|
6860 | 507 |
t1 <- gets lastType |
6509 | 508 |
e2 <- expr2C expr2 |
6860 | 509 |
case (op2C op, t1) of |
510 |
("+", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString)) |
|
6872 | 511 |
("==", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
512 |
("!=", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
|
6860 | 513 |
("&", BTBool) -> return $ parens $ e1 <+> text "&&" <+> e2 |
514 |
("|", BTBool) -> return $ parens $ e1 <+> text "||" <+> e2 |
|
515 |
(o, _) -> return $ parens $ e1 <+> text o <+> e2 |
|
6509 | 516 |
expr2C (NumberLiteral s) = return $ text s |
517 |
expr2C (FloatLiteral s) = return $ text s |
|
518 |
expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
|
6874 | 519 |
expr2C (StringLiteral [a]) = return . quotes $ text [a] |
6509 | 520 |
expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
6277 | 521 |
expr2C (Reference ref) = ref2C ref |
6860 | 522 |
expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
6509 | 523 |
expr2C Null = return $ text "NULL" |
524 |
expr2C (BuiltInFunCall params ref) = do |
|
525 |
r <- ref2C ref |
|
526 |
ps <- mapM expr2C params |
|
527 |
return $ |
|
528 |
r <> parens (hsep . punctuate (char ',') $ ps) |
|
6858 | 529 |
expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
530 |
expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
|
531 |
expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
|
532 |
expr2C a = error $ "Don't know how to render " ++ show a |
|
6273 | 533 |
|
6307 | 534 |
|
6512 | 535 |
ref2C :: Reference -> State RenderState Doc |
6854
873929cbd54b
Normalize RecordFields before conversion. Helps with namespaces problem.
unc0rr
parents:
6853
diff
changeset
|
536 |
-- rewrite into proper form |
6858 | 537 |
ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
538 |
ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
|
539 |
ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
|
540 |
ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
|
541 |
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
|
542 |
-- conversion routines |
6827 | 543 |
ref2C ae@(ArrayElement exprs ref) = do |
6835 | 544 |
es <- mapM expr2C exprs |
6509 | 545 |
r <- ref2C ref |
6827 | 546 |
t <- gets lastType |
6838 | 547 |
ns <- gets currentScope |
6827 | 548 |
case t of |
549 |
(BTArray _ t') -> modify (\st -> st{lastType = t'}) |
|
6836 | 550 |
(BTString) -> modify (\st -> st{lastType = BTChar}) |
6872 | 551 |
(BTPointerTo t) -> do |
552 |
t'' <- fromPointer (show t) =<< gets lastType |
|
553 |
case t'' of |
|
554 |
BTChar -> modify (\st -> st{lastType = BTChar}) |
|
555 |
a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
|
6838 | 556 |
a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
6509 | 557 |
return $ r <> (brackets . hcat) (punctuate comma es) |
6663 | 558 |
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
|
559 |
ref2C rf@(RecordField (Dereference ref1) ref2) = do |
6509 | 560 |
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
|
561 |
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
|
562 |
ns <- gets currentScope |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
563 |
r2 <- case t of |
6859 | 564 |
BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
6843
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
565 |
BTUnit -> withLastIdNamespace $ ref2C ref2 |
59da15acb2f2
Finally fix the bug with pointer declarations polluting namespace with bad records
unc0rr
parents:
6838
diff
changeset
|
566 |
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
6509 | 567 |
return $ |
568 |
r1 <> text "->" <> r2 |
|
6618 | 569 |
ref2C rf@(RecordField ref1 ref2) = do |
570 |
r1 <- ref2C ref1 |
|
571 |
t <- gets lastType |
|
6835 | 572 |
ns <- gets currentScope |
6817
daaf0834c4d2
- Apply unit's namespace to current scope when referencing unit name
unc0rr
parents:
6816
diff
changeset
|
573 |
r2 <- case t of |
6859 | 574 |
BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
6826 | 575 |
BTUnit -> withLastIdNamespace $ ref2C ref2 |
6835 | 576 |
a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
6509 | 577 |
return $ |
578 |
r1 <> text "." <> r2 |
|
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
|
579 |
ref2C d@(Dereference ref) = do |
6827 | 580 |
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
|
581 |
t <- fromPointer (show d) =<< gets lastType |
6834 | 582 |
modify (\st -> st{lastType = t}) |
6859 | 583 |
return $ (parens $ text "*" <> r) |
6509 | 584 |
ref2C (FunCall params ref) = do |
6826 | 585 |
ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
6509 | 586 |
r <- ref2C ref |
6826 | 587 |
t <- gets lastType |
588 |
case t of |
|
589 |
BTFunction t -> do |
|
590 |
modify (\s -> s{lastType = t}) |
|
591 |
return $ r <> ps |
|
592 |
_ -> return $ parens r <> ps |
|
593 |
||
6509 | 594 |
ref2C (Address ref) = do |
595 |
r <- ref2C ref |
|
596 |
return $ text "&" <> parens r |
|
597 |
ref2C (TypeCast t' expr) = do |
|
6663 | 598 |
t <- id2C IOLookup t' |
6509 | 599 |
e <- expr2C expr |
600 |
return $ parens t <> e |
|
6467 | 601 |
ref2C (RefExpression expr) = expr2C expr |
6355 | 602 |
|
6509 | 603 |
|
6860 | 604 |
op2C :: String -> String |
605 |
op2C "or" = "|" |
|
606 |
op2C "and" = "&" |
|
607 |
op2C "not" = "!" |
|
608 |
op2C "xor" = "^" |
|
609 |
op2C "div" = "/" |
|
610 |
op2C "mod" = "%" |
|
611 |
op2C "shl" = "<<" |
|
612 |
op2C "shr" = ">>" |
|
613 |
op2C "<>" = "!=" |
|
614 |
op2C "=" = "==" |
|
615 |
op2C a = a |
|
6273 | 616 |