diff -r b34288c8fafa -r 608c8b057c3b tools/pas2c.hs --- a/tools/pas2c.hs Thu Apr 05 14:50:58 2012 +0400 +++ b/tools/pas2c.hs Thu Apr 05 14:58:34 2012 +0400 @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Pas2C where import Text.PrettyPrint.HughesPJ @@ -13,6 +14,7 @@ import System.IO.Error import qualified Data.Map as Map import Data.List (find) +import Numeric import PascalParser import PascalUnitSyntaxTree @@ -323,6 +325,9 @@ initExpr2C :: InitExpression -> State RenderState Doc +initExpr2C InitNull = return $ text "NULL" +initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr) +initExpr2C (InitPrefixOp op expr) = liftM2 (<>) (op2C op) (initExpr2C expr) initExpr2C (InitBinOp op expr1 expr2) = do e1 <- initExpr2C expr1 e2 <- initExpr2C expr2 @@ -332,8 +337,16 @@ initExpr2C (InitFloat s) = return $ text s initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) initExpr2C (InitString s) = return $ doubleQuotes $ text s +initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") initExpr2C (InitReference i) = id2C IOLookup i -initExpr2C _ = return $ text "<>" +initExpr2C (InitRecord fields) = do + (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields + return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace +initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values +initExpr2C (InitRange _) = return $ text "<>" +initExpr2C (InitSet _) = return $ text "<>" +initExpr2C (BuiltInFunction {}) = return $ text "<>" +initExpr2C a = error $ "Don't know how to render " ++ show a type2C :: TypeDecl -> State RenderState Doc @@ -350,15 +363,25 @@ type2C' (PointerTo t) = liftM (<> text "*") $ type2C t type2C' (RecordType tvs union) = do t <- withState' id $ mapM (tvar2C False) tvs - return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" + return $ lbrace $+$ (nest 4 . vcat $ t) $+$ rbrace type2C' (RangeType r) = return $ text "<>" type2C' (Sequence ids) = do mapM_ (id2C IOInsert) ids return $ text "<>" - type2C' (ArrayDecl r t) = return $ text "<>" + type2C' (ArrayDecl r t) = do + t' <- type2C t + return $ t' <> brackets (text "<>") type2C' (Set t) = return $ text "<>" type2C' (FunctionType returnType params) = return $ text "<>" - type2C' (DeriveType _) = return $ text "<>" + type2C' (DeriveType (InitBinOp {})) = return $ text "int" + type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) + type2C' (DeriveType (InitNumber _)) = return $ text "int" + type2C' (DeriveType (InitHexNumber _)) = return $ text "int" + type2C' (DeriveType (InitFloat _)) = return $ text "float" + type2C' (DeriveType (BuiltInFunction {})) = return $ text "int" + type2C' (DeriveType (InitString {})) = return $ text "string255" + type2C' (DeriveType (InitReference {})) = return $ text "<>" + type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a phrase2C :: Phrase -> State RenderState Doc phrase2C (Phrases p) = do @@ -441,22 +464,26 @@ expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) expr2C (StringLiteral s) = return $ doubleQuotes $ text s expr2C (Reference ref) = ref2C ref -expr2C (PrefixOp op expr) = liftM2 (<+>) (op2C op) (expr2C expr) +expr2C (PrefixOp op expr) = liftM2 (<>) (op2C op) (expr2C expr) expr2C Null = return $ text "NULL" expr2C (BuiltInFunCall params ref) = do r <- ref2C ref ps <- mapM expr2C params return $ r <> parens (hsep . punctuate (char ',') $ ps) -expr2C _ = return $ text "<>" +expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") +expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) +expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") +expr2C a = error $ "Don't know how to render " ++ show a ref2C :: Reference -> State RenderState Doc -- rewrite into proper form -ref2C r@(RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) -ref2C r@(RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) -ref2C r@(RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 -ref2C r@(RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) +ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) +ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) +ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 +ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) +ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) -- conversion routines ref2C ae@(ArrayElement exprs ref) = do es <- mapM expr2C exprs @@ -464,10 +491,6 @@ t <- gets lastType ns <- gets currentScope case t of - (BTArray _ ta@(BTArray _ t')) - | length exprs == 2 -> modify (\st -> st{lastType = t'}) - | length exprs == 1 -> modify (\st -> st{lastType = ta}) - | otherwise -> error $ "Array has more than two dimensions" (BTArray _ t') -> modify (\st -> st{lastType = t'}) (BTString) -> modify (\st -> st{lastType = BTChar}) a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) @@ -531,5 +554,3 @@ op2C "=" = return $ text "==" op2C a = return $ text a -maybeVoid "" = "void" -maybeVoid a = a