[project @ 2000-06-07 06:10:53 by andy]

Adding types to the names inside the GOO.

All needed for a langauge with unboxed types ...

3 files changed, 221 insertions, 137 deletions

diff --git a/ghc/compiler/javaGen/Java.lhs b/ghc/compiler/javaGen/Java.lhs
index 578be9a89b..ede6ac28e4 100644
--- a/ghc/compiler/javaGen/Java.lhs
+++ b/ghc/compiler/javaGen/Java.lhs
@@ -22,21 +22,21 @@ module Java where
 
 \begin{code}
 data CompilationUnit
-  = Package Name [Decl]
+  = Package PackageName [Decl]
     deriving (Show)
     
 data Decl
  = Import PackageName
- | Field [Modifier] Type Name (Maybe Expr)
- | Constructor [Modifier] Name [Parameter] [Statement]
- | Method [Modifier] Type Name [Parameter] [Exception] [Statement]
+ | Field [Modifier] Name (Maybe Expr)
+ | Constructor [Modifier] TypeName [Parameter] [Statement]
+ | Method [Modifier] Name [Parameter] [Exception] [Statement]
  | Comment [String]
- | Interface [Modifier] Name [TypeName] [Decl]
- | Class [Modifier] Name [TypeName] [TypeName] [Decl]
+ | Interface [Modifier] TypeName [TypeName] [Decl]
+ | Class [Modifier] TypeName [TypeName] [TypeName] [Decl]
    deriving (Show)
 
 data Parameter
- = Parameter [Modifier] Type Name
+ = Parameter [Modifier] Name
    deriving (Show)
    
 data Statement
@@ -55,10 +55,10 @@ data Statement
     deriving (Show)
 
 data Expr 
-  = Var Name Type
-  | Literal Lit Type
+  = Var Name
+  | Literal Lit
   | Cast Type Expr
-  | Access Expr Name		-- perhaps: Access Expr Var?
+  | Access Expr Name
   | Assign Expr Expr
   | InstanceOf Expr Type
   | Call Expr Name [Expr]
@@ -90,6 +90,7 @@ data PrimType
   | PrimFloat
   | PrimDouble
   | PrimByte
+  | PrimVoid
     deriving (Show)
 
 type PackageName = String	-- A package name
@@ -101,10 +102,24 @@ type TypeName    = String	-- a fully qualified type name
 				-- like "java.lang.Object".
 				-- has type "Type <the name>"
 
-type Name        = String	-- A class name or method etc, 
+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.
+				--
+				-- Thinking:
+				-- ... foo1.foo2(...).foo3 ...
+				-- here you want to know the *result*
+				-- after callling foo1, then foo2,
+				-- then foo3.
+
 
 data Lit
   = IntLit Integer	-- unboxed
@@ -116,13 +131,16 @@ 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  
+   ; Field ms n e -> Field (m:ms) n e  
    ; Constructor ms n as ss -> Constructor (m:ms) n as ss
-   ; Method ms t n as ts ss -> Method (m:ms) t n as ts 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
diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs
index a44b529191..34cf42b4b9 100644
--- a/ghc/compiler/javaGen/JavaGen.lhs
+++ b/ghc/compiler/javaGen/JavaGen.lhs
@@ -68,7 +68,7 @@ import Outputable
 javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
 
 javaGen mod import_mods tycons binds
-  = liftCompilationUnit package
+  = id {-liftCompilationUnit-} package
   where
     decls = [Import "haskell.runtime.*"] ++
 	    [Import (moduleString mod) | mod <- import_mods] ++
@@ -97,7 +97,7 @@ javaTyCon tycon
   = tycon_jclass : concat (map constr_class constrs)
   where
     constrs = tyConDataCons tycon
-    tycon_jclass_jname =  addCons (javaName tycon)
+    tycon_jclass_jname =  javaGlobTypeName tycon ++ "zdc"
     tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] []
 
     constr_class data_con
@@ -109,45 +109,43 @@ javaTyCon tycon
 	  constr_jtype = javaConstrWkrType data_con
 
 	  field_names  = constrToFields data_con
