19 |
19 |
20 import PascalParser |
20 import PascalParser |
21 import PascalUnitSyntaxTree |
21 import PascalUnitSyntaxTree |
22 |
22 |
23 |
23 |
24 data InsertOption = |
24 data InsertOption = |
25 IOInsert |
25 IOInsert |
26 | IOLookup |
26 | IOLookup |
27 | IOLookupLast |
27 | IOLookupLast |
28 | IOLookupFunction Int |
28 | IOLookupFunction Int |
29 | IODeferred |
29 | IODeferred |
30 |
30 |
31 type Record = (String, BaseType) |
31 type Record = (String, BaseType) |
32 type Records = Map.Map String [Record] |
32 type Records = Map.Map String [Record] |
33 data RenderState = RenderState |
33 data RenderState = RenderState |
34 { |
34 { |
35 currentScope :: Records, |
35 currentScope :: Records, |
36 lastIdentifier :: String, |
36 lastIdentifier :: String, |
37 lastType :: BaseType, |
37 lastType :: BaseType, |
38 stringConsts :: [(String, String)], |
38 stringConsts :: [(String, String)], |
40 toMangle :: Set.Set String, |
40 toMangle :: Set.Set String, |
41 currentUnit :: String, |
41 currentUnit :: String, |
42 currentFunctionResult :: String, |
42 currentFunctionResult :: String, |
43 namespaces :: Map.Map String Records |
43 namespaces :: Map.Map String Records |
44 } |
44 } |
45 |
45 |
46 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" "" |
46 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" "" |
47 |
47 |
48 getUniq :: State RenderState Int |
48 getUniq :: State RenderState Int |
49 getUniq = do |
49 getUniq = do |
50 i <- gets uniqCounter |
50 i <- gets uniqCounter |
51 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
51 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
52 return i |
52 return i |
53 |
53 |
54 addStringConst :: String -> State RenderState Doc |
54 addStringConst :: String -> State RenderState Doc |
55 addStringConst str = do |
55 addStringConst str = do |
56 strs <- gets stringConsts |
56 strs <- gets stringConsts |
57 let a = find ((==) str . snd) strs |
57 let a = find ((==) str . snd) strs |
58 if isJust a then |
58 if isJust a then |
125 --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) |
125 --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) |
126 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
126 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
127 mapM_ (toCFiles nss) u |
127 mapM_ (toCFiles nss) u |
128 where |
128 where |
129 toNamespace :: Map.Map String Records -> PascalUnit -> Records |
129 toNamespace :: Map.Map String Records -> PascalUnit -> Records |
130 toNamespace nss (System tvs) = |
130 toNamespace nss (System tvs) = |
131 currentScope $ execState f (emptyState nss) |
131 currentScope $ execState f (emptyState nss) |
132 where |
132 where |
133 f = do |
133 f = do |
134 checkDuplicateFunDecls tvs |
134 checkDuplicateFunDecls tvs |
135 mapM_ (tvar2C True) tvs |
135 mapM_ (tvar2C True) tvs |
136 toNamespace _ (Program {}) = Map.empty |
136 toNamespace _ (Program {}) = Map.empty |
137 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
137 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
138 currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"} |
138 currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"} |
139 |
139 |
140 |
140 |
141 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
141 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
142 withState' f sf = do |
142 withState' f sf = do |
186 |
186 |
187 |
187 |
188 pascal2C :: PascalUnit -> State RenderState Doc |
188 pascal2C :: PascalUnit -> State RenderState Doc |
189 pascal2C (Unit _ interface implementation init fin) = |
189 pascal2C (Unit _ interface implementation init fin) = |
190 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
190 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
191 |
191 |
192 pascal2C (Program _ implementation mainFunction) = do |
192 pascal2C (Program _ implementation mainFunction) = do |
193 impl <- implementation2C implementation |
193 impl <- implementation2C implementation |
194 [main] <- tvar2C True |
194 [main] <- tvar2C True |
195 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
195 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
196 return $ impl $+$ main |
196 return $ impl $+$ main |
197 |
197 |
198 |
198 |
199 |
199 |
200 interface2C :: Interface -> State RenderState Doc |
200 interface2C :: Interface -> State RenderState Doc |
201 interface2C (Interface uses tvars) = do |
201 interface2C (Interface uses tvars) = do |
202 u <- uses2C uses |
202 u <- uses2C uses |
203 tv <- typesAndVars2C True tvars |
203 tv <- typesAndVars2C True tvars |
204 r <- renderStringConsts |
204 r <- renderStringConsts |
205 return (u $+$ r $+$ tv) |
205 return (u $+$ r $+$ tv) |
206 |
206 |
207 implementation2C :: Implementation -> State RenderState Doc |
207 implementation2C :: Implementation -> State RenderState Doc |
208 implementation2C (Implementation uses tvars) = do |
208 implementation2C (Implementation uses tvars) = do |
209 u <- uses2C uses |
209 u <- uses2C uses |
210 tv <- typesAndVars2C True tvars |
210 tv <- typesAndVars2C True tvars |
211 r <- renderStringConsts |
211 r <- renderStringConsts |
259 id2C IOLookupLast i = id2CLookup last i |
259 id2C IOLookupLast i = id2CLookup last i |
260 id2C (IOLookupFunction params) (Identifier i t) = do |
260 id2C (IOLookupFunction params) (Identifier i t) = do |
261 let i' = map toLower i |
261 let i' = map toLower i |
262 v <- gets $ Map.lookup i' . currentScope |
262 v <- gets $ Map.lookup i' . currentScope |
263 lt <- gets lastType |
263 lt <- gets lastType |
264 if isNothing v then |
264 if isNothing v then |
265 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
265 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v |
266 else |
266 else |
267 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
267 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in |
268 modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
268 modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
269 where |
269 where |
270 checkParam (_, BTFunction p _) = p == params |
270 checkParam (_, BTFunction p _) = p == params |
271 checkParam _ = False |
271 checkParam _ = False |
272 id2C IODeferred (Identifier i t) = do |
272 id2C IODeferred (Identifier i t) = do |
280 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
280 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc |
281 id2CLookup f (Identifier i _) = do |
281 id2CLookup f (Identifier i _) = do |
282 let i' = map toLower i |
282 let i' = map toLower i |
283 v <- gets $ Map.lookup i' . currentScope |
283 v <- gets $ Map.lookup i' . currentScope |
284 lt <- gets lastType |
284 lt <- gets lastType |
285 if isNothing v then |
285 if isNothing v then |
286 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
286 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt |
287 else |
287 else |
288 let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
288 let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) |
289 |
289 |
290 |
290 |
291 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
291 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
292 id2CTyped t (Identifier i _) = do |
292 id2CTyped t (Identifier i _) = do |
293 tb <- resolveType t |
293 tb <- resolveType t |
294 case (t, tb) of |
294 case (t, tb) of |
295 (_, BTUnknown) -> do |
295 (_, BTUnknown) -> do |
296 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t |
296 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t |
297 (SimpleType {}, BTRecord _ r) -> do |
297 (SimpleType {}, BTRecord _ r) -> do |
298 ts <- type2C t |
298 ts <- type2C t |
299 id2C IOInsert (Identifier i (BTRecord (render $ ts empty) r)) |
299 id2C IOInsert (Identifier i (BTRecord (render $ ts empty) r)) |
300 (_, BTRecord _ r) -> do |
300 (_, BTRecord _ r) -> do |
301 ts <- type2C t |
301 ts <- type2C t |
302 id2C IOInsert (Identifier i (BTRecord i r)) |
302 id2C IOInsert (Identifier i (BTRecord i r)) |
303 _ -> id2C IOInsert (Identifier i tb) |
303 _ -> id2C IOInsert (Identifier i tb) |
304 |
304 |
305 |
305 |
306 |
306 |
307 resolveType :: TypeDecl -> State RenderState BaseType |
307 resolveType :: TypeDecl -> State RenderState BaseType |
308 resolveType st@(SimpleType (Identifier i _)) = do |
308 resolveType st@(SimpleType (Identifier i _)) = do |
309 let i' = map toLower i |
309 let i' = map toLower i |
325 where |
325 where |
326 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
326 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
327 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
327 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
328 resolveType (ArrayDecl (Just i) t) = do |
328 resolveType (ArrayDecl (Just i) t) = do |
329 t' <- resolveType t |
329 t' <- resolveType t |
330 return $ BTArray i BTInt t' |
330 return $ BTArray i BTInt t' |
331 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t |
331 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t |
332 resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t |
332 resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t |
333 resolveType (DeriveType (InitHexNumber _)) = return BTInt |
333 resolveType (DeriveType (InitHexNumber _)) = return BTInt |
334 resolveType (DeriveType (InitNumber _)) = return BTInt |
334 resolveType (DeriveType (InitNumber _)) = return BTInt |
335 resolveType (DeriveType (InitFloat _)) = return BTFloat |
335 resolveType (DeriveType (InitFloat _)) = return BTFloat |
358 fromPointer :: String -> BaseType -> State RenderState BaseType |
358 fromPointer :: String -> BaseType -> State RenderState BaseType |
359 fromPointer s (BTPointerTo t) = resolve s t |
359 fromPointer s (BTPointerTo t) = resolve s t |
360 fromPointer s t = do |
360 fromPointer s t = do |
361 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
361 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
362 |
362 |
363 |
363 |
364 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params |
364 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params |
365 |
365 |
366 numberOfDeclarations :: [TypeVarDeclaration] -> Int |
366 numberOfDeclarations :: [TypeVarDeclaration] -> Int |
367 numberOfDeclarations = sum . map cnt |
367 numberOfDeclarations = sum . map cnt |
368 where |
368 where |
369 cnt (VarDeclaration _ (ids, _) _) = length ids |
369 cnt (VarDeclaration _ (ids, _) _) = length ids |
370 cnt _ = 1 |
370 cnt _ = 1 |
371 |
371 |
372 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
372 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] |
373 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
373 fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do |
374 t <- type2C returnType |
374 t <- type2C returnType |
375 t'<- gets lastType |
375 t'<- gets lastType |
376 p <- withState' id $ functionParams2C params |
376 p <- withState' id $ functionParams2C params |
377 n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
377 n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
378 return [t empty <+> n <> parens p] |
378 return [t empty <+> n <> parens p] |
379 |
379 |
380 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
380 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
381 let res = docToLower $ text rv <> text "_result" |
381 let res = docToLower $ text rv <> text "_result" |
382 t <- type2C returnType |
382 t <- type2C returnType |
383 t'<- gets lastType |
383 t'<- gets lastType |
384 n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
384 n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name |
385 |
385 |
386 let isVoid = case returnType of |
386 let isVoid = case returnType of |
387 VoidType -> True |
387 VoidType -> True |
388 _ -> False |
388 _ -> False |
389 |
389 |
390 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st |
390 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st |
391 , currentFunctionResult = if isVoid then [] else render res}) $ do |
391 , currentFunctionResult = if isVoid then [] else render res}) $ do |
392 p <- functionParams2C params |
392 p <- functionParams2C params |
393 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
393 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
394 return (p, ph) |
394 return (p, ph) |
395 |
395 |
396 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
396 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
397 |
397 |
398 return [ |
398 return [ |
399 t empty <+> n <> parens p |
399 t empty <+> n <> parens p |
400 $+$ |
400 $+$ |
401 text "{" |
401 text "{" |
402 $+$ |
402 $+$ |
403 nest 4 phrasesBlock |
403 nest 4 phrasesBlock |
404 $+$ |
404 $+$ |
405 text "}"] |
405 text "}"] |
406 where |
406 where |
407 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
407 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
408 phrase2C' p = phrase2C p |
408 phrase2C' p = phrase2C p |
409 un [a] b = a : b |
409 un [a] b = a : b |
410 |
410 |
411 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
411 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
412 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
412 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
413 |
413 |
414 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
414 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
415 tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) = |
415 tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) = |
416 fun2C b name f |
416 fun2C b name f |
417 tvar2C _ td@(TypeDeclaration i' t) = do |
417 tvar2C _ td@(TypeDeclaration i' t) = do |
418 i <- id2CTyped t i' |
418 i <- id2CTyped t i' |
419 tp <- type2C t |
419 tp <- type2C t |
420 return [text "typedef" <+> tp i] |
420 return [text "typedef" <+> tp i] |
421 |
421 |
422 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
422 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
423 t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t |
423 t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t |
424 ie <- initExpr mInitExpr |
424 ie <- initExpr mInitExpr |
425 lt <- gets lastType |
425 lt <- gets lastType |
426 case (isConst, lt, ids, mInitExpr) of |
426 case (isConst, lt, ids, mInitExpr) of |
434 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' $ text "*" <+> i)) $ mapM (id2CTyped t) ids |
434 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' $ text "*" <+> i)) $ mapM (id2CTyped t) ids |
435 _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids |
435 _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids |
436 where |
436 where |
437 initExpr Nothing = return $ empty |
437 initExpr Nothing = return $ empty |
438 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
438 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
439 |
439 |
440 tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do |
440 tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do |
441 r <- op2CTyped op (extractTypes params) |
441 r <- op2CTyped op (extractTypes params) |
442 fun2C f i (FunctionDeclaration r ret params body) |
442 fun2C f i (FunctionDeclaration r ret params body) |
443 |
443 |
444 |
444 |
445 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
445 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
446 op2CTyped op t = do |
446 op2CTyped op t = do |
447 t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t |
447 t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t |
448 bt <- gets lastType |
448 bt <- gets lastType |
449 return $ Identifier (t' ++ "_op_" ++ opStr) bt |
449 return $ Identifier (t' ++ "_op_" ++ opStr) bt |
450 where |
450 where |
451 opStr = case op of |
451 opStr = case op of |
452 "+" -> "add" |
452 "+" -> "add" |
453 "-" -> "sub" |
453 "-" -> "sub" |
454 "*" -> "mul" |
454 "*" -> "mul" |
455 "/" -> "div" |
455 "/" -> "div" |
456 "=" -> "eq" |
456 "=" -> "eq" |
457 "<" -> "lt" |
457 "<" -> "lt" |
458 ">" -> "gt" |
458 ">" -> "gt" |
459 "<>" -> "neq" |
459 "<>" -> "neq" |
460 _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" |
460 _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" |
461 |
461 |
462 extractTypes :: [TypeVarDeclaration] -> [TypeDecl] |
462 extractTypes :: [TypeVarDeclaration] -> [TypeDecl] |
463 extractTypes = concatMap f |
463 extractTypes = concatMap f |
464 where |
464 where |
465 f (VarDeclaration _ (ids, t) _) = replicate (length ids) t |
465 f (VarDeclaration _ (ids, t) _) = replicate (length ids) t |
466 f a = error $ "extractTypes: can't extract from " ++ show a |
466 f a = error $ "extractTypes: can't extract from " ++ show a |
498 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
498 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
499 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
499 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
500 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" |
500 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" |
501 initExpr2C' (InitSet []) = return $ text "0" |
501 initExpr2C' (InitSet []) = return $ text "0" |
502 initExpr2C' (InitSet a) = return $ text "<<set>>" |
502 initExpr2C' (InitSet a) = return $ text "<<set>>" |
503 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ |
503 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ |
504 case e of |
504 case e of |
505 (Identifier "LongInt" _) -> int (-2^31) |
505 (Identifier "LongInt" _) -> int (-2^31) |
506 (Identifier "SmallInt" _) -> int (-2^15) |
506 (Identifier "SmallInt" _) -> int (-2^15) |
507 _ -> error $ "BuiltInFunction 'low': " ++ show e |
507 _ -> error $ "BuiltInFunction 'low': " ++ show e |
508 initExpr2C' (BuiltInFunction "high" [e]) = do |
508 initExpr2C' (BuiltInFunction "high" [e]) = do |
513 a -> error $ "BuiltInFunction 'high': " ++ show a |
513 a -> error $ "BuiltInFunction 'high': " ++ show a |
514 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e |
514 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e |
515 initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e |
515 initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e |
516 initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e |
516 initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e |
517 initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e |
517 initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e |
518 initExpr2C' b@(BuiltInFunction _ _) = error $ show b |
518 initExpr2C' b@(BuiltInFunction _ _) = error $ show b |
519 initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a |
519 initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a |
520 |
520 |
521 |
521 |
522 range2C :: InitExpression -> State RenderState [Doc] |
522 range2C :: InitExpression -> State RenderState [Doc] |
523 range2C (InitString [a]) = return [quotes $ text [a]] |
523 range2C (InitString [a]) = return [quotes $ text [a]] |
652 return $ text "while" <> parens e $$ p |
652 return $ text "while" <> parens e $$ p |
653 phrase2C (SwitchCase expr cases mphrase) = do |
653 phrase2C (SwitchCase expr cases mphrase) = do |
654 e <- expr2C expr |
654 e <- expr2C expr |
655 cs <- mapM case2C cases |
655 cs <- mapM case2C cases |
656 d <- dflt |
656 d <- dflt |
657 return $ |
657 return $ |
658 text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) |
658 text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) |
659 where |
659 where |
660 case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
660 case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
661 case2C (e, p) = do |
661 case2C (e, p) = do |
662 ies <- mapM range2C e |
662 ies <- mapM range2C e |
663 ph <- phrase2C p |
663 ph <- phrase2C p |
664 return $ |
664 return $ |
665 vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") |
665 vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") |
666 dflt | isNothing mphrase = return [] |
666 dflt | isNothing mphrase = return [] |
667 | otherwise = do |
667 | otherwise = do |
668 ph <- mapM phrase2C $ fromJust mphrase |
668 ph <- mapM phrase2C $ fromJust mphrase |
669 return [text "default:" <+> nest 4 (vcat ph)] |
669 return [text "default:" <+> nest 4 (vcat ph)] |
670 |
670 |
671 phrase2C wb@(WithBlock ref p) = do |
671 phrase2C wb@(WithBlock ref p) = do |
672 r <- ref2C ref |
672 r <- ref2C ref |
673 t <- gets lastType |
673 t <- gets lastType |
674 case t of |
674 case t of |
675 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
675 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
676 a -> do |
676 a -> do |
677 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
677 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
678 phrase2C (ForCycle i' e1' e2' p) = do |
678 phrase2C (ForCycle i' e1' e2' p) = do |
679 i <- id2C IOLookup i' |
679 i <- id2C IOLookup i' |
680 e1 <- expr2C e1' |
680 e1 <- expr2C e1' |
681 e2 <- expr2C e2' |
681 e2 <- expr2C e2' |
682 ph <- phrase2C (wrapPhrase p) |
682 ph <- phrase2C (wrapPhrase p) |
683 return $ |
683 return $ |
684 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
684 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
685 $$ |
685 $$ |
686 ph |
686 ph |
687 phrase2C (RepeatCycle e' p') = do |
687 phrase2C (RepeatCycle e' p') = do |
688 e <- expr2C e' |
688 e <- expr2C e' |
730 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
730 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
731 (_, BTRecord t1 _, BTInt) -> do |
731 (_, BTRecord t1 _, BTInt) -> do |
732 -- aw, "LongInt" here is hwengine-specific hack |
732 -- aw, "LongInt" here is hwengine-specific hack |
733 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] |
733 i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] |
734 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
734 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
735 ("in", _, _) -> |
735 ("in", _, _) -> |
736 case expr2 of |
736 case expr2 of |
737 SetExpression set -> do |
737 SetExpression set -> do |
738 ids <- mapM (id2C IOLookup) set |
738 ids <- mapM (id2C IOLookup) set |
739 return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids |
739 return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids |
740 _ -> error "'in' against not set expression" |
740 _ -> error "'in' against not set expression" |
802 case lt of |
802 case lt of |
803 BTString -> return $ text "Length" <> parens e' |
803 BTString -> return $ text "Length" <> parens e' |
804 BTArray {} -> return $ text "length_ar" <> parens e' |
804 BTArray {} -> return $ text "length_ar" <> parens e' |
805 _ -> error $ "length() called on " ++ show lt |
805 _ -> error $ "length() called on " ++ show lt |
806 expr2C (BuiltInFunCall params ref) = do |
806 expr2C (BuiltInFunCall params ref) = do |
807 r <- ref2C ref |
807 r <- ref2C ref |
808 t <- gets lastType |
808 t <- gets lastType |
809 ps <- mapM expr2C params |
809 ps <- mapM expr2C params |
810 case t of |
810 case t of |
811 BTFunction _ t' -> do |
811 BTFunction _ t' -> do |
812 modify (\s -> s{lastType = t'}) |
812 modify (\s -> s{lastType = t'}) |
813 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
813 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
814 return $ |
814 return $ |
815 r <> parens (hsep . punctuate (char ',') $ ps) |
815 r <> parens (hsep . punctuate (char ',') $ ps) |
816 expr2C a = error $ "Don't know how to render " ++ show a |
816 expr2C a = error $ "Don't know how to render " ++ show a |
817 |
817 |
818 ref2CF :: Reference -> State RenderState Doc |
818 ref2CF :: Reference -> State RenderState Doc |
819 ref2CF (SimpleReference name) = do |
819 ref2CF (SimpleReference name) = do |
860 case t of |
860 case t of |
861 BTString -> return $ r <> text ".s" <> brackets e |
861 BTString -> return $ r <> text ".s" <> brackets e |
862 _ -> return $ r <> brackets e |
862 _ -> return $ r <> brackets e |
863 ref2C (SimpleReference name) = id2C IOLookup name |
863 ref2C (SimpleReference name) = id2C IOLookup name |
864 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
864 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
865 r1 <- ref2C ref1 |
865 r1 <- ref2C ref1 |
866 t <- fromPointer (show ref1) =<< gets lastType |
866 t <- fromPointer (show ref1) =<< gets lastType |
867 r2 <- case t of |
867 r2 <- case t of |
868 BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2 |
868 BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2 |
869 BTUnit -> error "What??" |
869 BTUnit -> error "What??" |
870 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
870 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
871 return $ |
871 return $ |
872 r1 <> text "->" <> r2 |
872 r1 <> text "->" <> r2 |
873 ref2C rf@(RecordField ref1 ref2) = do |
873 ref2C rf@(RecordField ref1 ref2) = do |
874 r1 <- ref2C ref1 |
874 r1 <- ref2C ref1 |
875 t <- gets lastType |
875 t <- gets lastType |
876 case t of |
876 case t of |
896 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
896 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
897 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
897 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
898 where |
898 where |
899 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
899 fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name |
900 fref2C a = ref2C a |
900 fref2C a = ref2C a |
901 |
901 |
902 ref2C (Address ref) = do |
902 ref2C (Address ref) = do |
903 r <- ref2C ref |
903 r <- ref2C ref |
904 return $ text "&" <> parens r |
904 return $ text "&" <> parens r |
905 ref2C (TypeCast t'@(Identifier i _) expr) = do |
905 ref2C (TypeCast t'@(Identifier i _) expr) = do |
906 lt <- expr2C expr >> gets lastType |
906 lt <- expr2C expr >> gets lastType |
907 case (map toLower i, lt) of |
907 case (map toLower i, lt) of |
908 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
908 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
909 ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) |
909 ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) |
910 (a, _) -> do |
910 (a, _) -> do |
911 e <- expr2C expr |
911 e <- expr2C expr |
912 t <- id2C IOLookup t' |
912 t <- id2C IOLookup t' |
913 return . parens $ parens t <> e |
913 return . parens $ parens t <> e |
914 ref2C (RefExpression expr) = expr2C expr |
914 ref2C (RefExpression expr) = expr2C expr |
915 |
915 |
916 |
916 |
917 op2C :: String -> String |
917 op2C :: String -> String |