From: Ian Lynagh Date: Tue, 6 May 2008 10:43:07 +0000 (+0000) Subject: Remove javaGen; part of trac #2243 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=911e7de13ab1c0e5426c7f234e0c8dd29185a2ba;ds=inline Remove javaGen; part of trac #2243 --- diff --git a/compiler/javaGen/Java.lhs b/compiler/javaGen/Java.lhs deleted file mode 100644 index f703632..0000000 --- a/compiler/javaGen/Java.lhs +++ /dev/null @@ -1,176 +0,0 @@ -Anbstract 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 - -Major reworking to be usable for the intermeduate (GOO) language -for the backend of GHC and to target languauges like Java sucessfully. --- Andy Gill - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module Java where - -\end{code} - -%************************************************************************ -%* * -\subsection{Java type declararations} -%* * -%************************************************************************ - -\begin{code} -data CompilationUnit - = Package PackageName [Decl] - deriving (Show) - -data Decl - = Import PackageName - | Field [Modifier] Name (Maybe Expr) - | Constructor [Modifier] TypeName [Parameter] [Statement] - | Method [Modifier] Name [Parameter] [Exception] [Statement] - | Comment [String] - | Interface [Modifier] TypeName [TypeName] [Decl] - | Class [Modifier] TypeName [TypeName] [TypeName] [Decl] - deriving (Show) - -data Parameter - = Parameter [Modifier] Name - deriving (Show) - -data Statement - = Skip - | Return Expr -- This always comes last in a list - -- of statements, and it is understood - -- you might change this to something - -- else (like a variable assignment) - -- if this is not top level statements. - | Block [Statement] - | ExprStatement Expr -- You are never interested in the result - -- of an ExprStatement - | 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 - | Raise TypeName [Expr] - | New Type [Expr] (Maybe [Decl]) -- anonymous innerclass - deriving (Show) - -data Modifier - = Public | Protected | Private - | Static - | Abstract | Final | Native | Synchronized | Transient | Volatile - deriving (Show, Eq, Ord) - --- A type is used to refer in general to the shape of things, --- or a specific class. Never use a name to refer to a class, --- always use a type. - -data Type - = PrimType PrimType - | ArrayType Type - | Type TypeName - deriving (Show, Eq) - -data PrimType - = PrimInt - | PrimBoolean - | PrimChar - | PrimLong - | PrimFloat - | PrimDouble - | PrimByte - | PrimVoid - deriving (Show, Eq) - -type PackageName = String -- A package name - -- like "java.awt.Button" - -type Exception = TypeName -- A class name that must be an exception. - -type TypeName = String -- a fully qualified type name - -- like "java.lang.Object". - -- has type "Type " - -data Name = Name String Type - deriving Show -- A class name or method etc, - -- at defintion time, - -- this generally not a qualified name. - - -- The type is shape of the box require - -- to store an access to this thing. - -- So variables might be Int or Object. - - -- ** method calls store the returned - -- ** type, not a complete arg x result type. - -- - -- Thinking: - -- ... foo1.foo2(...).foo3 ... - -- here you want to know the *result* - -- after calling foo1, then foo2, - -- then foo3. - -instance Eq Name where - (Name nm _) == (Name nm' _) = nm == nm' - - -instance Ord Name where - (Name nm _) `compare` (Name nm' _) = nm `compare` nm' - - -data Lit - = IntLit Integer -- unboxed - | CharLit Int -- unboxed - | StringLit String -- java string - deriving Show - -addModifier :: Modifier -> Decl -> Decl -addModifier = \m -> \d -> - case d of - { Import n -> Import n - ; Field ms n e -> Field (m:ms) n e - ; Constructor ms n as ss -> Constructor (m:ms) n as ss - ; Method ms n as ts ss -> Method (m:ms) n as ts 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 - } - -changeNameType :: Type -> Name -> Name -changeNameType ty (Name n _) = Name n ty - -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} diff --git a/compiler/javaGen/JavaGen.lhs b/compiler/javaGen/JavaGen.lhs deleted file mode 100644 index 513879a..0000000 --- a/compiler/javaGen/JavaGen.lhs +++ /dev/null @@ -1,1173 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 -% -\section{Generate Java} - -Name mangling for Java. -~~~~~~~~~~~~~~~~~~~~~~ - -Haskell has a number of namespaces. The Java translator uses -the standard Haskell mangles (see OccName.lhs), and some extra -mangles. - -All names are hidden inside packages. - -module name: - - becomes a first level java package. - - can not clash with java, because haskell modules are upper case, - java default packages are lower case. - -function names: - - these turn into classes - - java keywords (eg. private) have the suffix "zdk" ($k) added. - -data *types* - - These have a base class, so need to appear in the - same name space as other object. for example data Foo = Foo - - We add a postfix to types: "zdc" ($c) - - Types are upper case, so never clash with keywords - -data constructors - - There are tWO classes for each Constructor - (1) - Class with the payload extends the relevent datatype baseclass. - - This class has the prefix zdw ($w) - (2) - Constructor *wrapper* just use their own name. - - Constructors are upper case, so never clash with keywords - - So Foo would become 2 classes. - * Foo -- the constructor wrapper - * zdwFoo -- the worker, with the payload - - -$i for instances. -$k for keyword nameclash avoidance. - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module JavaGen( javaGen ) where - -import Java - -import Literal ( Literal(..) ) -import Id ( Id, isDataConWorkId_maybe, isId, idName, isDeadBinder, idPrimRep - , isPrimOpId_maybe ) -import Name ( NamedThing(..), getOccString, isExternalName, isInternalName - , nameModule ) -import PrimRep ( PrimRep(..) ) -import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConWorkId ) -import qualified Type -import qualified CoreSyn -import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr, - Bind(..), AltCon(..), collectBinders, isValArg - ) -import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) -import qualified CoreUtils -import Module ( Module, moduleString ) -import TyCon ( TyCon, isDataTyCon, tyConDataCons ) -import Outputable - -import Maybe -import PrimOp -import Util ( lengthIs, notNull ) - -#include "HsVersions.h" - -\end{code} - - -\begin{code} -javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit - -javaGen mod import_mods tycons binds - = liftCompilationUnit package - where - decls = [Import "haskell.runtime.*"] ++ - [Import (moduleString mod) | mod <- import_mods] ++ - concat (map javaTyCon (filter isDataTyCon tycons)) ++ - concat (map javaTopBind binds) - package = Package (moduleString mod) decls -\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 : concat (map constr_class constrs) - where - constrs = tyConDataCons tycon - tycon_jclass_jname = javaTyConTypeName tycon ++ "zdc" - tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] [] - - constr_class data_con - = [ Class [Public] constr_jname [tycon_jclass_jname] [] - (field_decls ++ [cons_meth,debug_meth]) - ] - where - constr_jname = shortName (javaConstrWkrName data_con) - - field_names = constrToFields data_con - field_decls = [ Field [Public] n Nothing - | n <- field_names - ] - - cons_meth = mkCons constr_jname field_names - - debug_meth = Method [Public] (Name "toString" stringType) - [] - [] - ( [ Declaration (Field [] txt Nothing) ] - ++ [ ExprStatement - (Assign (Var txt) - (mkStr - ("( " ++ - getOccString data_con ++ - " ") - ) - ) - ] - ++ [ ExprStatement - (Assign (Var txt) - (Op (Var txt) - "+" - (Op (Var n) "+" litSp) - ) - ) - | n <- field_names - ] - ++ [ Return (Op (Var txt) - "+" - (mkStr ")") - ) - ] - ) - - litSp = mkStr " " - txt = Name "__txt" stringType - - --- This checks to see the type is reasonable to call new with. --- primitives might use a static method later. -mkNew :: Type -> [Expr] -> Expr -mkNew t@(PrimType primType) _ = error "new primitive -- fix it???" -mkNew t@(Type _) es = New t es Nothing -mkNew _ _ = error "new with strange arguments" - -constrToFields :: DataCon -> [Name] -constrToFields cons = - [ fieldName i t - | (i,t) <- zip [1..] (map primRepToType - (map Type.typePrimRep - (dataConRepArgTys cons) - ) - ) - ] - -mkCons :: TypeName -> [Name] -> Decl -mkCons name args = Constructor [Public] name - [ Parameter [] n | n <- args ] - [ ExprStatement (Assign - (Access this n) - (Var n) - ) - | n <- args ] - -mkStr :: String -> Expr -mkStr str = Literal (StringLit str) -\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] (shortName (javaIdTypeName bndr)) - [] [codeName] [enter_meth] - where - enter_meth = Method [Public] - enterName - [vmArg] - [excName] - (javaExpr vmRETURN rhs) -\end{code} - -%************************************************************************ -%* * -\subsection{Expressions} -%* * -%************************************************************************ - -\begin{code} -javaVar :: Id -> Expr -javaVar v | isExternalName (idName v) = mkNew (javaIdType v) [] - | otherwise = Var (javaName v) - -javaLit :: Literal.Literal -> Expr -javaLit (MachInt i) = Literal (IntLit (fromInteger i)) -javaLit (MachChar c) = Literal (CharLit c) -javaLit (MachStr fs) = Literal (StringLit str) - where - str = concatMap renderString (unpackFS fs) ++ "\\000" - -- This should really handle all the chars 0..31. - renderString '\NUL' = "\\000" - renderString other = [other] - -javaLit other = pprPanic "javaLit" (ppr other) - --- Pass in the 'shape' of the result. -javaExpr :: (Expr -> Statement) -> CoreExpr -> [Statement] --- Generate code to apply the value of --- the expression to the arguments aleady on the stack -javaExpr r (CoreSyn.Var v) = [r (javaVar v)] -javaExpr r (CoreSyn.Lit l) = [r (javaLit l)] -javaExpr r (CoreSyn.App f a) = javaApp r f [a] -javaExpr r e@(CoreSyn.Lam _ _) = javaLam r (collectBinders e) -javaExpr r (CoreSyn.Case e x alts) = javaCase r e x alts -javaExpr r (CoreSyn.Let bind body) = javaBind bind ++ javaExpr r body -javaExpr r (CoreSyn.Note _ e) = javaExpr r e - -javaCase :: (Expr -> Statement) -> 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 throw java.lang.Exception - --- This first special case happens a lot, typically --- during dictionary deconstruction. --- We need to access at least *one* field, to check to see --- if we have correct constructor. --- If we've got the wrong one, this is _|_, and the --- casting will catch this with an exception. - -javaCase r e x [(DataAlt d,bs,rhs)] | notNull bs - = java_expr PushExpr e ++ - [ var [Final] (javaName x) - (whnf primRep (vmPOP (primRepToType primRep))) ] ++ - bind_args d bs ++ - javaExpr r rhs - where - primRep = idPrimRep x - whnf PtrRep = vmWHNF -- needs evaluation - whnf _ = id -- anything else does notg - - bind_args d bs = [var [Final] (javaName b) - (Access (Cast (javaConstrWkrType d) (javaVar x) - ) f - ) - | (b,f) <- filter isId bs `zip` (constrToFields d) - , not (isDeadBinder b) - ] - -javaCase r e x alts - | isIfThenElse && isPrimCmp - = javaIfThenElse r (fromJust maybePrim) tExpr fExpr - | otherwise - = java_expr PushExpr e ++ - [ var [Final] (javaName x) - (whnf primRep (vmPOP (primRepToType primRep))) - , IfThenElse (map mk_alt con_alts) (Just default_code) - ] - where - isIfThenElse = CoreUtils.exprType e `Type.eqType` boolTy - -- also need to check that x is not free in - -- any of the branches. - maybePrim = findCmpPrim e [] - isPrimCmp = isJust maybePrim - (_,_,tExpr) = CoreUtils.findAlt (DataAlt trueDataCon) alts - (_,_,fExpr) = CoreUtils.findAlt (DataAlt falseDataCon) alts - - primRep = idPrimRep x - whnf PtrRep = vmWHNF -- needs evaluation - whnf _ = id - - (con_alts, maybe_default) = CoreUtils.findDefault alts - default_code = case maybe_default of - Nothing -> ExprStatement (Raise excName [Literal (StringLit "case failure")]) - Just rhs -> Block (javaExpr r rhs) - - mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs)) - mk_alt (LitAlt lit, bs, rhs) = (eqLit lit , Block (javaExpr r rhs)) - - - eqLit (MachInt n) = Op (Literal (IntLit n)) - - "==" - (Var (javaName x)) - eqLit (MachChar n) = Op (Literal (CharLit n)) - "==" - (Var (javaName x)) - eqLit other = pprPanic "eqLit" (ppr other) - - bind_args d bs = [var [Final] (javaName b) - (Access (Cast (javaConstrWkrType d) (javaVar x) - ) f - ) - | (b,f) <- filter isId bs `zip` (constrToFields d) - , not (isDeadBinder b) - ] - -javaIfThenElse r cmp tExpr fExpr -{- - - Now what we need to do is generate code for the if/then/else. - - [all arguments are already check for simpleness (Var or Lit).] - - - - if ( arg1 arg2 arg3 ...) { - - trueCode - - } else { - - falseCode - - } - -} - = [IfThenElse [(cmp,j_tExpr)] (Just j_fExpr)] - where - j_tExpr, j_fExpr :: Statement - j_tExpr = Block (javaExpr r tExpr) - j_fExpr = Block (javaExpr r fExpr) - -javaBind (NonRec x rhs) -{- - x = ...rhs_x... - ==> - final Object x = new Thunk( new Code() { ...code for rhs_x... } ) --} - - = java_expr (SetVar name) rhs - where - name = case coreTypeToType rhs of - ty@(PrimType _) -> javaName x `withType` ty - _ -> javaName x `withType` codeType - -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 [] class_name [] [codeName] stmts) - where - class_name = javaIdTypeName b - stmts = [Field [] (javaName b `withType` codeType) Nothing | (b,_) <- prs] ++ - [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)] - - mk_inst (b,r) = var [Final] name (mkNew ty []) - where - name@(Name _ ty) = javaInstName b - - mk_thunk (b,r) = var [Final] (javaName b `withType` codeType) - (mkNew thunkType [Var (javaInstName b)]) - - mk_knot (b,_) = [ ExprStatement (Assign lhs rhs) - | (b',_) <- prs, - let lhs = Access (Var (javaInstName b)) (javaName b'), - let rhs = Var (javaName b') - ] - -javaLam :: (Expr -> Statement) -> ([CoreBndr], CoreExpr) -> [Statement] -javaLam r (bndrs, body) - | null val_bndrs = javaExpr r body - | otherwise - = vmCOLLECT (length val_bndrs) this - ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs] - ++ javaExpr r body - where - val_bndrs = map javaName (filter isId bndrs) - -javaApp :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement] -javaApp r (CoreSyn.App f a) as - | isValArg a = javaApp r f (a:as) - | otherwise = javaApp r f as -javaApp r (CoreSyn.Var f) as - = case isDataConWorkId_maybe f of { - Just dc | as `lengthIs` dataConRepArity dc - -- NOTE: Saturated constructors never returning a primitive at this point - -- - -- We push the arguments backwards, because we are using - -- the (ugly) semantics of the order of evaluation of arguments, - -- to avoid making up local names. Oh to have a namesupply... - -- - -> javaArgs (reverse as) ++ - [r (New (javaIdType f) - (javaPops as) - Nothing - ) - ] - | otherwise -> - -- build a local - let stmts = - vmCOLLECT (dataConRepArity dc) this ++ - [ vmRETURN - (New (javaIdType f) - [ vmPOP ty | (Name _ ty) <- constrToFields dc ] - Nothing - ) - ] - in javaArgs (reverse as) ++ [r (newCode stmts)] - ; other -> java_apply r (CoreSyn.Var f) as - } - -javaApp r f as = java_apply r f as - --- This means, given a expression an a list of arguments, --- generate code for "pushing the arguments on the stack, --- and the executing the expression." - -java_apply :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement] -java_apply r f as = javaArgs as ++ javaExpr r f - --- This generates statements that have the net effect --- of pushing values (perhaps thunks) onto the stack. - -javaArgs :: [CoreExpr] -> [Statement] -javaArgs args = concat [ java_expr PushExpr a | a <- args, isValArg a] - -javaPops :: [CoreExpr] -> [Expr] -javaPops args = [ vmPOP (primRepToType (Type.typePrimRep (CoreUtils.exprType a))) - | a <- args - , isValArg a - ] - - --- The result is a list of statments that have the effect of --- pushing onto the stack (via one of the VM.PUSH* commands) --- the argument, (or returning, or setting a variable) --- perhaps thunked. - -{- This is mixing two things. - (1) Optimizations for things like primitives, whnf calls, etc. - (2) If something needs a thunk constructor round it. - - Seperate them at some point! - -} -data ExprRetStyle = SetVar Name | PushExpr | ReturnExpr - -java_expr :: ExprRetStyle -> CoreExpr -> [Statement] -java_expr _ (CoreSyn.Type t) = pprPanic "java_expr" (ppr t) -java_expr ret e - | isPrimCall = [push (fromJust maybePrim)] - -- This is a shortcut, - -- basic names and literals do not need a code block - -- to compute the value. - | isPrim primty && CoreUtils.exprIsTrivial e = javaExpr push e - | isPrim primty = - let expr = javaExpr vmRETURN e - code = access (vmWHNF (newCode expr)) (primRepToType primty) - in [push code] - | otherwise = - let expr = javaExpr vmRETURN e - code = newCode expr - code' = if CoreUtils.exprIsValue e - || CoreUtils.exprIsTrivial e - || isPrim primty - then code - else newThunk code - in [push code'] - where - maybePrim = findFnPrim e [] - isPrimCall = isJust maybePrim - - push e = case ret of - SetVar name -> var [Final] name e - PushExpr -> vmPUSH e - ReturnExpr -> vmRETURN e - corety = CoreUtils.exprType e - primty = Type.typePrimRep corety - isPrim PtrRep = False -- only this needs updated - isPrim _ = True - -coreTypeToType = primRepToType . Type.typePrimRep . CoreUtils.exprType - -renameForKeywords :: (NamedThing name) => name -> String -renameForKeywords name - | str `elem` keywords = "zdk" ++ str - | otherwise = str - where - str = getOccString name - -keywords :: [String] -keywords = - [ "return" - , "if" - , "then" - , "else" - , "class" - , "instance" - , "import" - , "throw" - , "try" - ] - -\end{code} - -%************************************************************************ -%* * -\subsection{Helper functions} -%* * -%************************************************************************ - -\begin{code} -true, this,javaNull :: Expr -this = Var thisName -true = Var (Name "true" (PrimType PrimBoolean)) -javaNull = Var (Name "null" objectType) - -vmCOLLECT :: Int -> Expr -> [Statement] -vmCOLLECT 0 e = [] -vmCOLLECT n e = [ExprStatement - (Call varVM collectName - [ Literal (IntLit (toInteger n)) - , e - ] - ) - ] - -vmPOP :: Type -> Expr -vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) [] - -vmPUSH :: Expr -> Statement -vmPUSH e = ExprStatement - (Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e]) - -vmRETURN :: Expr -> Statement -vmRETURN e = Return ( - case ty of - PrimType _ -> Call varVM (Name ("RETURN" ++ suffix ty) - valueType - ) [e] - _ -> e) - where - ty = exprType e - -var :: [Modifier] -> Name -> Expr -> Statement -var ms field_name@(Name _ ty) value - | exprType value == ty = Declaration (Field ms field_name (Just value)) - | otherwise = var ms field_name (Cast ty value) - -vmWHNF :: Expr -> Expr -vmWHNF e = Call varVM whnfName [e] - -suffix :: Type -> String -suffix (PrimType t) = primName t -suffix _ = "" - -primName :: PrimType -> String -primName PrimInt = "int" -primName PrimChar = "char" -primName PrimByte = "byte" -primName PrimBoolean = "boolean" -primName _ = error "unsupported primitive" - -varVM :: Expr -varVM = Var vmName - -instanceOf :: Id -> DataCon -> Expr -instanceOf x data_con - = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con) - -newCode :: [Statement] -> Expr -newCode [Return e] = e -newCode stmts = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts]) - -newThunk :: Expr -> Expr -newThunk e = New thunkType [e] Nothing - -vmArg :: Parameter -vmArg = Parameter [Final] vmName - --- This is called with boolean compares, checking --- to see if we can do an obvious shortcut. --- If there is, we return a (GOO) expression for doing this, - --- So if, we have case (#< x y) of { True -> e1; False -> e2 }, --- we will call findCmpFn with (#< x y), this return Just (Op x "<" y) - -findCmpPrim :: CoreExpr -> [Expr] -> Maybe Expr -findCmpPrim (CoreSyn.App f a) as = - case a of - CoreSyn.Var v -> findCmpPrim f (javaVar v:as) - CoreSyn.Lit l -> findCmpPrim f (javaLit l:as) - _ -> Nothing -findCmpPrim (CoreSyn.Var p) as = - case isPrimOpId_maybe p of - Just prim -> find_cmp_prim prim as - Nothing -> Nothing -findCmpPrim _ as = Nothing - -find_cmp_prim cmpPrim args@[a,b] = - case cmpPrim of - IntGtOp -> fn ">" - IntGeOp -> fn ">=" - IntEqOp -> fn "==" - IntNeOp -> fn "/=" - IntLtOp -> fn "<" - IntLeOp -> fn "<=" - _ -> Nothing - where - fn op = Just (Op a op b) -find_cmp_prim _ _ = Nothing - -findFnPrim :: CoreExpr -> [Expr] -> Maybe Expr -findFnPrim (CoreSyn.App f a) as = - case a of - CoreSyn.Var v -> findFnPrim f (javaVar v:as) - CoreSyn.Lit l -> findFnPrim f (javaLit l:as) - _ -> Nothing -findFnPrim (CoreSyn.Var p) as = - case isPrimOpId_maybe p of - Just prim -> find_fn_prim prim as - Nothing -> Nothing -findFnPrim _ as = Nothing - -find_fn_prim cmpPrim args@[a,b] = - case cmpPrim of - IntAddOp -> fn "+" - IntSubOp -> fn "-" - IntMulOp -> fn "*" - _ -> Nothing - where - fn op = Just (Op a op b) -find_fn_prim _ _ = Nothing -\end{code} - -%************************************************************************ -%* * -\subsection{Haskell to Java Types} -%* * -%************************************************************************ - -\begin{code} -exprType (Var (Name _ t)) = t -exprType (Literal lit) = litType lit -exprType (Cast t _) = t -exprType (New t _ _) = t -exprType (Call _ (Name _ t) _) = t -exprType (Access _ (Name _ t)) = t -exprType (Raise t _) = error "do not know the type of raise!" -exprType (Op _ op _) | op `elem` ["==","/=","<","<=","=>",">"] - = PrimType PrimBoolean -exprType (Op x op _) | op `elem` ["+","-","*"] - = exprType x -exprType expr = error ("can't figure out an expression type: " ++ show expr) - -litType (IntLit i) = PrimType PrimInt -litType (CharLit i) = PrimType PrimChar -litType (StringLit i) = stringType -- later, might use char array? -\end{code} - -%************************************************************************ -%* * -\subsection{Name mangling} -%* * -%************************************************************************ - -\begin{code} -codeName, excName, thunkName :: TypeName -codeName = "haskell.runtime.Code" -thunkName = "haskell.runtime.Thunk" -excName = "java.lang.Exception" - -enterName, vmName,thisName,collectName, whnfName :: Name -enterName = Name "ENTER" objectType -vmName = Name "VM" vmType -thisName = Name "this" (Type "") -collectName = Name "COLLECT" void -whnfName = Name "WHNF" objectType - -fieldName :: Int -> Type -> Name -- Names for fields of a constructor -fieldName n ty = Name ("f" ++ show n) ty - -withType :: Name -> Type -> Name -withType (Name n _) t = Name n t - --- This maps (local only) names Ids to Names, --- using the same string as the Id. -javaName :: Id -> Name -javaName n - | isExternalName (idName n) = error "useing javaName on global" - | otherwise = Name (getOccString n) - (primRepToType (idPrimRep n)) - --- TypeName's are almost always global. This would typically return something --- like Test.foo or Test.Foozdc or PrelBase.foldr. --- Local might use locally bound types, (which do not have '.' in them). - -javaIdTypeName :: Id -> TypeName -javaIdTypeName n - | isInternalName n' = renameForKeywords n' - | otherwise = moduleString (nameModule n') ++ "." ++ renameForKeywords n' - where - n' = getName n - --- There is no such thing as a local type constructor. - -javaTyConTypeName :: TyCon -> TypeName -javaTyConTypeName n = (moduleString (nameModule n') ++ "." ++ renameForKeywords n') - where - n' = getName n - --- this is used for getting the name of a class when defining it. -shortName :: TypeName -> TypeName -shortName = reverse . takeWhile (/= '.') . reverse - --- The function that makes the constructor name --- The constructor "Foo ..." in module Test, --- would return the name "Test.Foo". - -javaConstrWkrName :: DataCon -> TypeName -javaConstrWkrName = javaIdTypeName . dataConWorkId - --- Makes x_inst for Rec decls --- They are *never* is primitive --- and always have local (type) names. -javaInstName :: Id -> Name -javaInstName n = Name (renameForKeywords n ++ "zdi_inst") - (Type (renameForKeywords n)) -\end{code} - -%************************************************************************ -%* * -\subsection{Types and type mangling} -%* * -%************************************************************************ - -\begin{code} --- Haskell RTS types -codeType, thunkType, valueType :: Type -codeType = Type codeName -thunkType = Type thunkName -valueType = Type "haskell.runtime.Value" -vmType = Type "haskell.runtime.VMEngine" - --- Basic Java types -objectType, stringType :: Type -objectType = Type "java.lang.Object" -stringType = Type "java.lang.String" - -void :: Type -void = PrimType PrimVoid - -inttype :: Type -inttype = PrimType PrimInt - -chartype :: Type -chartype = PrimType PrimChar - -bytetype :: Type -bytetype = PrimType PrimByte - --- This lets you get inside a possible "Value" type, --- to access the internal unboxed object. -access :: Expr -> Type -> Expr -access expr (PrimType prim) = accessPrim (Cast valueType expr) prim -access expr other = expr - -accessPrim expr PrimInt = Call expr (Name "intValue" inttype) [] -accessPrim expr PrimChar = Call expr (Name "charValue" chartype) [] -accessPrim expr PrimByte = Call expr (Name "byteValue" bytetype) [] -accessPrim expr other = pprPanic "accessPrim" (text (show other)) - --- This is where we map from typename to types, --- allowing to match possible primitive types. -mkType :: TypeName -> Type -mkType "PrelGHC.Intzh" = inttype -mkType "PrelGHC.Charzh" = chartype -mkType other = Type other - --- Turns a (global) Id into a Type (fully qualified name). -javaIdType :: Id -> Type -javaIdType = mkType . javaIdTypeName - -javaLocalIdType :: Id -> Type -javaLocalIdType = primRepToType . idPrimRep - -primRepToType ::PrimRep -> Type -primRepToType PtrRep = objectType -primRepToType IntRep = inttype -primRepToType CharRep = chartype -primRepToType Int8Rep = bytetype -primRepToType AddrRep = objectType -primRepToType other = pprPanic "primRepToType" (ppr other) - --- The function that makes the constructor name -javaConstrWkrType :: DataCon -> Type -javaConstrWkrType con = Type (javaConstrWkrName con) -\end{code} - -%************************************************************************ -%* * -\subsection{Class Lifting} -%* * -%************************************************************************ - -This is a very simple class lifter. It works by carrying inwards a -list of bound variables (things that might need to be passed to a -lifted inner class). - * Any variable references is check with this list, and if it is - bound, then it is not top level, external reference. - * This means that for the purposes of lifting, it might be free - inside a lifted inner class. - * We remember these "free inside the inner class" values, and - use this list (which is passed, via the monad, outwards) - when lifting. - -\begin{code} -type Bound = [Name] -type Frees = [Name] - -combine :: [Name] -> [Name] -> [Name] -combine [] names = names -combine names [] = names -combine (name:names) (name':names') - | name < name' = name : combine names (name':names') - | name > name' = name' : combine (name:names) names' - | name == name = name : combine names names' - | otherwise = error "names are not a total order" - -both :: [Name] -> [Name] -> [Name] -both [] names = [] -both names [] = [] -both (name:names) (name':names') - | name < name' = both names (name':names') - | name > name' = both (name:names) names' - | name == name = name : both names names' - | otherwise = error "names are not a total order" - -combineEnv :: Env -> [Name] -> Env -combineEnv (Env bound env) new = Env (bound `combine` new) env - -addTypeMapping :: TypeName -> TypeName -> [Name] -> Env -> Env -addTypeMapping origName newName frees (Env bound env) - = Env bound ((origName,(newName,frees)) : env) - --- This a list of bound vars (with types) --- and a mapping from old class name --- to inner class name (with a list of frees that need passed --- to the inner class.) - -data Env = Env Bound [(TypeName,(TypeName,[Name]))] - -newtype LifterM a = - LifterM { unLifterM :: - TypeName -> -- this class name - Int -> -- uniq supply - ( a -- * - , Frees -- frees - , [Decl] -- lifted classes - , Int -- The uniqs - ) - } - -instance Monad LifterM where - return a = LifterM (\ n s -> (a,[],[],s)) - (LifterM m) >>= fn = LifterM (\ n s -> - case m n s of - (a,frees,lifted,s) - -> case unLifterM (fn a) n s of - (a,frees2,lifted2,s) -> ( a - , combine frees frees2 - , lifted ++ lifted2 - , s) - ) - -liftAccess :: Env -> Name -> LifterM () -liftAccess env@(Env bound _) name - | name `elem` bound = LifterM (\ n s -> ((),[name],[],s)) - | otherwise = return () - -scopedName :: TypeName -> LifterM a -> LifterM a -scopedName name (LifterM m) = - LifterM (\ _ s -> - case m name 1 of - (a,frees,lifted,_) -> (a,frees,lifted,s) - ) - -genAnonInnerClassName :: LifterM TypeName -genAnonInnerClassName = LifterM (\ n s -> - ( n ++ "$" ++ show s - , [] - , [] - , s + 1 - ) - ) - -genInnerClassName :: TypeName -> LifterM TypeName -genInnerClassName name = LifterM (\ n s -> - ( n ++ "$" ++ name - , [] - , [] - , s - ) - ) - -getFrees :: LifterM a -> LifterM (a,Frees) -getFrees (LifterM m) = LifterM (\ n s -> - case m n s of - (a,frees,lifted,n) -> ((a,frees),frees,lifted,n) - ) - -rememberClass :: Decl -> LifterM () -rememberClass decl = LifterM (\ n s -> ((),[],[decl],s)) - - -liftCompilationUnit :: CompilationUnit -> CompilationUnit -liftCompilationUnit (Package name ds) = - Package name (concatMap liftCompilationUnit' ds) - -liftCompilationUnit' :: Decl -> [Decl] -liftCompilationUnit' decl = - case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of - (ds,_,ds',_) -> ds ++ ds' - - --- The bound vars for the current class have --- already be captured before calling liftDecl, --- because they are in scope everywhere inside the class. - -liftDecl :: Bool -> Env -> Decl -> LifterM Decl -liftDecl = \ top env decl -> - case decl of - { Import n -> return (Import n) - ; Field mfs n e -> - do { e <- liftMaybeExpr env e - ; return (Field mfs (liftName env n) e) - } - ; Constructor mfs n as ss -> - do { let newBound = getBoundAtParameters as - ; (ss,_) <- liftStatements (combineEnv env newBound) ss - ; return (Constructor mfs n (liftParameters env as) ss) - } - ; Method mfs n as ts ss -> - do { let newBound = getBoundAtParameters as - ; (ss,_) <- liftStatements (combineEnv env newBound) ss - ; return (Method mfs (liftName env n) (liftParameters env as) ts ss) - } - ; Comment s -> return (Comment s) - ; Interface mfs n is ms -> error "interfaces not supported" - ; Class mfs n x is ms -> - do { let newBound = getBoundAtDecls ms - ; ms <- scopedName n - (liftDecls False (combineEnv env newBound) ms) - ; return (Class mfs n x is ms) - } - } - -liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl] -liftDecls top env = mapM (liftDecl top env) - -getBoundAtDecls :: [Decl] -> Bound -getBoundAtDecls = foldr combine [] . map getBoundAtDecl - -getBoundAtDecl :: Decl -> Bound -getBoundAtDecl (Field _ n _) = [n] -getBoundAtDecl _ = [] - -getBoundAtParameters :: [Parameter] -> Bound -getBoundAtParameters = foldr combine [] . map getBoundAtParameter - --- TODO -getBoundAtParameter :: Parameter -> Bound -getBoundAtParameter (Parameter _ n) = [n] - - -liftStatement :: Env -> Statement -> LifterM (Statement,Env) -liftStatement = \ env stmt -> - case stmt of - { Skip -> return (stmt,env) - ; Return e -> do { e <- liftExpr env e - ; return (Return e,env) - } - ; Block ss -> do { (ss,env) <- liftStatements env ss - ; return (Block ss,env) - } - ; ExprStatement e -> do { e <- liftExpr env e - ; return (ExprStatement e,env) - } - ; Declaration decl@(Field mfs n e) -> - do { e <- liftMaybeExpr env e - ; return ( Declaration (Field mfs (liftName env n) e) - , env `combineEnv` getBoundAtDecl decl - ) - } - ; Declaration decl@(Class mfs n x is ms) -> - do { innerName <- genInnerClassName n - ; frees <- liftClass env innerName ms x is - ; return ( Declaration (Comment ["lifted " ++ n]) - , addTypeMapping n innerName frees env - ) - } - ; Declaration d -> error "general Decl not supported" - ; IfThenElse ecs s -> ifthenelse env ecs s - ; Switch e as d -> error "switch not supported" - } - -ifthenelse :: Env - -> [(Expr,Statement)] - -> (Maybe Statement) - -> LifterM (Statement,Env) -ifthenelse env pairs may_stmt = - do { let (exprs,stmts) = unzip pairs - ; exprs <- liftExprs env exprs - ; (stmts,_) <- liftStatements env stmts - ; may_stmt <- case may_stmt of - Just stmt -> do { (stmt,_) <- liftStatement env stmt - ; return (Just stmt) - } - Nothing -> return Nothing - ; return (IfThenElse (zip exprs stmts) may_stmt,env) - } - -liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env) -liftStatements env [] = return ([],env) -liftStatements env (s:ss) = - do { (s,env) <- liftStatement env s - ; (ss,env) <- liftStatements env ss - ; return (s:ss,env) - } - -liftExpr :: Env -> Expr -> LifterM Expr -liftExpr = \ env expr -> - case expr of - { Var n -> do { liftAccess env n - ; return (Var (liftName env n)) - } - ; Literal l -> return expr - ; Cast t e -> do { e <- liftExpr env e - ; return (Cast (liftType env t) e) - } - ; Access e n -> do { e <- liftExpr env e - -- do not consider n as an access, because - -- this is a indirection via a reference - ; return (Access e n) - } - ; Assign l r -> do { l <- liftExpr env l - ; r <- liftExpr env r - ; return (Assign l r) - } - ; InstanceOf e t -> do { e <- liftExpr env e - ; return (InstanceOf e (liftType env t)) - } - ; Raise n es -> do { es <- liftExprs env es - ; return (Raise n es) - } - ; Call e n es -> do { e <- liftExpr env e - ; es <- mapM (liftExpr env) es - ; return (Call e n es) - } - ; Op e1 o e2 -> do { e1 <- liftExpr env e1 - ; e2 <- liftExpr env e2 - ; return (Op e1 o e2) - } - ; New n es ds -> new env n es ds - } - -liftParameter env (Parameter ms n) = Parameter ms (liftName env n) -liftParameters env = map (liftParameter env) - -liftName env (Name n t) = Name n (liftType env t) - -liftExprs :: Env -> [Expr] -> LifterM [Expr] -liftExprs = mapM . liftExpr - - -liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr) -liftMaybeExpr env Nothing = return Nothing -liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt - ; return (Just stmt) - } - - - -new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr -new env@(Env _ pairs) typ args Nothing = - do { args <- liftExprs env args - ; return (liftNew env typ args) - } -new env typ [] (Just inner) = - -- anon. inner class - do { innerName <- genAnonInnerClassName - ; frees <- liftClass env innerName inner [] [unType typ] - ; return (New (Type (innerName)) - (map Var frees) - Nothing) - } - where unType (Type name) = name - unType _ = error "incorrect type style" -new env typ _ (Just inner) = error "cant handle inner class with args" - - -liftClass :: Env -> TypeName -> [Decl] -> [TypeName] -> [TypeName] -> LifterM [ Name ] -liftClass env@(Env bound _) innerName inner xs is = - do { let newBound = getBoundAtDecls inner - ; (inner,frees) <- - getFrees (liftDecls False (env `combineEnv` newBound) inner) - ; let trueFrees = filter (\ (Name xs _) -> xs /= "VM") (both frees bound) - ; let freeDefs = [ Field [Final] n Nothing | n <- trueFrees ] - ; let cons = mkCons innerName trueFrees - ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner) - ; rememberClass innerClass - ; return trueFrees - } - -liftType :: Env -> Type -> Type -liftType (Env _ env) typ@(Type name) - = case lookup name env of - Nothing -> typ - Just (nm,_) -> Type nm -liftType _ typ = typ - -liftNew :: Env -> Type -> [Expr] -> Expr -liftNew (Env _ env) typ@(Type name) exprs - = case lookup name env of - Nothing -> New typ exprs Nothing - Just (nm,args) | null exprs - -> New (Type nm) (map Var args) Nothing - _ -> error "pre-lifted constructor with arguments" -\end{code} diff --git a/compiler/javaGen/PrintJava.lhs b/compiler/javaGen/PrintJava.lhs deleted file mode 100644 index 7ed295c..0000000 --- a/compiler/javaGen/PrintJava.lhs +++ /dev/null @@ -1,231 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section{Generate Java} - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -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" <+> packagename n <> text ";" - $$ - ds - -decls [] = empty -decls (d:ds) = decl d $$ decls ds - -decl = \d -> - case d of - { Import n -> importDecl (packagename n) - ; Field mfs n e -> field (modifiers mfs) (nameTy n) (name n) e - ; Constructor mfs n as ss -> constructor (modifiers mfs) (typename n) (parameters as) (statements ss) - ; Method mfs n as ts ss -> method (modifiers mfs) (nameTy n) (name n) (parameters as) (throws ts) (statements ss) - ; Comment s -> comment s - ; Interface mfs n is ms -> interface (modifiers mfs) (typename n) (extends is) (decls ms) - ; Class mfs n x is ms -> clazz (modifiers mfs) (typename 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 -> \ts -> \ss -> - mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> ts <+> 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 "}" - -modifiers mfs = hsep (map modifier mfs) - -modifier mf = text $ map toLower (show mf) - -extends [] = empty -extends xs = text "extends" <+> hsep (punctuate comma (map typename xs)) - -implements [] = empty -implements xs = text "implements" <+> hsep (punctuate comma (map typename xs)) - -throws [] = empty -throws xs = text "throws" <+> hsep (punctuate comma (map typename xs)) - -name (Name n t) = text n - -nameTy (Name n t) = typ t - -typename n = text n -packagename n = text n - -parameters as = map parameter as - -parameter (Parameter mfs n) = modifiers mfs <+> nameTy n <+> name n - -typ (PrimType s) = primtype s -typ (Type n) = typename n -typ (ArrayType t) = typ t <> text "[]" - -primtype PrimInt = text "int" -primtype PrimBoolean = text "boolean" -primtype PrimChar = text "char" -primtype PrimLong = text "long" -primtype PrimFloat = text "float" -primtype PrimDouble = text "double" -primtype PrimByte = text "byte" -primtype PrimVoid = text "void" - -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" <+> parens e <+> text "{", - indent s, - thenelse ecs ms] - -thenelse ((e,s):ecs) ms = sep [ text "} else if" <+> 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 (typ n) es (maybeClass ds) - ; Raise n es -> text "raise" <+> text n - <+> parens (hsep (punctuate comma (map expr es))) - ; 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 - } - -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))) - - -call e n es = e <> dot <> n <> parens (hsep (punctuate comma (map expr es))) - -literal = \l -> - case l of - { IntLit i -> text (show i) - ; CharLit c -> text "(char)" <+> text (show c) - ; StringLit s -> text ("\"" ++ s ++ "\"") -- strings are already printable - } - -maybeClass Nothing = Nothing -maybeClass (Just ds) = Just (decls ds) -\end{code} diff --git a/compiler/package.conf.in b/compiler/package.conf.in index adaf5de..3b2d265 100644 --- a/compiler/package.conf.in +++ b/compiler/package.conf.in @@ -122,8 +122,6 @@ exposed-modules: IlxGen Inst InstEnv - Java - JavaGen InteractiveUI Lexer LexCore @@ -170,7 +168,6 @@ exposed-modules: PprTyThing PrelInfo PrelNames - PrintJava PrelRules Pretty PrimOp