-	  field_decls  = [ Field [Public] t f Nothing 
-			 | (f,t) <- field_names
+	  field_decls  = [ Field [Public] n Nothing 
+			 | n <- field_names
 			 ]
 
 	  cons_meth    = mkCons (shortName constr_jname) field_names
 
-	  debug_meth   = Method [Public] stringT
-					 "toString"
+	  debug_meth   = Method [Public] (Name "toString" stringType)
 					 []
 					 []
-		       (  [ Declaration (Field [] stringT "__txt" Nothing) ]
+		       (  [ Declaration (Field [] txt Nothing) ]
 		       ++ [ ExprStatement
-				(Assign txt (Literal 
-					    (StringLit 
+				(Assign (Var txt)
+					    (mkStr
 						("( " ++ 
 						  getOccString data_con ++ 
 						  " ")
-					    )
-					    stringT
-				       )
+				       	     )
 				)
 			  ]
 		       ++ [ ExprStatement
-				(Assign txt 
-				   (Op txt "+" 
-				     (Op (Var f t) "+" litSp)
+				(Assign (Var txt)
+				   (Op (Var txt)
+				        "+" 
+				       (Op (Var n) "+" litSp)
 				   )
 				)
-			  | (f,t) <- field_names
+			  | n <- field_names
 			  ]
-		       ++ [ Return (Op txt "+" 
-				      (Literal (StringLit ")") stringT)
+		       ++ [ Return (Op (Var txt)
+				        "+" 
+				      (mkStr ")")
 				   )
 			  ]
 		       )
 
-	  stringT  = Type "java.lang.String"
-	  litSp    = Literal (StringLit " ") stringT
-	  txt      = Var "__txt" stringT
+	  litSp    = mkStr " "
+	  txt      = Name "__txt" stringType
 	 
 
 mkNew :: Type -> [Expr] -> Expr
@@ -155,22 +153,23 @@ mkNew t@(PrimType primType) [] = error "new primitive???"
 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 javaTauType (dataConRepArgTys cons))
+	]
 
-addCons :: Name -> Name
-addCons name = name ++ "zdc"
-
-constrToFields :: DataCon -> [(Name,Type)]
-constrToFields cons = zip (map fieldName [1..])
-			  (map javaTauType (dataConRepArgTys cons))
-
-mkCons :: Name -> [(Name,Type)] -> Decl
+mkCons :: TypeName -> [Name] -> Decl
 mkCons name args = Constructor [Public] name
-	[ Parameter [] t n | (n,t) <- args ]
+	[ Parameter [] n | n <- args ]
 	[ ExprStatement (Assign 
 			   (Access this n)
-			   (Var n t)
+			   (Var n)
 			 )
-		    | (n,t) <- args ]
+		    | n <- args ]
+
+mkStr :: String -> Expr
+mkStr str = Literal (StringLit str)
 \end{code}
 
 %************************************************************************
@@ -189,9 +188,10 @@ java_top_bind :: Id -> CoreExpr -> Decl
 --	  public Object ENTER() { ...translation of rhs... }
 --	}
 java_top_bind bndr rhs
-  = Class [Public] (shortName (javaName bndr)) [] [codeName] [enter_meth]
+  = Class [Public] (shortName (javaGlobTypeName bndr)) 
+		[] [codeName] [enter_meth]
   where
-    enter_meth = Method [Public] objectType enterName [vmArg] [excName] 
+    enter_meth = Method [Public] enterName [vmArg] [excName] 
 			(javaExpr vmRETURN rhs)
 \end{code}
 
@@ -205,11 +205,11 @@ java_top_bind bndr rhs
 \begin{code}
 javaVar :: Id -> Expr
 javaVar v | isGlobalName (idName v) = mkNew (javaGlobType v) []
-	  | otherwise	  	    = Var (javaName v) (javaType v)
+	  | otherwise	  	    = Var (javaName v)
 
 javaLit :: Literal.Literal -> Expr
-javaLit (MachInt i)  = Literal (IntLit (fromInteger i)) (PrimType PrimInt)
-javaLit (MachChar c) = Literal (CharLit c)              (PrimType PrimChar)
+javaLit (MachInt i)  = Literal (IntLit (fromInteger i))
+javaLit (MachChar c) = Literal (CharLit c)             
 javaLit other	     = pprPanic "javaLit" (ppr other)
 
 javaExpr :: (Expr -> Expr) -> CoreExpr -> [Statement]
@@ -237,7 +237,7 @@ javaCase :: (Expr -> Expr) -> CoreExpr -> Id -> [CoreAlt] -> [Statement]
 --	} else return null
 
 javaCase r e x alts
-  =  [var [Final] objectType (javaName x) (vmWHNF (javaArg e)),
+  =  [var [Final] (javaName x) (vmWHNF (javaArg e)),
       IfThenElse (map mk_alt alts) Nothing]
   where
      mk_alt (DEFAULT, [], rhs)   = (true, 	    Block (javaExpr r rhs))
@@ -247,14 +247,17 @@ javaCase r e x alts
      mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt)
 
 
-     eqLit (MachInt n) = Op (Literal (IntLit n) (PrimType PrimInt))
+     eqLit (MachInt n) = Op (Literal (IntLit n))
 			    "=="
-			    (Var (javaName x) (PrimType PrimInt))
+			    (Var (javaName x))
      eqLit other       = pprPanic "eqLit" (ppr other)
 
-     bind_args d bs = [var [Final] t (javaName b) 
-			   (Access (Cast (javaConstrWkrType d) (javaVar x)) f)
-		      | (b, (f,t)) <- filter isId bs `zip` (constrToFields d)
+     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)
 		      ]
 
@@ -264,7 +267,9 @@ javaBind (NonRec x rhs)
   ==>
 	final Object x = new Thunk( new Code() { ...code for rhs_x... } )
 -}
