47 addStringConst :: String -> State RenderState Doc |
47 addStringConst :: String -> State RenderState Doc |
48 addStringConst str = do |
48 addStringConst str = do |
49 strs <- gets stringConsts |
49 strs <- gets stringConsts |
50 let a = find ((==) str . snd) strs |
50 let a = find ((==) str . snd) strs |
51 if isJust a then |
51 if isJust a then |
|
52 do |
|
53 modify (\s -> s{lastType = BTString}) |
52 return . text . fst . fromJust $ a |
54 return . text . fst . fromJust $ a |
53 else |
55 else |
54 do |
56 do |
55 i <- getUniq |
57 i <- getUniq |
56 let sn = "__str" ++ show i |
58 let sn = "__str" ++ show i |
461 rt <- resolveType t |
463 rt <- resolveType t |
462 modify (\st -> st{lastType = rt}) |
464 modify (\st -> st{lastType = rt}) |
463 return r |
465 return r |
464 where |
466 where |
465 type2C' VoidType = return (text "void" <+>) |
467 type2C' VoidType = return (text "void" <+>) |
466 type2C' (String l) = return (text ("string" ++ show l) <+>) |
468 type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>) |
467 type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct __" <> i <+> text "*" <+> a) $ id2C IODeferred i |
469 type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct __" <> i <+> text "*" <+> a) $ id2C IODeferred i |
468 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
470 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
469 type2C' (RecordType tvs union) = do |
471 type2C' (RecordType tvs union) = do |
470 t <- withState' id $ mapM (tvar2C False) tvs |
472 t <- withState' id $ mapM (tvar2C False) tvs |
471 u <- unions |
473 u <- unions |
508 phrase2C :: Phrase -> State RenderState Doc |
510 phrase2C :: Phrase -> State RenderState Doc |
509 phrase2C (Phrases p) = do |
511 phrase2C (Phrases p) = do |
510 ps <- mapM phrase2C p |
512 ps <- mapM phrase2C p |
511 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
513 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
512 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
514 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
513 phrase2C (ProcCall ref params) = do |
515 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref |
|
516 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do |
514 r <- ref2C ref |
517 r <- ref2C ref |
515 ps <- mapM expr2C params |
518 ps <- mapM expr2C params |
516 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi |
519 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -} |
517 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
520 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do |
518 e <- expr2C expr |
521 e <- expr2C expr |
519 p1 <- (phrase2C . wrapPhrase) phrase1 |
522 p1 <- (phrase2C . wrapPhrase) phrase1 |
520 el <- elsePart |
523 el <- elsePart |
521 return $ |
524 return $ |
522 text "if" <> parens e $+$ p1 $+$ el |
525 text "if" <> parens e $+$ p1 $+$ el |
523 where |
526 where |
524 elsePart | isNothing mphrase2 = return $ empty |
527 elsePart | isNothing mphrase2 = return $ empty |
525 | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
528 | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) |
526 phrase2C (Assignment ref expr) = do |
529 phrase2C (Assignment ref expr) = do |
527 r <- ref2C ref |
530 r <- ref2C ref |
528 e <- expr2C expr |
531 t <- gets lastType |
529 return $ |
532 e <- case (t, expr) of |
530 r <> text " = " <> e <> semi |
533 (BTFunction _, (Reference r')) -> ref2C r' |
|
534 _ -> expr2C expr |
|
535 return $ r <+> text "=" <+> e <> semi |
531 phrase2C (WhileCycle expr phrase) = do |
536 phrase2C (WhileCycle expr phrase) = do |
532 e <- expr2C expr |
537 e <- expr2C expr |
533 p <- phrase2C $ wrapPhrase phrase |
538 p <- phrase2C $ wrapPhrase phrase |
534 return $ text "while" <> parens e $$ p |
539 return $ text "while" <> parens e $$ p |
535 phrase2C (SwitchCase expr cases mphrase) = do |
540 phrase2C (SwitchCase expr cases mphrase) = do |
597 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction BTString)) |
602 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction BTString)) |
598 ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
603 ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
599 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
604 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
600 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
605 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
601 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
606 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
602 (o, _, _) -> return $ parens e1 <+> text o <+> parens e2 |
607 (o, _, _) | o `elem` boolOps -> do |
|
608 modify(\s -> s{lastType = BTBool}) |
|
609 return $ parens e1 <+> text o <+> parens e2 |
|
610 | otherwise -> return $ parens e1 <+> text o <+> parens e2 |
|
611 where |
|
612 boolOps = ["==", "!=", "<", ">", "<=", ">="] |
603 expr2C (NumberLiteral s) = return $ text s |
613 expr2C (NumberLiteral s) = return $ text s |
604 expr2C (FloatLiteral s) = return $ text s |
614 expr2C (FloatLiteral s) = return $ text s |
605 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
615 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
606 expr2C (StringLiteral [a]) = do |
616 expr2C (StringLiteral [a]) = do |
607 modify(\s -> s{lastType = BTChar}) |
617 modify(\s -> s{lastType = BTChar}) |