[project @ 2001-07-19 15:33:17 by apt]

external core: omit repn for recursive newtypes and fix char literals

diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs
index 4894deb..cadb639 100644 (file)
--- a/ghc/compiler/coreSyn/ExternalCore.lhs
+++ b/ghc/compiler/coreSyn/ExternalCore.lhs
@@ -12,7 +12,7 @@ data Module
 
 data Tdef 
   = Data Tcon [Tbind] [Cdef]
 
 data Tdef 
   = Data Tcon [Tbind] [Cdef]

-  | Newtype Tcon [Tbind] Ty
+  | Newtype Tcon [Tbind] (Maybe Ty)

 
 data Cdef 
   = Constr Dcon [Tbind] [Ty]
 
 data Cdef 
   = Constr Dcon [Tbind] [Ty]

diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
index b8e17cc..9b0a507 100644 (file)
--- a/ghc/compiler/coreSyn/MkExternalCore.lhs
+++ b/ghc/compiler/coreSyn/MkExternalCore.lhs
@@ -87,14 +87,16 @@ collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) =
 
 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
 collect_tdefs tcon tdefs 
 
 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
 collect_tdefs tcon tdefs 

-  | isAlgTyCon tcon = tdef : tdefs
+  | isAlgTyCon tcon = tdef: tdefs

   where
   where

-    tdef | isNewTyCon tcon
-        = C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) (make_ty rep)
-        | otherwise
-        = C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
-    (_, rep) = newTyConRep tcon
-    tyvars   = tyConTyVars tcon
+    tdef | isNewTyCon tcon = 
+                C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) repclause 
+         | otherwise = 
+                C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
+         where repclause | isRecursiveTyCon tcon = Nothing
+                        | otherwise = Just (make_ty rep)
+                                           where (_, rep) = newTyConRep tcon
+    tyvars = tyConTyVars tcon

 
 collect_tdefs _ tdefs = tdefs
 
 
 collect_tdefs _ tdefs = tdefs
 

@@ -151,7 +153,8 @@ make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 make_lit :: Literal -> C.Lit
 make_lit l = 
   case l of
 make_lit :: Literal -> C.Lit
 make_lit l = 
   case l of

-    MachChar i -> C.Lchar (chr i) t
+    MachChar i | i <= 0xff -> C.Lchar (chr i) t
+    MachChar i | otherwise -> C.Lint (toEnum i) t

     MachStr s -> C.Lstring (_UNPK_ s) t
     MachAddr i -> C.Lint i t  
     MachInt i -> C.Lint i t
     MachStr s -> C.Lstring (_UNPK_ s) t
     MachAddr i -> C.Lint i t  
     MachInt i -> C.Lint i t

@@ -185,12 +188,14 @@ make_kind _ = error "MkExternalCore died: make_kind"
 
 {- Id generation. -}
 
 
 {- Id generation. -}
 

-{- Use encoded strings, except restore non-leading '#'s.
+{- Use encoded strings, except restore '#'s.

    Also, adjust casing to work around some badly-chosen internal names. -}
 make_id :: Bool -> Name -> C.Id
 make_id is_var nm = 
   case n of
    Also, adjust casing to work around some badly-chosen internal names. -}
 make_id :: Bool -> Name -> C.Id
 make_id is_var nm = 
   case n of

-    c:cs -> if isUpper c && is_var then (toLower c):(decode cs) else (decode n)
+    c:cs -> if isUpper c && is_var then (toLower c):(decode cs) 
+           else if isLower c && (not is_var) then (toUpper c):(decode cs)
+            else decode n

   where n = (occNameString . nameOccName) nm
         decode ('z':'h':cs) = '#':(decode cs)
         decode (c:cs) = c:(decode cs)
   where n = (occNameString . nameOccName) nm
         decode ('z':'h':cs) = '#':(decode cs)
         decode (c:cs) = c:(decode cs)

diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs
index 8ed16c5..c7e51e3 100644 (file)
--- a/ghc/compiler/coreSyn/PprExternalCore.lhs
+++ b/ghc/compiler/coreSyn/PprExternalCore.lhs
@@ -55,8 +55,11 @@ ptdef (Data tcon tbinds cdefs) =
   (text "%data" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
   $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
 
   (text "%data" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
   $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
 

-ptdef (Newtype tcon tbinds ty ) =
-  text "%newtype" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> char '=' <+> pty ty 
+ptdef (Newtype tcon tbinds rep ) =
+  text "%newtype" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> repclause
+       where repclause = case rep of
+                           Just ty -> char '=' <+> pty ty 
+                          Nothing -> empty

 
 pcdef (Constr dcon tbinds tys)  =
   (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
 
 pcdef (Constr dcon tbinds tys)  =
   (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])

@@ -160,14 +163,10 @@ pstring s = doubleQuotes(text (escape s))
 escape s = foldr f [] (map ord s)
     where 
      f cv rest | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = 
 escape s = foldr f [] (map ord s)
     where 
      f cv rest | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = 

-        '\\':'u':h3:h2:h1:h0:rest
-           where (q3,r3) = quotRem cv (16*16*16) 
-                h3 = toUpper(intToDigit q3)
-                (q2,r2) = quotRem r3 (16*16)
-                 h2 = toUpper(intToDigit q2)
-                (q1,r1) = quotRem r2 16
-                h1 = toUpper(intToDigit q1)
-                 h0 = toUpper(intToDigit r1)
+        '\\':'x':h1:h0:rest
+           where (q1,r1) = quotRem cv 16
+                h1 = intToDigit q1
+                 h0 = intToDigit r1

      f cv rest = (chr cv):rest
 
 \end{code}
      f cv rest = (chr cv):rest
 
 \end{code}