-  = [var [Final] objectType (javaName x) (newThunk (newCode (javaExpr vmRETURN rhs)))]
+  = [var [Final] (javaLocName x objectType)
+		 (newThunk (newCode (javaExpr vmRETURN rhs)))
+    ]
 
 javaBind (Rec prs)
 {- 	rec { x = ...rhs_x...; y = ...rhs_y... }
@@ -288,33 +293,35 @@ javaBind (Rec prs)
   = (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)
+    mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts)
 		   where
-		     stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
-			     [Method [Public] objectType enterName [vmArg] [excName] (javaExpr vmRETURN r)]	
+		     class_name = javaLocTypeName b
+		     stmts = [Field [] (javaLocName b codeType) Nothing | (b,_) <- prs] ++
+			     [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)]	
 
-    mk_inst (b,r) = var [Final] (javaGlobType b) (javaInstName b)
-			(New (javaGlobType b) [] Nothing)
+    mk_inst (b,r) = var [Final] (javaInstName b)
+			(mkNew (javaGlobType b) [])
 
-    mk_thunk (b,r) = var [Final] thunkType (javaName b)
-			 (New thunkType [Var (javaInstName b) (Type "<inst>")] Nothing)
+    mk_thunk (b,r) = var [Final] (javaLocName b thunkType)
+			 (New thunkType [Var (javaInstName b)] Nothing)
 
