Commit a3837710 authored by apt's avatar apt
Browse files

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

external core: omit repn for recursive newtypes and fix char literals
parent f5c94708
......@@ -12,7 +12,7 @@ data Module
data Tdef
= Data Tcon [Tbind] [Cdef]
| Newtype Tcon [Tbind] Ty
| Newtype Tcon [Tbind] (Maybe Ty)
data Cdef
= Constr Dcon [Tbind] [Ty]
......
......@@ -87,14 +87,16 @@ collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) =
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs tcon tdefs
| isAlgTyCon tcon = tdef : tdefs
| isAlgTyCon tcon = tdef: tdefs
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
......@@ -151,7 +153,8 @@ make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
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
......@@ -185,12 +188,14 @@ make_kind _ = error "MkExternalCore died: make_kind"
{- 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
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)
......
......@@ -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)))))
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)])
......@@ -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) =
'\\':'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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment