--- /dev/null
+Abstract syntax for Java subset that is the target of Mondrian.
+The syntax has been taken from "The Java Language Specification".
+
+(c) Erik Meijer & Arjan van IJzendoorn
+
+November 1999
+
+\begin{code}
+module Java where
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Java type declararations}
+%* *
+%************************************************************************
+
+\begin{code}
+data CompilationUnit
+ = Package Name [Decl]
+ deriving (Show)
+
+data Decl
+ = Import Name
+ | Field [Modifier] Type Name (Maybe Expr)
+ | Constructor [Modifier] Name [Parameter] [Statement]
+ | Method [Modifier] Type Name [Parameter] [Statement]
+ | Comment [String]
+ | Interface [Modifier] Name [Name] [Decl]
+ | Class [Modifier] Name [Name] [Name] [Decl]
+ deriving (Show)
+
+data Parameter
+ = Parameter [Modifier] Type Name
+ deriving (Show)
+
+data Statement
+ = Skip
+ | Return Expr
+ | Block [Statement]
+ | ExprStatement Expr
+ | Declaration Decl -- variable = inner Field, Class = innerclass
+ | IfThenElse [(Expr,Statement)] (Maybe Statement)
+ | Switch Expr [(Expr, [Statement])] (Maybe [Statement])
+ deriving (Show)
+
+data Expr
+ = Var Name
+ | Literal Lit
+ | Cast Type Expr
+ | Access Expr Name
+ | Assign Expr Expr
+ | InstanceOf Expr Type
+ | Call Expr Name [Expr]
+ | Op Expr String Expr
+ | New Name [Expr] (Maybe [Decl]) -- anonymous innerclass
+ | NewArray Name [Expr]
+ deriving (Show)
+
+data Type
+ = Type Name
+ | Array Type
+ deriving (Show)
+
+data Modifier
+ = Public | Protected | Private
+ | Static
+ | Abstract | Final | Native | Synchronized | Transient | Volatile
+ deriving (Show, Eq, Ord)
+
+type Name = [String]
+
+data Lit
+ = IntLit Int -- Boxed
+ | UIntLit Int -- Unboxed
+ | CharLit Char -- Boxed
+ | UCharLit Char -- Unboxed
+ | StringLit String
+ deriving Show
+
+addModifier :: Modifier -> Decl -> Decl
+addModifier = \m -> \d ->
+ case d of
+ { Import n -> Import n
+ ; Field ms t n e -> Field (m:ms) t n e
+ ; Constructor ms n as ss -> Constructor (m:ms) n as ss
+ ; Method ms t n as ss -> Method (m:ms) t n as ss
+ ; Comment ss -> Comment ss
+ ; Interface ms n xs ds -> Interface (m:ms) n xs ds
+ ; Class ms n xs is ds -> Class (m:ms) n xs is ds
+ }
+
+areSimple :: [Expr] -> Bool
+areSimple = \es -> all isSimple es
+
+isSimple :: Expr -> Bool
+isSimple = \e ->
+ case e of
+ { Cast t e -> isSimple e
+ ; Access e n -> isSimple e
+ ; Assign l r -> isSimple l && isSimple r
+ ; InstanceOf e t -> isSimple e
+ ; Call e n es -> isSimple e && areSimple es
+ ; Op e1 o e2 -> False
+ ; New n es Nothing -> areSimple es
+ ; New n es (Just ds) -> False
+ ; otherwise -> True
+ }
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section{Generate Java}
+
+\begin{code}
+module JavaGen( javaGen ) where
+
+import Java
+
+import Literal ( Literal(..) )
+import Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder )
+import Name ( NamedThing(..), getOccString, isGlobalName )
+import DataCon ( DataCon, dataConRepArity, dataConId )
+import qualified CoreSyn
+import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
+ Bind(..), Alt, AltCon(..), collectBinders, isValArg
+ )
+import CoreUtils( exprIsValue, exprIsTrivial )
+import Module ( Module, moduleString )
+import TyCon ( TyCon, isDataTyCon, tyConDataCons )
+import Outputable
+
+#include "HsVersions.h"
+
+\end{code}
+
+
+\begin{code}
+javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
+
+javaGen mod import_mods tycons binds
+ = Package [moduleString mod] decls
+ where
+ decls = [Import [moduleString mod] | mod <- import_mods] ++
+ concat (map javaTyCon (filter isDataTyCon tycons)) ++
+ concat (map javaTopBind binds)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Type declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+javaTyCon :: TyCon -> [Decl]
+-- public class List {}
+--
+-- public class $wCons extends List {
+-- Object f1; Object f2
+-- }
+-- public class $wNil extends List {}
+
+javaTyCon tycon
+ = tycon_jclass : map constr_class constrs
+ where
+ constrs = tyConDataCons tycon
+ tycon_jclass_jname = javaName tycon
+ tycon_jclass = Class [Public] tycon_jclass_jname [] [] []
+
+ constr_class data_con
+ = Class [Public] constr_jname [tycon_jclass_jname] [] field_decls
+ where
+ constr_jname = javaConstrWkrName data_con
+ enter_meth = Method [Public] objectType enterName [] stmts
+ n_val_args = dataConRepArity data_con
+ field_names = map fieldName [1..n_val_args]
+ field_decls = [Field [Public] objectType f Nothing | f <- field_names]
+ stmts = vmCOLLECT n_val_args (Var thisName) ++
+ [var [Final] objectType f vmPOP | f <- field_names] ++
+ [Return (New constr_jname (map Var field_names) Nothing)]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Bindings}
+%* *
+%************************************************************************
+
+\begin{code}
+javaTopBind :: CoreBind -> [Decl]
+javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
+javaTopBind (Rec prs) = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
+
+java_top_bind :: Id -> CoreExpr -> Decl
+-- public class f implements Code {
+-- public Object ENTER() { ...translation of rhs... }
+-- }
+java_top_bind bndr rhs
+ = Class [Public] (javaName bndr) [] [codeName] [enter_meth]
+ where
+ enter_meth = Method [Public] objectType enterName [] (javaExpr rhs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+javaVar :: Id -> Expr
+javaVar v | isGlobalName (idName v) = New (javaName v) [] Nothing
+ | otherwise = Var (javaName v)
+
+
+javaLit :: Literal.Literal -> Lit
+javaLit (MachInt i) = UIntLit (fromInteger i)
+javaLit (MachChar c) = UCharLit c
+javaLit other = pprPanic "javaLit" (ppr other)
+
+javaExpr :: CoreExpr -> [Statement]
+-- Generate code to apply the value of
+-- the expression to the arguments aleady on the stack
+javaExpr (CoreSyn.Var v) = [Return (javaVar v)]
+javaExpr (CoreSyn.Lit l) = [Return (Literal (javaLit l))]
+javaExpr (CoreSyn.App f a) = javaApp f [a]
+javaExpr e@(CoreSyn.Lam _ _) = javaLam (collectBinders e)
+javaExpr (CoreSyn.Case e x alts) = javaCase e x alts
+javaExpr (CoreSyn.Let bind body) = javaBind bind ++ javaExpr body
+javaExpr (CoreSyn.Note _ e) = javaExpr e
+
+javaCase :: CoreExpr -> Id -> [CoreAlt] -> [Statement]
+-- case e of x { Nil -> r1
+-- Cons p q -> r2 }
+-- ==>
+-- final Object x = VM.WHNF(...code for e...)
+-- else if x instance_of Nil {
+-- ...translation of r1...
+-- } else if x instance_of Cons {
+-- final Object p = ((Cons) x).f1
+-- final Object q = ((Cons) x).f2
+-- ...translation of r2...
+-- } else return null
+
+javaCase e x alts
+ = [var [Final] objectType (javaName x) (vmWHNF (javaArg e)),
+ IfThenElse (map mk_alt alts) Nothing]
+ where
+ mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr rhs))
+ mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr rhs))
+ mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
+
+ bind_args d bs = [var [Final] objectType (javaName b)
+ (Access (Cast (Type (javaConstrWkrName d)) (javaVar x)) f)
+ | (b, f) <- filter isId bs `zip` map fieldName [1..],
+ not (isDeadBinder b)
+ ]
+
+javaBind (NonRec x rhs)
+{-
+ x = ...rhs_x...
+ ==>
+ final Object x = new Thunk( new Code() { ...code for rhs_x... } )
+-}
+ = [var [Final] objectType (javaName x) (javaArg rhs)]
+
+javaBind (Rec prs)
+{- rec { x = ...rhs_x...; y = ...rhs_y... }
+ ==>
+ class x implements Code {
+ Code x, y;
+ public Object ENTER() { ...code for rhs_x...}
+ }
+ ...ditto for y...
+
+ final x x_inst = new x();
+ ...ditto for y...
+
+ final Thunk x = new Thunk( x_inst );
+ ...ditto for y...
+
+ x_inst.x = x;
+ x_inst.y = y;
+ ...ditto for y...
+-}
+ = (map mk_class prs) ++ (map mk_inst prs) ++
+ (map mk_thunk prs) ++ concat (map mk_knot prs)
+ where
+ mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts)
+ where
+ stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
+ [Method [Public] objectType enterName [] (javaExpr r)]
+
+ mk_inst (b,r) = var [Final] (Type (javaName b)) (javaInstName b)
+ (New (javaName b) [] Nothing)
+
+ mk_thunk (b,r) = var [Final] thunkType (javaName b)
+ (New thunkName [Var (javaInstName b)] Nothing)
+
+ mk_knot (b,_) = [ExprStatement (Assign lhs rhs)
+ | (b',_) <- prs,
+ let lhs = Access (Var (javaInstName b)) (javaName b'),
+ let rhs = Var (javaName b')
+ ]
+
+javaLam :: ([CoreBndr], CoreExpr) -> [Statement]
+javaLam (bndrs, body)
+ | null val_bndrs = javaExpr body
+ | otherwise
+ = vmCOLLECT (length val_bndrs) (Var thisName)
+ ++ [var [Final] objectType (javaName n) vmPOP | n <- val_bndrs]
+ ++ javaExpr body
+ where
+ val_bndrs = filter isId bndrs
+
+javaApp :: CoreExpr -> [CoreExpr] -> [Statement]
+javaApp (CoreSyn.App f a) as = javaApp f (a:as)
+javaApp (CoreSyn.Var f) as
+ = case isDataConId_maybe f of {
+ Just dc | length as == dataConRepArity dc
+ -> -- Saturated constructors
+ [Return (New (javaName f) (javaArgs as) Nothing)]
+
+ ; other -> -- Not a saturated constructor
+ java_apply (CoreSyn.Var f) as
+ }
+
+javaApp f as = java_apply f as
+
+java_apply :: CoreExpr -> [CoreExpr] -> [Statement]
+java_apply f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr f
+
+javaArgs :: [CoreExpr] -> [Expr]
+javaArgs args = [javaArg a | a <- args, isValArg a]
+
+javaArg :: CoreExpr -> Expr
+javaArg (CoreSyn.Type t) = pprPanic "javaArg" (ppr t)
+javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr e)
+ | otherwise = newThunk (newCode (javaExpr e))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Helper functions}
+%* *
+%************************************************************************
+
+\begin{code}
+true, this :: Expr
+this = Var thisName
+
+true = Var ["true"]
+
+vmCOLLECT :: Int -> Expr -> [Statement]
+vmCOLLECT 0 e = []
+vmCOLLECT n e = [ExprStatement (Call (Var vmName) ["COLLECT"] [Literal (IntLit n), e])]
+
+vmPOP :: Expr
+vmPOP = Call (Var vmName) ["POP"] []
+
+vmPUSH :: Expr -> Expr
+vmPUSH e = Call (Var vmName) ["PUSH"] [e]
+
+var :: [Modifier] -> Type -> Name -> Expr -> Statement
+var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
+
+vmWHNF :: Expr -> Expr
+vmWHNF e = Call (Var vmName) ["WHNF"] [e]
+
+instanceOf :: Id -> DataCon -> Expr
+instanceOf x data_con
+ = InstanceOf (Var (javaName x)) (Type (javaConstrWkrName data_con))
+
+newCode :: [Statement] -> Expr
+newCode [Return e] = e
+newCode stmts = New codeName [] (Just [Method [Public] objectType enterName [] stmts])
+
+newThunk :: Expr -> Expr
+newThunk e = New thunkName [e] Nothing
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Name mangling}
+%* *
+%************************************************************************
+
+\begin{code}
+codeName, enterName, vmName :: Name
+codeName = ["Code"]
+thunkName = ["Thunk"]
+enterName = ["ENTER"]
+vmName = ["VM"]
+thisName = ["this"]
+
+fieldName :: Int -> Name -- Names for fields of a constructor
+fieldName n = ["f" ++ show n]
+
+javaName :: NamedThing a => a -> Name
+javaName n = [getOccString n]
+
+javaConstrWkrName :: DataCon -> Name
+-- The function that makes the constructor
+javaConstrWkrName con = [getOccString (dataConId con)]
+
+javaInstName :: NamedThing a => a -> Name
+-- Makes x_inst for Rec decls
+javaInstName n = [getOccString n ++ "_inst"]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Type mangling}
+%* *
+%************************************************************************
+
+\begin{code}
+codeType, thunkType, objectType :: Type
+objectType = Type ["Object"]
+codeType = Type codeName
+thunkType = Type thunkName
+\end{code}
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section{Generate Java}
+
+\begin{code}
+module PrintJava( compilationUnit ) where
+
+import Java
+import Outputable
+import Char( toLower )
+\end{code}
+
+\begin{code}
+indent :: SDoc -> SDoc
+indent = nest 2
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Pretty printer}
+%* *
+%************************************************************************
+
+\begin{code}
+compilationUnit :: CompilationUnit -> SDoc
+compilationUnit (Package n ds) = package n (decls ds)
+
+package = \n -> \ds ->
+ text "package" <+> name n <> text ";"
+ $$
+ ds
+
+decls [] = empty
+decls (d:ds) = decl d $$ decls ds
+
+decl = \d ->
+ case d of
+ { Import n -> importDecl (name n)
+ ; Field mfs t n e -> field (modifiers mfs) (typ t) (name n) e
+ ; Constructor mfs n as ss -> constructor (modifiers mfs) (name n) (parameters as) (statements ss)
+ ; Method mfs t n as ss -> method (modifiers mfs) (typ t) (name n) (parameters as) (statements ss)
+ ; Comment s -> comment s
+ ; Interface mfs n is ms -> interface (modifiers mfs) (name n) (extends is) (decls ms)
+ ; Class mfs n x is ms -> clazz (modifiers mfs) (name n) (extends x) (implements is) (decls ms)
+ }
+
+importDecl n = text "import" <+> n <> text ";"
+
+field = \mfs -> \t -> \n -> \e ->
+ case e of
+ { Nothing -> mfs <+> t <+> n <> text ";"
+ ; Just e -> lay [mfs <+> t <+> n <+> text "=", indent (expr e <> text ";")]
+ where
+ lay | isSimple e = hsep
+ | otherwise = sep
+ }
+
+constructor = \mfs -> \n -> \as -> \ss ->
+ mfs <+> n <+> parens (hsep (punctuate comma as)) <+> text "{"
+ $$ indent ss
+ $$ text "}"
+
+method = \mfs -> \t -> \n -> \as -> \ss ->
+ mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> text "{"
+ $$ indent ss
+ $$ text "}"
+
+comment = \ss ->
+ text "/**"
+ $$ indent (vcat [ text s | s <- ss])
+ $$ text "**/"
+
+interface = \mfs -> \n -> \xs -> \ms ->
+ mfs <+> n <+> xs <+> text "{"
+ $$ indent ms
+ $$ text "}"
+
+clazz = \mfs -> \n -> \x -> \is -> \ms ->
+ mfs <+> text "class" <+> n <+> x <+> is <+> text "{"
+ $$ indent ms
+ $$ text "}"
+
+staticblock = \ss ->
+ text "static" <+> text "{"
+ $$ indent ss
+ $$ text "}"
+
+modifiers mfs = hsep (map modifier mfs)
+
+modifier mf = text $ map toLower (show mf)
+
+extends [] = empty
+extends xs = text "extends" <+> hsep (punctuate comma (map name xs))
+
+implements [] = empty
+implements xs = text "implements" <+> hsep (punctuate comma (map name xs))
+
+name ns = hcat (punctuate dot (map text ns))
+
+parameters as = map parameter as
+
+parameter (Parameter mfs t n) = modifiers mfs <+> typ t <+> name n
+
+typ (Type n) = name n
+typ (Array t) = typ t <> text "[]"
+
+statements ss = vcat (map statement ss)
+
+statement = \s ->
+ case s of
+ { Skip -> skip
+ ; Return e -> returnStat (expr e)
+ ; Block ss -> vcat [statement s | s <- ss]
+ ; ExprStatement e -> exprStatement (expr e)
+ ; Declaration d -> declStatement (decl d)
+ ; IfThenElse ecs s -> ifthenelse [ (expr e, statement s) | (e,s) <- ecs ] (maybe Nothing (Just .statement) s)
+ ; Switch e as d -> switch (expr e) (arms as) (deflt d)
+ }
+
+skip = empty
+
+returnStat e = sep [text "return", indent e <> semi]
+
+exprStatement e = e <> semi
+
+declStatement d = d
+
+ifthenelse ((e,s):ecs) ms = sep [text "if",
+ indent (parens e) <+> text "{",
+ indent s,
+ thenelse ecs ms]
+
+thenelse ((e,s):ecs) ms = sep [ text "} else if",
+ indent (parens e) <+> text "{",
+ indent s,
+ thenelse ecs ms]
+
+thenelse [] Nothing = text "}"
+thenelse [] (Just s) = sep [text "} else {", indent s, text "}"]
+
+switch = \e -> \as -> \d ->
+ text "switch" <+> parens e <+> text "{"
+ $$ indent (as $$ d)
+ $$ text "}"
+
+deflt Nothing = empty
+deflt (Just ss) = text "default:" $$ indent (statements ss)
+
+arms [] = empty
+arms ((e,ss):as) = text "case" <+> expr e <> colon
+ $$ indent (statements ss)
+ $$ arms as
+
+maybeExpr Nothing = Nothing
+maybeExpr (Just e) = Just (expr e)
+
+expr = \e ->
+ case e of
+ { Var n -> name n
+ ; Literal l -> literal l
+ ; Cast t e -> cast (typ t) e
+ ; Access e n -> expr e <> text "." <> name n
+ ; Assign l r -> assign (expr l) r
+ ; New n es ds -> new (name n) es (maybeClass ds)
+ ; Call e n es -> call (expr e) (name n) es
+ ; Op e1 o e2 -> op e1 o e2
+ ; InstanceOf e t -> expr e <+> text "instanceof" <+> typ t
+ ; NewArray n es -> newArray (name n) es
+ }
+
+op = \e1 -> \o -> \e2 ->
+ ( if isSimple e1
+ then expr e1
+ else parens (expr e1)
+ )
+ <+>
+ text o
+ <+>
+ ( if isSimple e2
+ then expr e2
+ else parens (expr e2)
+ )
+
+assign = \l -> \r ->
+ if isSimple r
+ then l <+> text "=" <+> (expr r)
+ else l <+> text "=" $$ indent (expr r)
+
+cast = \t -> \e ->
+ if isSimple e
+ then parens (parens t <> expr e)
+ else parens (parens t $$ indent (expr e))
+
+new n [] (Just ds) = sep [text "new" <+> n <+> text "()" <+> text "{",
+ indent ds,
+ text "}"]
+new n es Nothing = text "new" <+> n <> parens (hsep (punctuate comma (map expr es)))
+
+newArray n es = text "new" <+> n <> text "[]" <+> braces (hsep (punctuate comma (map expr es)))
+
+call e n es = e <> dot <> n <> parens (hsep (punctuate comma (map expr es)))
+
+literal = \l ->
+ case l of
+ { IntLit i -> text (show i)
+ ; UIntLit i -> text (show i)
+ ; CharLit c -> text (show c)
+ ; UCharLit c -> text (show c)
+ ; StringLit s -> text (show s)
+ }
+
+maybeClass Nothing = Nothing
+maybeClass (Just ds) = Just (decls ds)
+\end{code}
projects / ghc-hetmet.git / commitdiff