-    mk_knot (b,_) = [ExprStatement (Assign lhs rhs) 
+    mk_knot (b,_) = [ ExprStatement (Assign lhs rhs) 
 		    | (b',_) <- prs,
-		      let lhs = Access (Var (javaInstName b) (Type "<inst>")) (javaName b'),
-		      let rhs = Var (javaName b') (Type "<inst>")
+		      let lhs = Access (Var (javaInstName b)) (javaName b'),
+		      let rhs = Var (javaName b')
 		    ]
 
 
+-- We are needlessly 
 javaLam :: (Expr -> Expr) -> ([CoreBndr], CoreExpr) -> [Statement]
 javaLam r (bndrs, body)
   | null val_bndrs = javaExpr r body
   | otherwise
   =  vmCOLLECT (length val_bndrs) this
-  ++ [var [Final] t (javaName n) (vmPOP t) | (n,t) <- val_bndrs]
+  ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs]
   ++ javaExpr r body
   where
-    val_bndrs = map (\ id -> (id,javaType id)) (filter isId bndrs)
+    val_bndrs = map javaName (filter isId bndrs)
 
 javaApp :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement]
 javaApp r (CoreSyn.App f a) as = javaApp r f (a:as)
@@ -323,7 +330,6 @@ javaApp r (CoreSyn.Var f) as
 	Just dc | length as == dataConRepArity dc
 		-> 	-- Saturated constructors
 		   [Return (New (javaGlobType f) (javaArgs as) Nothing)]
-
     ; other ->   -- Not a saturated constructor
 	java_apply r (CoreSyn.Var f) as
     }
@@ -332,7 +338,6 @@ javaApp r f as = java_apply r f as
 
 java_apply :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement]
 java_apply r f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr r f
-
 javaArgs :: [CoreExpr] -> [Expr]
 javaArgs args = [javaArg a | a <- args, isValArg a]
 
@@ -350,33 +355,40 @@ javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr id e)
 
 \begin{code}
 true, this :: Expr
-this = Var thisName (Type "<this>")
-true = Var "true" (PrimType PrimBoolean)
+this = Var thisName 
+true = Var (Name "true" (PrimType PrimBoolean))
 
 vmCOLLECT :: Int -> Expr -> [Statement]
 vmCOLLECT 0 e = []
-vmCOLLECT n e = [ExprStatement (Call varVM "COLLECT" 
-				     [Literal (IntLit (toInteger n)) (PrimType PrimInt), e])]
+vmCOLLECT n e = [ExprStatement 
+		    (Call varVM collectName
+			[ Literal (IntLit (toInteger n))
+			, e
+			]
+		    )
+		]
 
 vmPOP :: Type -> Expr 
-vmPOP ty = Call varVM ("POP" ++ suffix ty) []
+vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) []
 
 vmPUSH :: Expr -> Expr
-vmPUSH e = Call varVM ("PUSH" ++ suffix (exprType e)) [e]
+vmPUSH e = Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e]
 
 vmRETURN :: Expr -> Expr
 vmRETURN e = 
      case ty of
-	PrimType _ -> Call varVM ("RETURN" ++ suffix (exprType e)) [e]
+	PrimType _ -> Call varVM (Name ("RETURN" ++ suffix (exprType e))
+				       valueType
+				  ) [e]
 	_ -> e
   where
 	ty = exprType e
 
-var :: [Modifier] -> Type -> Name -> Expr -> Statement
-var ms ty field_name value = Declaration (Field ms ty field_name (Just value))
+var :: [Modifier] -> Name -> Expr -> Statement
+var ms field_name value = Declaration (Field ms field_name (Just value))
 
 vmWHNF :: Expr -> Expr
-vmWHNF e = Call varVM "WHNF" [e]
+vmWHNF e = Call varVM whnfName [e]
 
 suffix :: Type -> String
 suffix (PrimType t) = primName t
@@ -388,21 +400,21 @@ primName PrimChar = "char"
 primName _         = error "unsupported primitive"
 
 varVM :: Expr
-varVM = Var vmName (Type "haskell.runtime.VMEngine")
+varVM = Var vmName 
 
 instanceOf :: Id -> DataCon -> Expr
 instanceOf x data_con
-  = InstanceOf (Var (javaName x) (Type "<instof>")) (javaConstrWkrType data_con)
+  = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
 
 newCode :: [Statement] -> Expr
 newCode [Return e] = e
-newCode stmts	   = New codeType [] (Just [Method [Public] objectType enterName [vmArg] [excName] stmts])
+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] (Type "haskell.runtime.VMEngine") vmName
+vmArg = Parameter [Final] vmName
 \end{code}
 
 %************************************************************************
