74 |
113 |
75 renderCFiles :: Map.Map String PascalUnit -> IO () |
114 renderCFiles :: Map.Map String PascalUnit -> IO () |
76 renderCFiles units = do |
115 renderCFiles units = do |
77 let u = Map.toList units |
116 let u = Map.toList units |
78 let nss = Map.map (toNamespace nss) units |
117 let nss = Map.map (toNamespace nss) units |
|
118 hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss) |
|
119 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
79 mapM_ (toCFiles nss) u |
120 mapM_ (toCFiles nss) u |
80 where |
121 where |
81 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
122 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
82 toNamespace nss (System tvs) = |
123 toNamespace nss (System tvs) = |
83 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
124 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
84 toNamespace _ (Program {}) = [] |
125 toNamespace _ (Program {}) = [] |
85 toNamespace nss (Unit _ interface _ _ _) = |
126 toNamespace nss (Unit _ interface _ _ _) = |
86 currentScope $ execState (interface2C interface) (emptyState nss) |
127 currentScope $ execState (interface2C interface) (emptyState nss) |
87 |
128 |
88 |
129 |
89 withState' :: (a -> a) -> State a b -> State a b |
130 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
90 withState' f s = do |
131 withState' f sf = do |
91 st <- liftM f get |
132 st <- liftM f get |
92 return $ evalState s st |
133 let (a, s) = runState sf st |
|
134 modify(\st -> st{ |
|
135 lastType = lastType s |
|
136 , uniqCounter = uniqCounter s |
|
137 , stringConsts = stringConsts s |
|
138 }) |
|
139 return a |
93 |
140 |
94 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
141 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
95 withLastIdNamespace f = do |
142 withLastIdNamespace f = do |
96 li <- gets lastIdentifier |
143 li <- gets lastIdentifier |
97 nss <- gets namespaces |
144 nss <- gets namespaces |
98 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
145 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
99 |
146 |
100 withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
147 withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
101 withRecordNamespace recs = withState' f |
148 withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
|
149 withRecordNamespace prefix recs = withState' f |
102 where |
150 where |
103 f st = st{currentScope = records ++ currentScope st} |
151 f st = st{currentScope = records ++ currentScope st} |
104 records = map (\(a, b) -> (map toLower a, (a, b))) recs |
152 records = map (\(a, b) -> (map toLower a, (prefix ++ a, b))) recs |
105 |
153 |
106 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
154 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
107 toCFiles _ (_, System _) = return () |
155 toCFiles _ (_, System _) = return () |
108 toCFiles ns p@(fn, pu) = do |
156 toCFiles ns p@(fn, pu) = do |
109 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
157 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
110 toCFiles' p |
158 toCFiles' p |
111 where |
159 where |
112 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
160 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
113 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
161 toCFiles' (fn, (Unit unitId interface implementation _ _)) = do |
114 let (a, s) = runState (interface2C interface) initialState |
162 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState |
115 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
163 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
116 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
164 writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
117 initialState = emptyState ns |
165 initialState = emptyState ns |
118 |
166 |
119 render2C :: RenderState -> State RenderState Doc -> String |
167 render2C :: RenderState -> State RenderState Doc -> String |
120 render2C a = render . flip evalState a |
168 render2C a = render . ($+$ empty) . flip evalState a |
121 |
169 |
122 usesFiles :: PascalUnit -> [String] |
170 usesFiles :: PascalUnit -> [String] |
123 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
171 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
124 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
172 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
125 usesFiles (System {}) = [] |
173 usesFiles (System {}) = [] |
234 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
298 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type |
235 resolveType (DeriveType _) = return BTUnknown |
299 resolveType (DeriveType _) = return BTUnknown |
236 resolveType (String _) = return BTString |
300 resolveType (String _) = return BTString |
237 resolveType VoidType = return BTVoid |
301 resolveType VoidType = return BTVoid |
238 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
302 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
239 resolveType (RangeType _) = return $ BTUnknown |
303 resolveType (RangeType _) = return $ BTVoid |
240 resolveType (Set t) = liftM BTSet $ resolveType t |
304 resolveType (Set t) = liftM BTSet $ resolveType t |
241 --resolveType UnknownType = return BTUnknown |
305 |
242 resolveType a = error $ "resolveType: " ++ show a |
306 |
243 |
307 resolve :: String -> BaseType -> State RenderState BaseType |
244 |
308 resolve s (BTUnresolved t) = do |
245 fromPointer :: BaseType -> State RenderState BaseType |
309 v <- gets $ find (\(a, _) -> a == t) . currentScope |
246 fromPointer (BTPointerTo t) = f t |
310 if isJust v then |
247 where |
311 resolve s . snd . snd . fromJust $ v |
248 f (BTUnresolved s) = do |
312 else |
249 v <- gets $ find (\(a, _) -> a == s) . currentScope |
313 error $ "Unknown type " ++ show t ++ "\n" ++ s |
250 if isJust v then |
314 resolve _ t = return t |
251 f . snd . snd . fromJust $ v |
315 |
252 else |
316 fromPointer :: String -> BaseType -> State RenderState BaseType |
253 error $ "Unknown type " ++ show t |
317 fromPointer s (BTPointerTo t) = resolve s t |
254 f t = return t |
318 fromPointer s (BTFunctionReturn _ (BTPointerTo t)) = resolve s t |
255 fromPointer t = error $ "Dereferencing from non-pointer type " ++ show t |
319 fromPointer s t = do |
256 |
320 ns <- gets currentScope |
257 |
321 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s ++ "\n\n" ++ show (take 100 ns) |
258 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
322 |
259 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
323 |
|
324 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params |
|
325 |
|
326 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
|
327 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
260 t <- type2C returnType |
328 t <- type2C returnType |
261 p <- withState' id $ liftM hcat $ mapM (tvar2C False) params |
329 t'<- gets lastType |
262 n <- id2C IOInsert name |
330 p <- withState' id $ functionParams2C params |
263 return $ t <+> n <> parens p <> text ";" |
331 n <- id2C IOInsert $ setBaseType (BTFunction t') name |
264 |
332 return [t empty <+> n <> parens p] |
265 tvar2C True (FunctionDeclaration (Identifier i _) returnType params (Just (tvars, phrase))) = do |
333 |
|
334 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
|
335 let res = docToLower $ text rv <> text "_result" |
266 t <- type2C returnType |
336 t <- type2C returnType |
267 t'<- gets lastType |
337 t'<- gets lastType |
268 n <- id2C IOInsert (Identifier i (BTFunction t')) |
338 n <- id2C IOInsert $ setBaseType (BTFunction t') name |
269 (p, ph) <- withState' (\st -> st{currentScope = (lastIdentifier st, (lastIdentifier st ++ "_result", t')) : currentScope st}) $ do |
339 (p, ph) <- withState' (\st -> st{currentScope = (map toLower rv, (render res, BTFunctionReturn (render n) t')) : currentScope st}) $ do |
270 p <- liftM hcat $ mapM (tvar2C False) params |
340 p <- functionParams2C params |
271 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
341 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
272 return (p, ph) |
342 return (p, ph) |
273 let res = docToLower $ n <> text "_result" |
|
274 let phrasesBlock = case returnType of |
343 let phrasesBlock = case returnType of |
275 VoidType -> ph |
344 VoidType -> ph |
276 _ -> t <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
345 _ -> t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
277 return $ |
346 return [ |
278 t <+> n <> parens p |
347 t empty <+> n <> parens p |
279 $+$ |
348 $+$ |
280 text "{" |
349 text "{" |
281 $+$ |
350 $+$ |
282 nest 4 phrasesBlock |
351 nest 4 phrasesBlock |
283 $+$ |
352 $+$ |
284 text "}" |
353 text "}"] |
285 where |
354 where |
286 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
355 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
287 phrase2C' p = phrase2C p |
356 phrase2C' p = phrase2C p |
288 |
357 |
289 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
358 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
290 |
359 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
|
360 |
|
361 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
|
362 tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) = |
|
363 fun2C b name f |
291 tvar2C _ td@(TypeDeclaration i' t) = do |
364 tvar2C _ td@(TypeDeclaration i' t) = do |
292 i <- id2CTyped t i' |
365 i <- id2CTyped t i' |
293 tp <- type2C t |
366 tp <- case t of |
294 return $ text "type" <+> i <+> tp <> semi |
367 FunctionType {} -> type2C (PointerTo t) |
|
368 _ -> type2C t |
|
369 return [text "typedef" <+> tp i] |
295 |
370 |
296 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
371 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
297 t' <- type2C t |
372 t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t |
298 i <- mapM (id2CTyped t) ids |
|
299 ie <- initExpr mInitExpr |
373 ie <- initExpr mInitExpr |
300 return $ if isConst then text "const" else empty |
374 lt <- gets lastType |
301 <+> t' |
375 case (isConst, lt, ids, mInitExpr) of |
302 <+> (hsep . punctuate (char ',') $ i) |
376 (True, BTInt, [i], Just _) -> do |
303 <+> ie |
377 i' <- id2CTyped t i |
304 <> text ";" |
378 return [text "enum" <> braces (i' <+> ie)] |
|
379 (True, BTFloat, [i], Just e) -> do |
|
380 i' <- id2CTyped t i |
|
381 ie <- initExpr2C e |
|
382 return [text "#define" <+> i' <+> parens ie <> text "\n"] |
|
383 _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids |
305 where |
384 where |
306 initExpr Nothing = return $ empty |
385 initExpr Nothing = return $ empty |
307 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
386 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
308 |
387 |
309 tvar2C f (OperatorDeclaration op i ret params body) = |
388 tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do |
310 tvar2C f (FunctionDeclaration i ret params body) |
389 r <- op2CTyped op (extractTypes params) |
311 |
390 fun2C f i (FunctionDeclaration r ret params body) |
312 |
391 |
|
392 |
|
393 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
|
394 op2CTyped op t = do |
|
395 t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t |
|
396 bt <- gets lastType |
|
397 return $ case bt of |
|
398 BTRecord {} -> Identifier (t' ++ "_op_" ++ opStr) bt |
|
399 _ -> Identifier t' bt |
|
400 where |
|
401 opStr = case op of |
|
402 "+" -> "add" |
|
403 "-" -> "sub" |
|
404 "*" -> "mul" |
|
405 "/" -> "div" |
|
406 "=" -> "eq" |
|
407 "<" -> "lt" |
|
408 ">" -> "gt" |
|
409 _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" |
|
410 |
|
411 extractTypes :: [TypeVarDeclaration] -> [TypeDecl] |
|
412 extractTypes = concatMap f |
|
413 where |
|
414 f (VarDeclaration _ (ids, t) _) = replicate (length ids) t |
|
415 f a = error $ "extractTypes: can't extract from " ++ show a |
|
416 |
313 initExpr2C :: InitExpression -> State RenderState Doc |
417 initExpr2C :: InitExpression -> State RenderState Doc |
|
418 initExpr2C InitNull = return $ text "NULL" |
|
419 initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr) |
|
420 initExpr2C (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C expr) |
314 initExpr2C (InitBinOp op expr1 expr2) = do |
421 initExpr2C (InitBinOp op expr1 expr2) = do |
315 e1 <- initExpr2C expr1 |
422 e1 <- initExpr2C expr1 |
316 e2 <- initExpr2C expr2 |
423 e2 <- initExpr2C expr2 |
317 o <- op2C op |
424 return $ parens $ e1 <+> text (op2C op) <+> e2 |
318 return $ parens $ e1 <+> o <+> e2 |
|
319 initExpr2C (InitNumber s) = return $ text s |
425 initExpr2C (InitNumber s) = return $ text s |
320 initExpr2C (InitFloat s) = return $ text s |
426 initExpr2C (InitFloat s) = return $ text s |
321 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
427 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
322 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
428 initExpr2C (InitString [a]) = return . quotes $ text [a] |
|
429 initExpr2C (InitString s) = return $ strInit s |
|
430 initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
323 initExpr2C (InitReference i) = id2C IOLookup i |
431 initExpr2C (InitReference i) = id2C IOLookup i |
324 initExpr2C _ = return $ text "<<expression>>" |
432 initExpr2C (InitRecord fields) = do |
325 |
433 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
326 |
434 return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace |
327 type2C :: TypeDecl -> State RenderState Doc |
435 initExpr2C (InitArray [value]) = initExpr2C value |
328 type2C (SimpleType i) = id2C IOLookup i |
436 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
|
437 initExpr2C r@(InitRange (Range i@(Identifier i' _))) = do |
|
438 id2C IOLookup i |
|
439 t <- gets lastType |
|
440 case t of |
|
441 BTEnum s -> return . int $ length s |
|
442 BTInt -> case i' of |
|
443 "byte" -> return $ int 256 |
|
444 _ -> error $ "InitRange identifier: " ++ i' |
|
445 _ -> error $ "InitRange: " ++ show r |
|
446 initExpr2C (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
|
447 initExpr2C (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
|
448 initExpr2C (InitRange a) = error $ show a --return $ text "<<range>>" |
|
449 initExpr2C (InitSet []) = return $ text "0" |
|
450 initExpr2C (InitSet a) = return $ text "<<set>>" |
|
451 initExpr2C (BuiltInFunction "low" [InitReference e]) = return $ |
|
452 case e of |
|
453 (Identifier "LongInt" _) -> int (-2^31) |
|
454 (Identifier "SmallInt" _) -> int (-2^15) |
|
455 _ -> error $ "BuiltInFunction 'low': " ++ show e |
|
456 initExpr2C (BuiltInFunction "high" [e]) = do |
|
457 initExpr2C e |
|
458 t <- gets lastType |
|
459 case t of |
|
460 (BTArray i _ _) -> initExpr2C $ BuiltInFunction "pred" [InitRange i] |
|
461 a -> error $ "BuiltInFunction 'high': " ++ show a |
|
462 initExpr2C (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C e |
|
463 initExpr2C (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C e |
|
464 initExpr2C (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C e |
|
465 initExpr2C (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C e |
|
466 initExpr2C b@(BuiltInFunction _ _) = error $ show b |
|
467 initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a |
|
468 |
|
469 |
|
470 range2C :: InitExpression -> State RenderState [Doc] |
|
471 range2C (InitString [a]) = return [quotes $ text [a]] |
|
472 range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i |
|
473 range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b] |
|
474 range2C a = liftM (flip (:) []) $ initExpr2C a |
|
475 |
|
476 baseType2C :: String -> BaseType -> Doc |
|
477 baseType2C _ BTFloat = text "float" |
|
478 baseType2C _ BTBool = text "bool" |
|
479 baseType2C _ BTString = text "string255" |
|
480 baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s |
|
481 |
|
482 type2C :: TypeDecl -> State RenderState (Doc -> Doc) |
|
483 type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i |
329 type2C t = do |
484 type2C t = do |
330 r <- type2C' t |
485 r <- type2C' t |
331 rt <- resolveType t |
486 rt <- resolveType t |
332 modify (\st -> st{lastType = rt}) |
487 modify (\st -> st{lastType = rt}) |
333 return r |
488 return r |
334 where |
489 where |
335 type2C' VoidType = return $ text "void" |
490 type2C' VoidType = return (text "void" <+>) |
336 type2C' (String l) = return $ text $ "string" ++ show l |
491 type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>) |
337 type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
492 type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct __" <> i <+> text "*" <+> a) $ id2C IODeferred i |
338 type2C' (PointerTo t) = liftM (<> text "*") $ type2C t |
493 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
339 type2C' (RecordType tvs union) = do |
494 type2C' (RecordType tvs union) = do |
340 t <- mapM (tvar2C False) tvs |
495 t <- withState' id $ mapM (tvar2C False) tvs |
341 return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
496 u <- unions |
342 type2C' (RangeType r) = return $ text "<<range type>>" |
497 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i |
|
498 where |
|
499 unions = case union of |
|
500 Nothing -> return empty |
|
501 Just a -> do |
|
502 structs <- mapM struct2C a |
|
503 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
|
504 struct2C tvs = do |
|
505 t <- withState' id $ mapM (tvar2C False) tvs |
|
506 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi |
|
507 type2C' (RangeType r) = return (text "int" <+>) |
343 type2C' (Sequence ids) = do |
508 type2C' (Sequence ids) = do |
344 mapM_ (id2C IOInsert) ids |
509 is <- mapM (id2C IOInsert . setBaseType bt) ids |
345 return $ text "<<sequence type>>" |
510 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [1..]) <+>) |
346 type2C' (ArrayDecl r t) = return $ text "<<array type>>" |
511 where |
347 type2C' (Set t) = return $ text "<<set>>" |
512 bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids |
348 type2C' (FunctionType returnType params) = return $ text "<<function>>" |
513 type2C' (ArrayDecl Nothing t) = type2C (PointerTo t) |
349 type2C' (DeriveType _) = return $ text "<<type derived from constant literal>>" |
514 type2C' (ArrayDecl (Just r) t) = do |
|
515 t' <- type2C t |
|
516 r' <- initExpr2C (InitRange r) |
|
517 return $ \i -> t' i <> brackets r' |
|
518 type2C' (Set t) = return (text "<<set>>" <+>) |
|
519 type2C' (FunctionType returnType params) = do |
|
520 t <- type2C returnType |
|
521 p <- withState' id $ functionParams2C params |
|
522 return (\i -> t empty <+> i <> parens p) |
|
523 type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i) |
|
524 type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) |
|
525 type2C' (DeriveType (InitNumber _)) = return (text "int" <+>) |
|
526 type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>) |
|
527 type2C' (DeriveType (InitFloat _)) = return (text "float" <+>) |
|
528 type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>) |
|
529 type2C' (DeriveType (InitString {})) = return (text "string255" <+>) |
|
530 type2C' (DeriveType r@(InitReference {})) = do |
|
531 initExpr2C r |
|
532 t <- gets lastType |
|
533 return (baseType2C (show r) t <+>) |
|
534 type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a |
350 |
535 |
351 phrase2C :: Phrase -> State RenderState Doc |
536 phrase2C :: Phrase -> State RenderState Doc |
352 phrase2C (Phrases p) = do |
537 phrase2C (Phrases p) = do |
353 ps <- mapM phrase2C p |
538 ps <- mapM phrase2C p |
354 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
539 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
355 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
540 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
356 phrase2C (ProcCall ref params) = do |
541 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref |
|
542 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do |
357 r <- ref2C ref |
543 r <- ref2C ref |
358 ps <- mapM expr2C params |
544 ps <- mapM expr2C params |
359 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi |
545 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
360 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
546 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
361 e <- expr2C expr |
547 e <- expr2C expr |
362 p1 <- (phrase2C . wrapPhrase) phrase1 |
548 p1 <- (phrase2C . wrapPhrase) phrase1 |
363 el <- elsePart |
549 el <- elsePart |
364 return $ |
550 return $ |
365 text "if" <> parens e $+$ p1 $+$ el |
551 text "if" <> parens e $+$ p1 $+$ el |
366 where |
552 where |
367 elsePart | isNothing mphrase2 = return $ empty |
553 elsePart | isNothing mphrase2 = return $ empty |
368 | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
554 | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
369 phrase2C (Assignment ref expr) = do |
555 phrase2C (Assignment ref expr) = do |
370 r <- ref2C ref |
556 r <- ref2C ref |
371 e <- expr2C expr |
557 t <- gets lastType |
372 return $ |
558 e <- case (t, expr) of |
373 r <> text " = " <> e <> semi |
559 (BTFunction _, (Reference r')) -> ref2C r' |
|
560 _ -> expr2C expr |
|
561 return $ r <+> text "=" <+> e <> semi |
374 phrase2C (WhileCycle expr phrase) = do |
562 phrase2C (WhileCycle expr phrase) = do |
375 e <- expr2C expr |
563 e <- expr2C expr |
376 p <- phrase2C $ wrapPhrase phrase |
564 p <- phrase2C $ wrapPhrase phrase |
377 return $ text "while" <> parens e $$ p |
565 return $ text "while" <> parens e $$ p |
378 phrase2C (SwitchCase expr cases mphrase) = do |
566 phrase2C (SwitchCase expr cases mphrase) = do |
379 e <- expr2C expr |
567 e <- expr2C expr |
380 cs <- mapM case2C cases |
568 cs <- mapM case2C cases |
|
569 d <- dflt |
381 return $ |
570 return $ |
382 text "switch" <> parens e <> text "of" $+$ (nest 4 . vcat) cs |
571 text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) |
383 where |
572 where |
384 case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
573 case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
385 case2C (e, p) = do |
574 case2C (e, p) = do |
386 ie <- mapM initExpr2C e |
575 ies <- mapM range2C e |
387 ph <- phrase2C p |
576 ph <- phrase2C p |
388 return $ |
577 return $ |
389 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
578 vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") |
390 phrase2C (WithBlock ref p) = do |
579 dflt | isNothing mphrase = return [] |
|
580 | otherwise = do |
|
581 ph <- mapM phrase2C $ fromJust mphrase |
|
582 return [text "default:" <+> nest 4 (vcat ph)] |
|
583 |
|
584 phrase2C wb@(WithBlock ref p) = do |
391 r <- ref2C ref |
585 r <- ref2C ref |
392 ph <- phrase2C $ wrapPhrase p |
586 t <- gets lastType |
393 return $ text "namespace" <> parens r $$ ph |
587 case t of |
|
588 (BTRecord rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
|
589 a -> do |
|
590 ns <- gets currentScope |
|
591 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb ++ "\nnamespace: " ++ show (take 100 ns) |
394 phrase2C (ForCycle i' e1' e2' p) = do |
592 phrase2C (ForCycle i' e1' e2' p) = do |
395 i <- id2C IOLookup i' |
593 i <- id2C IOLookup i' |
396 e1 <- expr2C e1' |
594 e1 <- expr2C e1' |
397 e2 <- expr2C e2' |
595 e2 <- expr2C e2' |
398 ph <- phrase2C (wrapPhrase p) |
596 ph <- phrase2C (wrapPhrase p) |
401 $$ |
599 $$ |
402 ph |
600 ph |
403 phrase2C (RepeatCycle e' p') = do |
601 phrase2C (RepeatCycle e' p') = do |
404 e <- expr2C e' |
602 e <- expr2C e' |
405 p <- phrase2C (Phrases p') |
603 p <- phrase2C (Phrases p') |
406 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) |
604 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
407 phrase2C NOP = return $ text ";" |
605 phrase2C NOP = return $ text ";" |
408 |
606 |
|
607 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = return $ text "return" <> semi |
|
608 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <> e <> semi) $ expr2C e |
|
609 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e |
|
610 phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2) |
|
611 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e |
|
612 phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2) |
|
613 phrase2C a = error $ "phrase2C: " ++ show a |
409 |
614 |
410 wrapPhrase p@(Phrases _) = p |
615 wrapPhrase p@(Phrases _) = p |
411 wrapPhrase p = Phrases [p] |
616 wrapPhrase p = Phrases [p] |
412 |
|
413 |
617 |
414 expr2C :: Expression -> State RenderState Doc |
618 expr2C :: Expression -> State RenderState Doc |
415 expr2C (Expression s) = return $ text s |
619 expr2C (Expression s) = return $ text s |
416 expr2C (BinOp op expr1 expr2) = do |
620 expr2C (BinOp op expr1 expr2) = do |
417 e1 <- expr2C expr1 |
621 e1 <- expr2C expr1 |
|
622 t1 <- gets lastType |
418 e2 <- expr2C expr2 |
623 e2 <- expr2C expr2 |
419 o <- op2C op |
624 t2 <- gets lastType |
420 return $ parens $ e1 <+> o <+> e2 |
625 case (op2C op, t1, t2) of |
|
626 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString)) |
|
627 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction BTString)) |
|
628 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction BTString)) |
|
629 ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
|
630 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
|
631 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
|
632 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
|
633 (o, _, _) | o `elem` boolOps -> do |
|
634 modify(\s -> s{lastType = BTBool}) |
|
635 return $ parens e1 <+> text o <+> parens e2 |
|
636 | otherwise -> return $ parens e1 <+> text o <+> parens e2 |
|
637 where |
|
638 boolOps = ["==", "!=", "<", ">", "<=", ">="] |
421 expr2C (NumberLiteral s) = return $ text s |
639 expr2C (NumberLiteral s) = return $ text s |
422 expr2C (FloatLiteral s) = return $ text s |
640 expr2C (FloatLiteral s) = return $ text s |
423 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
641 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
424 expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
642 expr2C (StringLiteral [a]) = do |
425 expr2C (Reference ref) = ref2C ref |
643 modify(\s -> s{lastType = BTChar}) |
426 expr2C (PrefixOp op expr) = liftM2 (<+>) (op2C op) (expr2C expr) |
644 return . quotes $ text [a] |
|
645 expr2C (StringLiteral s) = addStringConst s |
|
646 expr2C (Reference ref) = ref2CF ref |
|
647 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
427 expr2C Null = return $ text "NULL" |
648 expr2C Null = return $ text "NULL" |
|
649 expr2C (CharCode a) = do |
|
650 modify(\s -> s{lastType = BTChar}) |
|
651 return $ quotes $ text "\\x" <> text (showHex (read a) "") |
|
652 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
|
653 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
|
654 |
|
655 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
|
656 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
|
657 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e |
428 expr2C (BuiltInFunCall params ref) = do |
658 expr2C (BuiltInFunCall params ref) = do |
429 r <- ref2C ref |
659 r <- ref2C ref |
|
660 t <- gets lastType |
430 ps <- mapM expr2C params |
661 ps <- mapM expr2C params |
|
662 case t of |
|
663 BTFunction t' -> do |
|
664 modify (\s -> s{lastType = t'}) |
|
665 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
431 return $ |
666 return $ |
432 r <> parens (hsep . punctuate (char ',') $ ps) |
667 r <> parens (hsep . punctuate (char ',') $ ps) |
433 expr2C _ = return $ text "<<expression>>" |
668 expr2C a = error $ "Don't know how to render " ++ show a |
434 |
669 |
|
670 ref2CF :: Reference -> State RenderState Doc |
|
671 ref2CF (SimpleReference name) = do |
|
672 i <- id2C IOLookup name |
|
673 t <- gets lastType |
|
674 case t of |
|
675 BTFunction _ -> return $ i <> parens empty |
|
676 _ -> return $ i |
|
677 ref2CF r = ref2C r |
435 |
678 |
436 ref2C :: Reference -> State RenderState Doc |
679 ref2C :: Reference -> State RenderState Doc |
437 ref2C ae@(ArrayElement exprs ref) = do |
680 -- rewrite into proper form |
438 es <- mapM expr2C exprs |
681 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
|
682 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
|
683 ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
|
684 ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
|
685 ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) |
|
686 -- conversion routines |
|
687 ref2C ae@(ArrayElement [expr] ref) = do |
|
688 e <- expr2C expr |
439 r <- ref2C ref |
689 r <- ref2C ref |
440 t <- gets lastType |
690 t <- gets lastType |
441 ns <- gets currentScope |
691 ns <- gets currentScope |
442 case t of |
692 case t of |
443 (BTArray _ (BTArray _ t')) -> modify (\st -> st{lastType = t'}) |
693 (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) |
444 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
694 (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'}) |
|
695 (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar}) |
445 (BTString) -> modify (\st -> st{lastType = BTChar}) |
696 (BTString) -> modify (\st -> st{lastType = BTChar}) |
|
697 (BTPointerTo t) -> do |
|
698 t'' <- fromPointer (show t) =<< gets lastType |
|
699 case t'' of |
|
700 BTChar -> modify (\st -> st{lastType = BTChar}) |
|
701 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
446 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
702 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
447 return $ r <> (brackets . hcat) (punctuate comma es) |
703 case t of |
|
704 BTString -> return $ r <> text ".s" <> brackets e |
|
705 _ -> return $ r <> brackets e |
448 ref2C (SimpleReference name) = id2C IOLookup name |
706 ref2C (SimpleReference name) = id2C IOLookup name |
449 ref2C (RecordField (Dereference ref1) ref2) = do |
707 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
450 r1 <- ref2C ref1 |
708 r1 <- ref2C ref1 |
451 r2 <- ref2C ref2 |
709 t <- fromPointer (show ref1) =<< gets lastType |
|
710 ns <- gets currentScope |
|
711 r2 <- case t of |
|
712 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
|
713 BTUnit -> withLastIdNamespace $ ref2C ref2 |
|
714 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
452 return $ |
715 return $ |
453 r1 <> text "->" <> r2 |
716 r1 <> text "->" <> r2 |
454 ref2C rf@(RecordField ref1 ref2) = do |
717 ref2C rf@(RecordField ref1 ref2) = do |
455 r1 <- ref2C ref1 |
718 r1 <- ref2C ref1 |
456 t <- gets lastType |
719 t <- gets lastType |
457 ns <- gets currentScope |
720 ns <- gets currentScope |
458 r2 <- case t of |
721 r2 <- case t of |
459 BTRecord rs -> withRecordNamespace rs $ ref2C ref2 |
722 BTFunctionReturn s (BTRecord rs) -> withRecordNamespace "" rs $ ref2C ref2 |
460 BTUnit -> withLastIdNamespace $ ref2C ref2 |
723 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
|
724 BTUnit -> withLastIdNamespace $ ref2C ref2 |
461 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
725 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
462 return $ |
726 return $ |
463 r1 <> text "." <> r2 |
727 r1 <> text "." <> r2 |
464 ref2C (Dereference ref) = do |
728 ref2C d@(Dereference ref) = do |
465 r <- ref2C ref |
729 r <- ref2C ref |
466 t <- fromPointer =<< gets lastType |
730 t <- fromPointer (show d) =<< gets lastType |
467 modify (\st -> st{lastType = t}) |
731 modify (\st -> st{lastType = t}) |
468 return $ (parens $ text "*") <> r |
732 return $ (parens $ text "*" <> r) |
469 ref2C (FunCall params ref) = do |
733 ref2C f@(FunCall params ref) = do |
470 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
|
471 r <- ref2C ref |
734 r <- ref2C ref |
472 t <- gets lastType |
735 t <- gets lastType |
473 case t of |
736 case t of |
474 BTFunction t -> do |
737 BTFunction t' -> do |
475 modify (\s -> s{lastType = t}) |
738 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
|
739 modify (\s -> s{lastType = t'}) |
476 return $ r <> ps |
740 return $ r <> ps |
477 _ -> return $ parens r <> ps |
741 BTFunctionReturn r t' -> do |
|
742 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
|
743 modify (\s -> s{lastType = t'}) |
|
744 return $ text r <> ps |
|
745 _ -> case (ref, params) of |
|
746 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
|
747 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
478 |
748 |
479 ref2C (Address ref) = do |
749 ref2C (Address ref) = do |
480 r <- ref2C ref |
750 r <- ref2C ref |
481 return $ text "&" <> parens r |
751 return $ text "&" <> parens r |
482 ref2C (TypeCast t' expr) = do |
752 ref2C (TypeCast t'@(Identifier i _) expr) = do |
483 t <- id2C IOLookup t' |
753 case map toLower i of |
484 e <- expr2C expr |
754 "pchar" -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
485 return $ parens t <> e |
755 a -> do |
|
756 e <- expr2C expr |
|
757 t <- id2C IOLookup t' |
|
758 return $ parens t <> e |
486 ref2C (RefExpression expr) = expr2C expr |
759 ref2C (RefExpression expr) = expr2C expr |
487 |
760 |
488 |
761 |
489 op2C :: String -> State RenderState Doc |
762 op2C :: String -> String |
490 op2C "or" = return $ text "|" |
763 op2C "or" = "|" |
491 op2C "and" = return $ text "&" |
764 op2C "and" = "&" |
492 op2C "not" = return $ text "!" |
765 op2C "not" = "!" |
493 op2C "xor" = return $ text "^" |
766 op2C "xor" = "^" |
494 op2C "div" = return $ text "/" |
767 op2C "div" = "/" |
495 op2C "mod" = return $ text "%" |
768 op2C "mod" = "%" |
496 op2C "shl" = return $ text "<<" |
769 op2C "shl" = "<<" |
497 op2C "shr" = return $ text ">>" |
770 op2C "shr" = ">>" |
498 op2C "<>" = return $ text "!=" |
771 op2C "<>" = "!=" |
499 op2C "=" = return $ text "==" |
772 op2C "=" = "==" |
500 op2C a = return $ text a |
773 op2C a = a |
501 |
774 |
502 maybeVoid "" = "void" |
|
503 maybeVoid a = a |
|