422 modify (\st -> st{lastType = rt}) |
422 modify (\st -> st{lastType = rt}) |
423 return r |
423 return r |
424 where |
424 where |
425 type2C' VoidType = return (text "void" <+>) |
425 type2C' VoidType = return (text "void" <+>) |
426 type2C' (String l) = return (text ("string" ++ show l) <+>) |
426 type2C' (String l) = return (text ("string" ++ show l) <+>) |
427 type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct" <+> i <+> text "*" <+> a) $ id2C IODeferred i |
427 type2C' (PointerTo (SimpleType i)) = liftM (\i a -> text "struct __" <> i <+> text "*" <+> a) $ id2C IODeferred i |
428 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
428 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
429 type2C' (RecordType tvs union) = do |
429 type2C' (RecordType tvs union) = do |
430 t <- withState' id $ mapM (tvar2C False) tvs |
430 t <- withState' id $ mapM (tvar2C False) tvs |
431 u <- unions |
431 u <- unions |
432 return $ \i -> text "struct" <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i |
432 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i |
433 where |
433 where |
434 unions = case union of |
434 unions = case union of |
435 Nothing -> return empty |
435 Nothing -> return empty |
436 Just a -> do |
436 Just a -> do |
437 structs <- mapM struct2C a |
437 structs <- mapM struct2C a |
531 e <- expr2C e' |
531 e <- expr2C e' |
532 p <- phrase2C (Phrases p') |
532 p <- phrase2C (Phrases p') |
533 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) |
533 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) |
534 phrase2C NOP = return $ text ";" |
534 phrase2C NOP = return $ text ";" |
535 |
535 |
|
536 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = return $ text "return" <> semi |
|
537 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <> e <> semi) $ expr2C e |
|
538 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e |
|
539 phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2) |
|
540 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e |
|
541 phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2) |
|
542 phrase2C a = error $ "phrase2C: " ++ show a |
536 |
543 |
537 wrapPhrase p@(Phrases _) = p |
544 wrapPhrase p@(Phrases _) = p |
538 wrapPhrase p = Phrases [p] |
545 wrapPhrase p = Phrases [p] |
539 |
546 |
540 expr2C :: Expression -> State RenderState Doc |
547 expr2C :: Expression -> State RenderState Doc |
545 e2 <- expr2C expr2 |
552 e2 <- expr2C expr2 |
546 case (op2C op, t1) of |
553 case (op2C op, t1) of |
547 ("+", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString)) |
554 ("+", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString)) |
548 ("==", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
555 ("==", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool)) |
549 ("!=", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
556 ("!=", BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool)) |
550 ("&", BTBool) -> return $ parens $ e1 <+> text "&&" <+> e2 |
557 ("&", BTBool) -> return $ parens e1 <+> text "&&" <+> parens e2 |
551 ("|", BTBool) -> return $ parens $ e1 <+> text "||" <+> e2 |
558 ("|", BTBool) -> return $ parens e1 <+> text "||" <+> parens e2 |
552 (o, _) -> return $ parens $ e1 <+> text o <+> e2 |
559 (o, _) -> return $ parens e1 <+> text o <+> parens e2 |
553 expr2C (NumberLiteral s) = return $ text s |
560 expr2C (NumberLiteral s) = return $ text s |
554 expr2C (FloatLiteral s) = return $ text s |
561 expr2C (FloatLiteral s) = return $ text s |
555 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
562 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
556 expr2C (StringLiteral [a]) = return . quotes $ text [a] |
563 expr2C (StringLiteral [a]) = return . quotes $ text [a] |
557 expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
564 expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
558 expr2C (Reference ref) = ref2C ref |
565 expr2C (Reference ref) = ref2C ref |
559 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
566 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
560 expr2C Null = return $ text "NULL" |
567 expr2C Null = return $ text "NULL" |
|
568 expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
|
569 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
|
570 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
|
571 expr2C b@(BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
|
572 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
561 expr2C (BuiltInFunCall params ref) = do |
573 expr2C (BuiltInFunCall params ref) = do |
562 r <- ref2C ref |
574 r <- ref2C ref |
563 ps <- mapM expr2C params |
575 ps <- mapM expr2C params |
564 return $ |
576 return $ |
565 r <> parens (hsep . punctuate (char ',') $ ps) |
577 r <> parens (hsep . punctuate (char ',') $ ps) |
566 expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
|
567 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
|
568 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
|
569 expr2C a = error $ "Don't know how to render " ++ show a |
578 expr2C a = error $ "Don't know how to render " ++ show a |
570 |
579 |
571 |
580 |
572 ref2C :: Reference -> State RenderState Doc |
581 ref2C :: Reference -> State RenderState Doc |
573 -- rewrite into proper form |
582 -- rewrite into proper form |
575 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
584 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
576 ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
585 ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
577 ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
586 ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
578 ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) |
587 ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) |
579 -- conversion routines |
588 -- conversion routines |
580 ref2C ae@(ArrayElement exprs ref) = do |
589 ref2C ae@(ArrayElement [expr] ref) = do |
581 es <- mapM expr2C exprs |
590 e <- expr2C expr |
582 r <- ref2C ref |
591 r <- ref2C ref |
583 t <- gets lastType |
592 t <- gets lastType |
584 ns <- gets currentScope |
593 ns <- gets currentScope |
585 case t of |
594 case t of |
586 (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) |
595 (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) |
589 t'' <- fromPointer (show t) =<< gets lastType |
598 t'' <- fromPointer (show t) =<< gets lastType |
590 case t'' of |
599 case t'' of |
591 BTChar -> modify (\st -> st{lastType = BTChar}) |
600 BTChar -> modify (\st -> st{lastType = BTChar}) |
592 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
601 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
593 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
602 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
594 return $ r <> (brackets . hcat) (punctuate comma es) |
603 case t of |
|
604 BTString -> return $ r <> text ".s" <> brackets e |
|
605 _ -> return $ r <> brackets e |
595 ref2C (SimpleReference name) = id2C IOLookup name |
606 ref2C (SimpleReference name) = id2C IOLookup name |
596 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
607 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
597 r1 <- ref2C ref1 |
608 r1 <- ref2C ref1 |
598 t <- fromPointer (show ref1) =<< gets lastType |
609 t <- fromPointer (show ref1) =<< gets lastType |
599 ns <- gets currentScope |
610 ns <- gets currentScope |