@@ -412,11 +424,15 @@ vmArg = Parameter [Final] (Type "haskell.runtime.VMEngine") vmName
 %************************************************************************
 
 \begin{code}
-exprType (Var _ t)     = t
-exprType (Literal _ t) = t
-exprType (Cast t _)    = t
-exprType (New t _ _)   = t
-exprType _             = error "can't figure out an expression type"
+exprType (Var (Name _ t)) = t
+exprType (Literal lit)    = litType lit
+exprType (Cast t _)       = t
+exprType (New t _ _)      = t
+exprType _                = error "can't figure out an expression type"
+
+litType (IntLit i)    = PrimType PrimInt
+litType (CharLit i)   = PrimType PrimChar
+litType (StringLit i) = error "<string?>"
 \end{code}
 
 %************************************************************************
@@ -426,79 +442,122 @@ exprType _             = error "can't figure out an expression type"
 %************************************************************************
 
 \begin{code}
-codeName, thunkName, enterName, vmName,excName :: Name
+codeName, excName, thunkName :: TypeName
 codeName  = "haskell.runtime.Code"
 thunkName = "haskell.runtime.Thunk"
-enterName = "ENTER"
-vmName    = "VM"
-thisName  = "this"
-excName = "Exception"
+excName   = "java.lang.Exception"
 
-fieldName :: Int -> Name	-- Names for fields of a constructor
-fieldName n = "f" ++ show n
+enterName, vmName,thisName,collectName, whnfName :: Name
+enterName   = Name "ENTER"   objectType
+vmName      = Name "VM"      vmType
+thisName    = Name "this"    (Type "<this>")
+collectName = Name "COLLECT" void
+whnfName    = Name "WNNF"    objectType
 
-javaName :: NamedThing a => a -> Name
+fieldName :: Int -> Type -> Name	-- Names for fields of a constructor
+fieldName n ty = Name ("f" ++ show n) ty
+
+-- TODO: change to idToJavaName :: Id -> Name
+
+javaLocName :: Id -> Type -> Name
+javaLocName n t = Name (getOccString n) t
+
+javaName :: Id -> Name
 javaName n = if isGlobalName n'
-	     then moduleString (nameModule n') ++ "." ++ getOccString n
-	     else getOccString n
+	     then Name (javaGlobTypeName n)
+		       (javaGlobType n)
+	     else Name (getOccString n)
+		       (Type "<loc?>")
+  where
+	     n' = getName n
+
+-- TypeName's are always global
+javaGlobTypeName :: NamedThing a => a -> TypeName
+javaGlobTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString n)
+  where
+	     n' = getName n
+
+javaLocTypeName :: NamedThing a => a -> TypeName
+javaLocTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString 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
 
-javaConstrWkrName :: DataCon -> Name
--- The function that makes the constructor
-javaConstrWkrName con = javaName (dataConId con)
+-- The function that makes the constructor name
+javaConstrWkrName :: DataCon -> TypeName
+javaConstrWkrName con = javaGlobTypeName (dataConId con)
 
-javaInstName :: NamedThing a => a -> Name
 -- Makes x_inst for Rec decls
-javaInstName n = getOccString n ++ "_inst"
+javaInstName :: NamedThing a => a -> Name
+javaInstName n = Name (getOccString n ++ "_inst") (Type "<inst>")
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection{Type mangling}
+\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
+
+-- This is where we map from type to possible primitive
+mkType "PrelGHC.Intzh"  = inttype
+mkType "PrelGHC.Charzh" = chartype
+mkType other            = Type other
+
 -- This mapping a global haskell name (typically a function name)
 -- to the name of the class that handles it.
--- The name must be global. So "Test.foo" maps to Type "Test.foo"
+-- The name must be global. So foo in module Test maps to (Type "Test.foo")
+-- TODO: change to Id
 
 javaGlobType :: NamedThing a => a -> Type
 javaGlobType n | '.' `notElem` name
 	       = error ("not using a fully qualified name for javaGlobalType: " ++ name)
 	       | otherwise
 	       = mkType name
