25 |
25 |
26 type Record = (String, (String, BaseType)) |
26 type Record = (String, (String, BaseType)) |
27 data RenderState = RenderState |
27 data RenderState = RenderState |
28 { |
28 { |
29 currentScope :: [Record], |
29 currentScope :: [Record], |
|
30 lastIdentifier :: String, |
30 lastType :: BaseType, |
31 lastType :: BaseType, |
31 namespaces :: Map.Map String [Record] |
32 namespaces :: Map.Map String [Record] |
32 } |
33 } |
33 |
34 |
34 pas2C :: String -> IO () |
35 pas2C :: String -> IO () |
72 let nss = Map.map (toNamespace nss) units |
73 let nss = Map.map (toNamespace nss) units |
73 mapM_ (toCFiles nss) u |
74 mapM_ (toCFiles nss) u |
74 where |
75 where |
75 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
76 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
76 toNamespace nss (System tvs) = |
77 toNamespace nss (System tvs) = |
77 currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] BTUnknown nss) |
78 currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] "" BTUnknown nss) |
78 toNamespace _ (Program {}) = [] |
79 toNamespace _ (Program {}) = [] |
79 toNamespace nss (Unit _ interface _ _ _) = |
80 toNamespace nss (Unit _ interface _ _ _) = |
80 currentScope $ execState (interface2C interface) (RenderState [] BTUnknown nss) |
81 currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss) |
81 |
82 |
82 |
83 |
|
84 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
|
85 withLastIdNamespace f = do |
|
86 li <- gets lastIdentifier |
|
87 nss <- gets namespaces |
|
88 st <- gets id |
|
89 return $ evalState f st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)} |
|
90 |
83 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
91 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
84 toCFiles _ (_, System _) = return () |
92 toCFiles _ (_, System _) = return () |
85 toCFiles ns p@(fn, pu) = do |
93 toCFiles ns p@(fn, pu) = do |
86 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
94 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
87 toCFiles' p |
95 toCFiles' p |
89 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
97 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
90 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
98 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
91 let (a, s) = runState (interface2C interface) initialState |
99 let (a, s) = runState (interface2C interface) initialState |
92 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
100 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
93 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
101 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
94 initialState = RenderState [] BTUnknown ns |
102 initialState = RenderState [] "" BTUnknown ns |
95 |
103 |
96 render2C :: RenderState -> State RenderState Doc -> String |
104 render2C :: RenderState -> State RenderState Doc -> String |
97 render2C a = render . flip evalState a |
105 render2C a = render . flip evalState a |
98 |
106 |
99 usesFiles :: PascalUnit -> [String] |
107 usesFiles :: PascalUnit -> [String] |
151 v <- gets $ find (\(a, _) -> a == i') . currentScope |
159 v <- gets $ find (\(a, _) -> a == i') . currentScope |
152 ns <- gets currentScope |
160 ns <- gets currentScope |
153 if isNothing v then |
161 if isNothing v then |
154 error $ "Not defined: '" ++ i' ++ "'\n" -- ++ show ns |
162 error $ "Not defined: '" ++ i' ++ "'\n" -- ++ show ns |
155 else |
163 else |
156 let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv}) >> (return . text . fst $ vv) |
164 let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
157 id2C IODeferred (Identifier i t) = do |
165 id2C IODeferred (Identifier i t) = do |
158 let i' = map toLower i |
166 let i' = map toLower i |
159 v <- gets $ find (\(a, _) -> a == i') . currentScope |
167 v <- gets $ find (\(a, _) -> a == i') . currentScope |
160 if (isNothing v) then |
168 if (isNothing v) then |
161 do |
169 do |
383 return $ |
391 return $ |
384 r1 <> text "->" <> r2 |
392 r1 <> text "->" <> r2 |
385 ref2C rf@(RecordField ref1 ref2) = do |
393 ref2C rf@(RecordField ref1 ref2) = do |
386 r1 <- ref2C ref1 |
394 r1 <- ref2C ref1 |
387 t <- gets lastType |
395 t <- gets lastType |
388 ns <- gets currentScope |
396 r2 <- case t of |
389 case t of |
|
390 r@(BTRecord _) -> error $ show r |
397 r@(BTRecord _) -> error $ show r |
391 r@(BTUnit) -> error $ show r |
398 r@(BTUnit) -> withLastIdNamespace $ ref2C ref2 |
392 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
399 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
393 r2 <- ref2C ref2 |
|
394 return $ |
400 return $ |
395 r1 <> text "." <> r2 |
401 r1 <> text "." <> r2 |
396 ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref |
402 ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref |
397 ref2C (FunCall params ref) = do |
403 ref2C (FunCall params ref) = do |
398 r <- ref2C ref |
404 r <- ref2C ref |