[finish new code generator
John Meacham <john@repetae.net>**20060126165801] hunk ./C/FromGrin2.hs 5
-import Control.Monad.State
hunk ./C/FromGrin2.hs 7
+import Control.Monad.State
hunk ./C/FromGrin2.hs 9
+import List(intersperse)
hunk ./C/FromGrin2.hs 14
+import Atom
+import CanType
hunk ./C/FromGrin2.hs 20
-import Grin.Grin
hunk ./C/FromGrin2.hs 21
+import GenUtil
+import Grin.Grin
hunk ./C/FromGrin2.hs 25
-import CanType
-import GenUtil
-import Atom
hunk ./C/FromGrin2.hs 38
-fetchVar :: Var -> C Expression
-fetchVar v = return $ (variable $ varName v)
+fetchVar :: Var -> Ty -> C Expression
+fetchVar v@(V n) _ | n < 0 = return $ (variable  $ varName v)
+fetchVar v ty = do
+    t <- convertType ty
+    return $ (localVariable t (varName v))
hunk ./C/FromGrin2.hs 57
-convertVal (Var v _) = fetchVar v
+convertVal (Var v ty) = fetchVar v ty
hunk ./C/FromGrin2.hs 66
+    ts <- mapM convertType (map getType xs)
hunk ./C/FromGrin2.hs 68
-    return (structAnon xs)
+    return (structAnon (zip xs ts))
hunk ./C/FromGrin2.hs 74
-    let f (TyPtr _) = nullPtr
-        f x = err $ "error-type " ++ show x
-    return (expr $ functionCall (name "jhc_error") [string s],f t)
+    let f (TyPtr _) = return nullPtr
+        f TyNode = return nullPtr
+        f (TyTup xs) = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts)
+        f (Ty x) = return $ cast (basicType (show x)) (constant $ number 0)
+        f x = return $ err $ "error-type " ++ show x
+    ev <- f t
+    return (expr $ functionCall (name "jhc_error") [string s],ev)
hunk ./C/FromGrin2.hs 103
-    nt <- nodeType t
+    nt <- nodeTypePtr t
hunk ./C/FromGrin2.hs 137
-nodeType a = return $ basicType ("struct " ++ show (nodeStructName a))
+nodeType a = return $ structType (nodeStructName a)
hunk ./C/FromGrin2.hs 150
-    let tmp' = project (nodeStructName t) (dereference tmp)
+    let tmp' = project' (nodeStructName t) tmp
hunk ./C/FromGrin2.hs 285
-
-    --ans = vcat $ includes ++ [line,enum_tag_t,line] ++ decls' ++ map cs tags ++ [text "",cn,text "",so,text "",text "/* Begin CAFS */"] ++ map ccaf (grinCafs grin) ++ [text "", consts, text "",text  "/* Begin Functions */"] ++ map prettyFuncP funcs ++ (map prettyFunc funcs)
-    ans = vcat $ includes ++ [line,enum_tag_t,line,header,line,union_node,line,text "/* Begin CAFS */"] ++ map ccaf (grinCafs grin) ++ [line, buildConstants finalHcHash, line,text  "/* Begin Functions */",body]
-
+    ans = vsep $ [vcat includes,enum_tag_t,header,union_node,text "/* CAFS */", vcat $ map ccaf (grinCafs grin), text "/* Constant Data */", buildConstants finalHcHash,text  "/* Functions */",body]
hunk ./C/FromGrin2.hs 287
-
-    (header,body) = generateC (jhc_sizeof:functions) []
-{-
-    cs (t,ts) = prettyDecl $ CStruct (toStruct t) ((tag_t, "tag"):map cst (zip [1..] ts))
-    cst (i,t) = (runIdentity $ toType' t, text $ 'a':show i)
-    -}
+    (header,body) = generateC (jhc_sizeof:functions) structs
hunk ./C/FromGrin2.hs 291
-    (functions,finalHcHash,req) = runC (mapM convertFunc $ grinFunctions grin)
+    ((functions,structs),finalHcHash,req) = runC $ do
+        funcs <- mapM convertFunc $ grinFunctions grin
+        sts <- flip mapM tags $ \ (n,ts) -> do
+            ts' <- mapM convertType ts
+            return (nodeStructName n,zip [ name $ 'a':show i | i <-  [1 ..] ] ts')
+        return (funcs,sts)
+
+
hunk ./C/FromGrin2.hs 301
-        cs t = text "  case " <> tshow (nodeTagName t) <> char ':' <+> text "return sizeof(" <> tshow (nodeStructName t) <>  text ");\n"
+        cs t = text "  case " <> tshow (nodeTagName t) <> char ':' <+> text "return sizeof(struct " <> tshow (nodeStructName t) <>  text ");\n"
hunk ./C/FromGrin2.hs 307
+vsep xs = vcat $ intersperse line xs
hunk ./C/FromGrin2.hs 312
-        cd = text "static " <> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (tshow (nodeTagName a):rs)) <> text "};"
+        cd = text "static struct " <> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (tshow (nodeTagName a):rs)) <> text "};"
hunk ./C/Generate.hs 43
+    structType,
hunk ./C/Generate.hs 53
-import Data.Monoid
-import Control.Monad
-import Control.Monad.RWS
hunk ./C/Generate.hs 54
-import Text.PrettyPrint.HughesPJ(Doc,render,nest,($$),($+$))
-import Numeric
-import Maybe(isNothing)
+import Control.Monad.RWS
+import Data.Monoid
hunk ./C/Generate.hs 57
+import Maybe(isNothing)
+import Numeric
+import qualified Data.Map as Map
+import Text.PrettyPrint.HughesPJ(Doc,render,nest,($$),($+$))
hunk ./C/Generate.hs 62
-import Util.UniqueMonad
-import GenUtil
hunk ./C/Generate.hs 63
-import C.Prims
+import GenUtil
+
hunk ./C/Generate.hs 66
-newtype G a = G (RWS () [()] Int a)
-    deriving(Monad,MonadWriter [()],MonadState Int)
+newtype G a = G (RWS () [(Name,Type)] (Int,Map.Map [Type] Name) a)
+    deriving(Monad,MonadWriter [(Name,Type)],MonadState (Int,Map.Map [Type] Name))
hunk ./C/Generate.hs 71
+    deriving(Eq,Ord)
hunk ./C/Generate.hs 77
-data Type = T (G Doc)
hunk ./C/Generate.hs 79
-data Statement = SD (G Doc)
+newtype Statement = SD (G Doc)
hunk ./C/Generate.hs 82
+data Type = TB String | TPtr Type | TAnon [Type] | TNStruct Name
+    deriving(Eq,Ord)
+
hunk ./C/Generate.hs 124
-    draw (T x) = x
-    err s = T $ terr s
+    draw (TB x) = text x
+    draw (TPtr x) = draw x <> char '*'
+    draw (TAnon ts) = do
+        (n,mp) <- get
+        case Map.lookup ts mp of
+            Just x -> text "struct" <+> draw x
+            Nothing -> do
+                let nm = name ("tup" ++ show n)
+                put (n + 1,Map.insert ts nm mp)
+                text "struct" <+> draw nm
+    draw (TNStruct n) = text "struct" <+> draw n
+
+    err s = TB $ terr s
hunk ./C/Generate.hs 140
-sizeof t = expC (parens $ draw t)
+sizeof t = expC (text "sizeof" <> parens $ draw t)
hunk ./C/Generate.hs 143
-cast t e = expD (parens (draw t) <> pdraw e)
+cast t e = expDC (parens (draw t) <> pdraw e)
hunk ./C/Generate.hs 162
-project' n e = project n $ dereference e
+project' n e = expD (pdraw e <> text "->" <> draw n)
hunk ./C/Generate.hs 165
-projectAnon n e = project (Name $ 'a':show n) e
+projectAnon n e = project (Name $ 't':show n) e
hunk ./C/Generate.hs 171
-localVariable _t n = variable n
+localVariable t n = expD $ do
+    tell [(n,t)]
+    draw n
hunk ./C/Generate.hs 187
-structAnon :: [Expression] -> Expression
-structAnon es = err "structAnon"
+commaExpression :: [Expression] -> Expression
+commaExpression [] = emptyExpression
+commaExpression [e] = e
+commaExpression ss = expD $ do
+    ds <- mapM draw ss
+    return (tupled ds)
+
+structAnon :: [(Expression,Type)] -> Expression
+--structAnon _ = err "structAnon"
+structAnon es = Exp ThNone $ ED $ do
+    (n,mp) <- get
+    put (n + 1,mp)
+    let nm = name ("_t" ++ show n)
+        lv = localVariable (anonStructType (snds es)) nm
+    draw $ commaExpression $ [operator "=" (projectAnon i lv) e | e <- fsts es | i <- [0..] ] ++ [lv]
hunk ./C/Generate.hs 263
-    return (localVariable t (name $ '_':'u':show u))
+    return (localVariable t (name $ 'x':show u))
hunk ./C/Generate.hs 305
-    body <- draw (functionBody f)
+    (body,uv) <- listen (draw (functionBody f))
+    uv' <- flip mapM [ (x,t) | (x,t) <- snubUnder fst uv, x `notElem` fsts (functionArgs f)] $ \ (n,t) -> do
+        t <- draw t
+        return $ t <+> tshow n <> semi
hunk ./C/Generate.hs 314
-    let proto = text "static" <+> frt <+> name <> tupled fas <> semi
-        proto' = text "static" <+> frt $$ name <> tupled fas
-    return (proto, proto' $+$ char '{' $+$ nest 8 body $+$ char '}')
+    let fas' = if null fas then [text "void"] else fas
+    let proto = text "static" <+> frt <+> name <> tupled fas' <> semi
+        proto' = text "static" <+> frt $$ name <> tupled fas'
+    return (proto, proto' $+$ lbrace $+$ nest 8 (vcat uv' $$ body) $+$ rbrace)
hunk ./C/Generate.hs 321
-anonStructType ts = err "anonStructType"
+anonStructType ts = TAnon ts
hunk ./C/Generate.hs 324
-basicType s = T (text s)
+basicType s = TB s
+
+structType :: Name -> Type
+structType n = TNStruct n
hunk ./C/Generate.hs 330
-ptrType t = T (draw t <> char '*')
+ptrType t = TPtr t
hunk ./C/Generate.hs 385
-        return (vcat protos $$ line $$  vsep bodys)
-    (fns,_,written) = runRWS ga () 1
-    ans = (empty,fns)
+        let shead = vcat $ map (text . (++ ";") . ("struct " ++) . show . fst) ss
+        shead2 <- declStructs True ss
+        return (shead $$ line $$ shead2, vcat protos $$ line $$  vsep bodys)
+    ((hd,fns),(_,ass),written) = runRWS ga () (1,Map.empty)
+
+    anons = [ (n, fields ts ) | (ts,n) <- Map.toList ass ] where
+        fields :: [Type] -> [(Name,Type)]
+        fields ts = [ (name ('t':show tn),t) | t <- ts | tn <- [0::Int .. ]]
+    G anons' = declStructs False anons
+    (anons'',_,_) = runRWS anons' () (1,Map.empty)
+
+    declStructs ht ss = liftM vsep $ flip mapM ss $ \ (n,ts) -> do
+            ts' <- flip mapM ts $ \ (n,t) -> do
+                t <- draw t
+                return $ t <+> tshow n <> semi
+            return $ text "struct" <+> tshow n <+> lbrace $$ nest 4 (vcat $ (if ht then text "tag_t tag;" else empty):ts') $$ rbrace <> semi
+    ans = (hd $$ anons'',fns)
hunk ./C/Generate.hs 425
-    (fns,_,_) = runRWS ga () 1
+    (fns,_,_) = runRWS ga () (1,Map.empty)
hunk ./data/jhc_rts.c 43
-static void XAmain(void) A_REGPARM;
+static void _amain(void) A_REGPARM;
hunk ./data/jhc_rts.c 110
-        XAmain();
+        _amain();