-  where name = javaName n
+  where name = javaGlobTypeName n
 
 -- This takes an id, and finds the ids *type* (for example, Int, Bool, a, etc).
 javaType :: Id -> Type
 javaType id = case (idPrimRep id) of
-		IntRep -> PrimType PrimInt
+		IntRep -> inttype
 		_ -> if isGlobalName (idName id)
-		     then Type (javaName id)
+		     then Type (javaGlobTypeName id)
 		     else objectType		-- TODO: ?? for now ??
 
--- This is where we map from type to possible primitive
-mkType "PrelGHC.Intzh" = PrimType PrimInt
-mkType other           = Type other
-
+-- This is used to get inside constructors, to find out the types
+-- of the payload elements
 javaTauType :: Type.TauType -> Type
 javaTauType (TypeRep.TyConApp tycon _) = javaGlobType tycon
 javaTauType (TypeRep.NoteTy _ t)       = javaTauType t
 javaTauType _                          = objectType
 
+-- The function that makes the constructor name
 javaConstrWkrType :: DataCon -> Type
--- The function that makes the constructor
 javaConstrWkrType con = Type (javaConstrWkrName con)
-
-codeType, thunkType, objectType :: Type
-objectType = Type ("java.lang.Object")
-codeType   = Type codeName
-thunkType  = Type thunkName
 \end{code}
 
 %************************************************************************
@@ -519,6 +578,7 @@ lifted inner class).
    when lifting.
 
 \begin{code}
+{-
 type Bound = [Name]
 type Frees = [Name]
 
@@ -820,4 +880,6 @@ liftNew (Env _ env) typ@(Type name) exprs
 		-> New (Type nm) (map (\ v -> Var v (Type "<arg>")) args) Nothing
 	_ -> error "pre-lifted constructor with arguments"
 listNew _           typ exprs = New typ exprs Nothing
+
+-}
 \end{code}
diff --git a/ghc/compiler/javaGen/PrintJava.lhs b/ghc/compiler/javaGen/PrintJava.lhs
index 3acd84c774..e077d4eb23 100644
--- a/ghc/compiler/javaGen/PrintJava.lhs
+++ b/ghc/compiler/javaGen/PrintJava.lhs
@@ -27,7 +27,7 @@ compilationUnit :: CompilationUnit -> SDoc
 compilationUnit (Package n ds) = package n (decls ds)
 
 package = \n -> \ds ->
-  text "package" <+> name n <> text ";"
+  text "package" <+> packagename n <> text ";"
   $$
   ds
   
@@ -36,13 +36,13 @@ 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 ts ss -> method (modifiers mfs) (typ t) (name n) (parameters as) (throws ts) (statements ss)
+    { 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) (name n) (extends is) (decls ms)
-    ; Class mfs n x is ms -> clazz (modifiers mfs) (name n) (extends x) (implements is) (decls ms)
+    ; 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 ";"
@@ -91,22 +91,27 @@ 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))
+extends xs = text "extends" <+> hsep (punctuate comma (map typename xs))
 
 implements [] = empty
-implements xs = text "implements" <+> hsep (punctuate comma (map name xs))
+implements xs = text "implements" <+> hsep (punctuate comma (map typename xs))
 
 throws [] = empty
-throws xs = text "throws" <+> hsep (punctuate comma (map name xs))
+throws xs = text "throws" <+> hsep (punctuate comma (map typename xs))
 
-name n = text n
+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 t n) = modifiers mfs <+> typ t <+> name n
+parameter (Parameter mfs n) = modifiers mfs <+> nameTy n <+> name n
 
 typ (PrimType s)  = primtype s
-typ (Type n)      = name n
+typ (Type n)      = typename n
 typ (ArrayType t) = typ t <> text "[]"
 
 primtype PrimInt     = text "int"
@@ -116,8 +121,7 @@ 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)
   
@@ -169,8 +173,8 @@ maybeExpr (Just e) = Just (expr e)
            
 expr = \e ->
  case e of
-   { Var n _ -> name n
-   ; Literal l _ -> literal l
+   { 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