152 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
152 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
153 writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
153 writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
154 initialState = emptyState ns |
154 initialState = emptyState ns |
155 |
155 |
156 render2C :: RenderState -> State RenderState Doc -> String |
156 render2C :: RenderState -> State RenderState Doc -> String |
157 render2C a = render . ($+$ text "") . flip evalState a |
157 render2C a = render . ($+$ empty) . flip evalState a |
158 |
158 |
159 usesFiles :: PascalUnit -> [String] |
159 usesFiles :: PascalUnit -> [String] |
160 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
160 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
161 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
161 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
162 usesFiles (System {}) = [] |
162 usesFiles (System {}) = [] |
582 expr2C (Expression s) = return $ text s |
582 expr2C (Expression s) = return $ text s |
583 expr2C (BinOp op expr1 expr2) = do |
583 expr2C (BinOp op expr1 expr2) = do |
584 e1 <- expr2C expr1 |
584 e1 <- expr2C expr1 |
585 t1 <- gets lastType |
585 t1 <- gets lastType |
586 e2 <- expr2C expr2 |
586 e2 <- expr2C expr2 |
587 case (op2C op, t1) of |
587 t2 <- gets lastType |
588 ("+", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString)) |
588 case (op2C op, t1, t2) of |
589 ("==", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
589 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString)) |
590 ("!=", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
590 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction BTString)) |
591 ("&", BTBool) -> return $ parens e1 <+> text "&&" <+> parens e2 |
591 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction BTString)) |
592 ("|", BTBool) -> return $ parens e1 <+> text "||" <+> parens e2 |
592 ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
593 (o, _) -> return $ parens e1 <+> text o <+> parens e2 |
593 ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
|
594 ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 |
|
595 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 |
|
596 (o, _, _) -> return $ parens e1 <+> text o <+> parens e2 |
594 expr2C (NumberLiteral s) = return $ text s |
597 expr2C (NumberLiteral s) = return $ text s |
595 expr2C (FloatLiteral s) = return $ text s |
598 expr2C (FloatLiteral s) = return $ text s |
596 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
599 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
597 expr2C (StringLiteral [a]) = return . quotes $ text [a] |
600 expr2C (StringLiteral [a]) = do |
|
601 modify(\s -> s{lastType = BTChar}) |
|
602 return . quotes $ text [a] |
598 expr2C (StringLiteral s) = addStringConst s |
603 expr2C (StringLiteral s) = addStringConst s |
599 expr2C (Reference ref) = ref2C ref |
604 expr2C (Reference ref) = ref2CF ref |
600 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
605 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
601 expr2C Null = return $ text "NULL" |
606 expr2C Null = return $ text "NULL" |
602 expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
607 expr2C (CharCode a) = do |
|
608 modify(\s -> s{lastType = BTChar}) |
|
609 return $ quotes $ text "\\x" <> text (showHex (read a) "") |
603 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
610 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
604 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
611 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
605 expr2C b@(BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
612 |
|
613 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
606 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
614 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
|
615 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e |
607 expr2C (BuiltInFunCall params ref) = do |
616 expr2C (BuiltInFunCall params ref) = do |
608 r <- ref2C ref |
617 r <- ref2C ref |
|
618 t <- gets lastType |
609 ps <- mapM expr2C params |
619 ps <- mapM expr2C params |
|
620 case t of |
|
621 BTFunction t' -> do |
|
622 modify (\s -> s{lastType = t'}) |
|
623 _ -> error $ "BuiltInFunCall lastType: " ++ show t |
610 return $ |
624 return $ |
611 r <> parens (hsep . punctuate (char ',') $ ps) |
625 r <> parens (hsep . punctuate (char ',') $ ps) |
612 expr2C a = error $ "Don't know how to render " ++ show a |
626 expr2C a = error $ "Don't know how to render " ++ show a |
613 |
627 |
|
628 ref2CF :: Reference -> State RenderState Doc |
|
629 ref2CF (SimpleReference name) = do |
|
630 i <- id2C IOLookup name |
|
631 t <- gets lastType |
|
632 case t of |
|
633 BTFunction _ -> return $ i <> parens empty |
|
634 _ -> return $ i |
|
635 ref2CF r = ref2C r |
614 |
636 |
615 ref2C :: Reference -> State RenderState Doc |
637 ref2C :: Reference -> State RenderState Doc |
616 -- rewrite into proper form |
638 -- rewrite into proper form |
617 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
639 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
618 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
640 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
661 ref2C d@(Dereference ref) = do |
683 ref2C d@(Dereference ref) = do |
662 r <- ref2C ref |
684 r <- ref2C ref |
663 t <- fromPointer (show d) =<< gets lastType |
685 t <- fromPointer (show d) =<< gets lastType |
664 modify (\st -> st{lastType = t}) |
686 modify (\st -> st{lastType = t}) |
665 return $ (parens $ text "*" <> r) |
687 return $ (parens $ text "*" <> r) |
666 ref2C (FunCall params ref) = do |
688 ref2C f@(FunCall params ref) = do |
667 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
|
668 r <- ref2C ref |
689 r <- ref2C ref |
669 t <- gets lastType |
690 t <- gets lastType |
670 case t of |
691 case t of |
671 BTFunction t -> do |
692 BTFunction t' -> do |
672 modify (\s -> s{lastType = t}) |
693 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
|
694 modify (\s -> s{lastType = t'}) |
673 return $ r <> ps |
695 return $ r <> ps |
674 _ -> return $ parens r <> ps |
696 _ -> case (ref, params) of |
|
697 (SimpleReference i, [p]) -> ref2C $ TypeCast i p |
|
698 _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t |
675 |
699 |
676 ref2C (Address ref) = do |
700 ref2C (Address ref) = do |
677 r <- ref2C ref |
701 r <- ref2C ref |
678 return $ text "&" <> parens r |
702 return $ text "&" <> parens r |
679 ref2C (TypeCast t' expr) = do |
703 ref2C (TypeCast t'@(Identifier i _) expr) = do |
680 t <- id2C IOLookup t' |
704 case map toLower i of |
681 e <- expr2C expr |
705 "pchar" -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) |
682 return $ parens t <> e |
706 a -> do |
|
707 e <- expr2C expr |
|
708 t <- id2C IOLookup t' |
|
709 return $ parens t <> e |
683 ref2C (RefExpression expr) = expr2C expr |
710 ref2C (RefExpression expr) = expr2C expr |
684 |
711 |
685 |
712 |
686 op2C :: String -> String |
713 op2C :: String -> String |
687 op2C "or" = "|" |
714 op2C "or" = "|" |