[add conversion of c-- operators to c code
John Meacham <john@repetae.net>**20070530024356] hunk ./C/FromGrin2.hs 141
+convertVal (Tup [x]) = convertVal x
+convertVal v | Just e <- convertConst v = return e
hunk ./C/FromGrin2.hs 144
-convertVal (Const (NodeC h _)) | h == tagHole = return (cast sptr_t (f_VALUE (constant $ number 0)))
hunk ./C/FromGrin2.hs 158
-convertVal (Lit i ty)
-    | ty == Ty (toAtom "float") || ty == Ty (toAtom "double") = return (constant $ floating (fromIntegral i))
-    | otherwise = return (constant $ number (fromIntegral i))
hunk ./C/FromGrin2.hs 159
-convertVal (Tup [x]) = convertVal x
-convertVal (Tup []) = return emptyExpression
hunk ./C/FromGrin2.hs 170
-convertVal (ValPrim (APrim p _) [x] _) = do
+convertVal (ValPrim (APrim p _) [x] (TyPrim opty)) = do
hunk ./C/FromGrin2.hs 173
-        CCast _ to -> return $ cast (basicType to) x'
---        Operator n [_] r ->  return $ cast (basicType r) (uoperator n x')
+        CCast _ to -> return $ cast (opTyToC opty) x'
+        Op (Op.UnOp n ta) r -> primUnOp n ta r x'
+        Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x'
hunk ./C/FromGrin2.hs 181
---        Operator n [_,_] r -> return $ cast (basicType r) (operator n x' y')
+        Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y'
hunk ./C/FromGrin2.hs 192
-convertType (TyPrim (Op.TyBits (Op.BitsExt s) _)) = return (basicType s)
-convertType (TyPrim (Op.TyBits (Op.Bits n) _)) = return (basicType $ "uint" ++ show n ++ "_t")
-convertType (TyPrim (Op.TyBits (Op.BitsArch Op.BitsInt) _)) = return $ basicType "unsigned"
-convertType (TyPrim (Op.TyBits (Op.BitsArch Op.BitsMax) _)) = return $ basicType "uintmax_t"
-convertType (TyPrim (Op.TyBits (Op.BitsArch Op.BitsPtr) _)) = return $ basicType "uintptr_t"
hunk ./C/FromGrin2.hs 198
-opTyToC opty = basicType (opTyToC' opty)
+forceHint _ Op.TyBool = Op.TyBool
+forceHint h (Op.TyBits b _) = Op.TyBits b h
+
+tyToC _ Op.TyBool = "bool"
+tyToC dh (Op.TyBits (Op.BitsExt s) _) = s
+tyToC dh (Op.TyBits b h) = f b h where
+    f b Op.HintNone = f b dh
+    f b Op.HintUnsigned = case b of
+        (Op.Bits n) ->  "uint" ++ show n ++ "_t"
+        (Op.BitsArch Op.BitsInt) -> "unsigned"
+        (Op.BitsArch Op.BitsMax) -> "uintmax_t"
+        (Op.BitsArch Op.BitsPtr) -> "uintptr_t"
+    f b Op.HintSigned = case b of
+        (Op.Bits n) ->  "int" ++ show n ++ "_t"
+        (Op.BitsArch Op.BitsInt) -> "int"
+        (Op.BitsArch Op.BitsMax) -> "intmax_t"
+        (Op.BitsArch Op.BitsPtr) -> "intptr_t"
+
+
+opTyToC opty = basicType (tyToC Op.HintUnsigned opty)
+
+opTyToC' opty = tyToC Op.HintUnsigned opty
hunk ./C/FromGrin2.hs 221
-opTyToC' Op.TyBool = "bool"
-opTyToC' (Op.TyBits (Op.BitsExt s) _) = s
-opTyToC' (Op.TyBits (Op.Bits n) _) =  "uint" ++ show n ++ "_t"
-opTyToC' (Op.TyBits (Op.BitsArch Op.BitsInt) _) = "unsigned"
-opTyToC' (Op.TyBits (Op.BitsArch Op.BitsMax) _) = "uintmax_t"
-opTyToC' (Op.TyBits (Op.BitsArch Op.BitsPtr) _) = "uintptr_t"
hunk ./C/FromGrin2.hs 344
-        f (Ty x) = return $ cast (basicType (show x)) (constant $ number 0)
+        f (TyPrim x) = return $ cast (opTyToC x) (constant $ number 0)
+        --f (Ty x) = return $ cast (basicType (show x)) (constant $ number 0)
hunk ./C/FromGrin2.hs 517
-        f (Left v) | Just e <- convertConst v = text (show $ drawG e)
+        f (Left v) = text (show $ drawG e) where
+            Just e = convertConst v
hunk ./C/FromGrin2.hs 521
-convertConst (Const (NodeC h _)) | h == tagHole = return nullPtr
+convertConst (Const (NodeC h _)) | h == tagHole = return (cast sptr_t (f_VALUE (constant $ number 0)))
+convertConst (Lit i (TyPrim Op.TyBool)) = return $ if i == 0 then constant cFalse else constant cTrue
+convertConst (Lit i (TyPrim (Op.TyBits _ Op.HintFloat))) = return (constant $ floating (realToFrac i))
hunk ./C/FromGrin2.hs 536
---        Operator n [_] r ->  return $ cast (basicType r) (uoperator n x')
+        Op (Op.UnOp n ta) r -> primUnOp n ta r x'
+        Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x'
hunk ./C/FromGrin2.hs 543
---        Operator n [_,_] r -> return $ cast (basicType r) (operator n x' y')
+        Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y'
hunk ./C/FromGrin2.hs 555
---    | APrim (Operator n [ta] r) _ <- primAPrim p, [a] <- vs = do
---        a' <- convertVal a
---        return $ cast (basicType r) (uoperator n a')
---    | APrim (Operator n [ta,tb] r) _ <- primAPrim p, [a,b] <- vs = do
---        a' <- convertVal a
---        b' <- convertVal b
---        return $ cast (basicType r) (operator n a' b')
+    | APrim Op {} _ <- primAPrim p = do
+        let (_,rt) = primType p
+        convertVal (ValPrim (primAPrim p) vs rt)
hunk ./C/FromGrin2.hs 572
+signedOps = [
+    (Op.Div,"/"),  -- TODO round to -Infinity
+    (Op.Mod,"%"),  -- TODO round to -Infinity
+    (Op.Quot,"/"),
+    (Op.Rem,"%"),
+    (Op.Shra,">>"),
+    (Op.Gt,">"),
+    (Op.Lt,"<"),
+    (Op.Gte,">="),
+    (Op.Lte,"<=")
+    ]
+
+
+binopSigned :: Op.BinOp -> Maybe String
+binopSigned b = lookup b signedOps
+
+castSigned ty v = return $ cast (basicType $ tyToC Op.HintSigned ty) v
+
+primBinOp n ta tb r a b
+    | Just (t,_) <- Op.binopInfix n = return $ operator t a b
+    | Just t <- binopSigned n = do
+        a <- castSigned ta a
+        b <- castSigned tb b
+        return $ operator t a b
+    | otherwise = return $ err ("primBinOp: " ++ show ((n,ta,tb,r),a,b))
+
+primUnOp Op.Neg ta r a = do
+    a <- castSigned ta a
+    return $ uoperator "-" a
+primUnOp Op.Com ta r a = do return $ uoperator "~" a
+primUnOp n ta r a
+    | otherwise = return $ err ("primUnOp: " ++ show ((n,ta,r),a))
+
hunk ./C/FromGrin2.hs 630
-{-
-newNode ty node = do
-    u <- newUniq
-    let n = name $ 'x':show u
-    d <- newVarNode ty n node
-    return (d,localVariable ty n)
--}
hunk ./C/FromGrin2.hs 694
---------
--- shape
---------
-
-
-toShape TyPtr {} = ShapeNativePtr
-toShape TyNode = ShapeNativePtr
-toShape (Ty bt)
-    | show bt == "int" = ShapeNativeInt
-    | show bt == "HsPtr" = ShapeNativePtr
-    | show bt == "HsFunPtr" = ShapeNativePtr
-toShape (Ty bt) = case genericPrimitiveInfo (show bt) of
-    Just v -> ShapeBits $ primTypeSizeOf v
-    Nothing -> error $ "toShape: " ++ show bt
-toShape t = error $ "toShape: " ++ show t
-
-newtype Shapes = Shapes [Shape]
-    deriving(Eq,Ord)
-
-data Shape = ShapeNativePtr | ShapeNativeInt | ShapeBits !Int
-    deriving(Eq,Ord)
-
-instance Show Shape where
-    showsPrec _ ShapeNativeInt = ('i':)
-    showsPrec _ ShapeNativePtr = ('p':)
-    showsPrec _ (ShapeBits n) = ('b':) . shows n
-
-instance Show Shapes where
-    showsPrec _ (Shapes s) = foldr (.) id (map shows s)
+castFunc :: Op.ConvOp -> Op.Ty -> Op.Ty -> Expression -> Expression
+castFunc co ta tb e | ta == tb = e
+castFunc co _ Op.TyBool e = cast (basicType "bool") e
+castFunc co Op.TyBool tb e = cast (opTyToC tb) e
+-- TODO fix
+castFunc _ _ tb e = cast (opTyToC tb) e