[add extension to allow multiple return values from c functions
John Meacham <john@repetae.net>**20120209142228
 Ignore-this: 51e4a3f9ca80ff2eae7f21376f0a0992
] hunk ./src/C/FromGrin2.hs 563
+convertExp (Prim (Func _ n as r rs@(_:_)) vs ty) = do
+        vs' <- mapM convertVal vs
+        rt <- mapM convertType ty
+        let rrs = map basicType' (r:rs)
+        ras <- mapM (newVar . basicType') rs
+        (stmt,rv) <- basicType' r `newTmpVar` (functionCall (name $ unpackPS n) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras))
+        return $ (stmt, structAnon (zip (rv:ras) rt))
hunk ./src/C/FromGrin2.hs 664
-        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimSizeOf } -> return $ expressionRaw ("sizeof(" ++ tyToC Op.HintUnsigned arg ++ ")")
-        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMinBound } -> return $ expressionRaw ("prim_minbound(" ++ tyToC Op.HintUnsigned arg ++ ")")
-        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMaxBound } -> return $ expressionRaw ("prim_maxbound(" ++ tyToC Op.HintUnsigned arg ++ ")")
-        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimUMaxBound } -> return $ expressionRaw ("prim_umaxbound(" ++ tyToC Op.HintUnsigned arg ++ ")")
+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimSizeOf } -> 
+            return $ expressionRaw ("sizeof(" ++ tyToC Op.HintUnsigned arg ++ ")")
+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMinBound } -> 
+            return $ expressionRaw ("prim_minbound(" ++ tyToC Op.HintUnsigned arg ++ ")")
+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMaxBound } -> 
+            return $ expressionRaw ("prim_maxbound(" ++ tyToC Op.HintUnsigned arg ++ ")")
+        PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimUMaxBound } -> 
+            return $ expressionRaw ("prim_umaxbound(" ++ tyToC Op.HintUnsigned arg ++ ")")
hunk ./src/C/FromGrin2.hs 695
-    | (Func _ n as r) <- p = do
+    | (Func _ n as r []) <- p = do
+        vs' <- mapM convertVal vs
+        rt <- convertTypes ty
+        return $ cast rt (functionCall (name $ unpackPS n) [ cast (basicType' t) v | v <- vs' | t <- as ])
+    | (Func _ n as r rs) <- p = do
hunk ./src/C/FromGrin2.hs 702
-        return $ cast (rt) (functionCall (name $ unpackPS n) [ cast (basicType' t) v | v <- vs' | t <- as ])
+        ras <- mapM (newVar . basicType') rs
+        return $ cast rt (functionCall (name $ unpackPS n) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras))
hunk ./src/C/Prims.hs 56
-    PrimPrim Atom          -- Special primitive implemented in the compiler somehow.
+    PrimPrim Atom -- Special primitive implemented in the compiler somehow.
hunk ./src/C/Prims.hs 65
-        primRetType :: ExtType
+        primRetType :: ExtType,
+	primRetArgs :: [ExtType]
hunk ./src/C/Prims.hs 75
-        primConst :: !PackedString         -- address of linker name
+        primConst :: !PackedString -- address of linker name
hunk ./src/C/Prims.hs 84
-    | PrimString !PackedString                                 -- address of a raw string. encoded in utf8.
+    | PrimString !PackedString  -- address of a raw string. encoded in utf8.
hunk ./src/E/FromHs.hs 243
-createFunc :: [E] -> ([TVr] -> (E -> E,E)) -> C E
+createFunc :: [E] -> ([TVr] -> C (E -> E,E)) -> C E
hunk ./src/E/FromHs.hs 258
-        (me,innerE) = ee tvrs'
-        eee = me $ foldr esr innerE xs
+    (me,innerE) <- ee tvrs'
+    let eee = me $ foldr esr innerE xs
hunk ./src/E/FromHs.hs 319
-    addWarning w = Ce $ tell [w]
+    addWarning w = liftIO (addWarning w)
hunk ./src/E/FromHs.hs 350
+fromTuple_ :: Monad m => E -> m [E]
+fromTuple_ (ELit LitCons { litName = n, litArgs = as }) | Just c <- fromUnboxedNameTuple n, c == length as = return as
+fromTuple_ e = fail "fromTuple_ : not unboxed tuple"
+
hunk ./src/E/FromHs.hs 383
-    -- (c) whether it's IO-like or not
-    -- (d) the real return type
-    -- (e) the arguments themselves
+    -- (c) the extra return variables passed back in pointers
+    -- (d) the arguments themselves
+    -- (e) the real return type
hunk ./src/E/FromHs.hs 387
-    ccallHelper :: ([ExtType] -> ExtType -> Bool -> [E] -> E -> E) -> E -> C E
+    invalidDecl s = addWarn InvalidDecl s >> fail s
+    ccallHelper :: ([ExtType] -> ExtType -> [ExtType] -> [E] -> E -> E) -> E -> C E
hunk ./src/E/FromHs.hs 390
-        let (ts,isIO,rt') = extractIO' ty
+        let (ts,isIO,rt) = extractIO' ty
hunk ./src/E/FromHs.hs 392
+        let (rt':ras) = case fromTuple_ rt of
+                Just (x:ys@(_:_)) -> (x:ys)
+                _ -> [rt]
+        ras' <- forM ras $ \t -> ffiTypeInfo ExtTypeVoid t return
hunk ./src/E/FromHs.hs 400
-            prim = myPrim (map extTypeInfoExtType cts) (extTypeInfoExtType pt)
-        case (isIO,pt) of
-            (True,ExtTypeVoid) -> cFun $ \rs -> (,) (ELam tvrWorld) $
-                        eStrictLet tvrWorld2
-                                   (prim True
-                                         (EVar tvrWorld
-                                          :[EVar t | t <- rs ])
-                                         tWorld__)
-                                   (eJustIO (EVar tvrWorld2) vUnit)
-            (False,ExtTypeVoid) -> fail "pure foreign function must return a valid value"
-            (_,ExtTypeBoxed cn rtt' _) -> do
+            prim = myPrim (map extTypeInfoExtType cts) (extTypeInfoExtType pt) (map extTypeInfoExtType ras')
+        case (isIO,pt,ras') of
+            (True,ExtTypeVoid,[]) -> cFun $ \rs -> return (ELam tvrWorld, 
+                eStrictLet tvrWorld2 (prim (EVar tvrWorld :[EVar t | t <- rs ]) tWorld__)
+                    (eJustIO (EVar tvrWorld2) vUnit))
+            (False,ExtTypeVoid,_) -> invalidDecl  "pure foreign function must return a non void value"
+            (True,_,(_:_)) -> invalidDecl "IO-like functions may not return a tuple"
+            (_,ExtTypeBoxed cn rtt' _,[]) -> do
hunk ./src/E/FromHs.hs 411
-                    False -> cFun $ \rs -> (,) id $
-                                 eStrictLet rtVar'
-                                           (prim False
-                                                 [ EVar t | t <- rs ]
-                                                 rtt')
-                                           (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
-                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
-                                eCaseTup' (prim True
-                                                (EVar tvrWorld:[EVar t | t <- rs ])
-                                                rttIO')
-                                          [tvrWorld2,rtVar']
-                                          (eLet rtVar
-                                                (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
-                                                (eJustIO (EVar tvrWorld2) (EVar rtVar)))
-            (_,ExtTypeRaw  _) -> do
-                [rtVar] <- newVars [rt']
+                    False -> cFun $ \rs -> return (id,
+                        eStrictLet rtVar' (prim [ EVar t | t <- rs ] rtt')
+                            (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }))
+                    True -> cFun $ \rs -> return $ (,) (ELam tvrWorld) $
+                        eCaseTup' (prim (EVar tvrWorld:[EVar t | t <- rs ]) rttIO') [tvrWorld2,rtVar']
+                            (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
+                                (eJustIO (EVar tvrWorld2) (EVar rtVar)))
+            (True,ExtTypeRaw  _,[]) -> do
hunk ./src/E/FromHs.hs 420
-                case isIO of
-                    False -> cFun $ \rs -> (,) id $ (prim False [ EVar t | t <- rs ] rt')
-                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $ (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
-                                --eCaseTup' (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
-                                --          [tvrWorld2,rtVar]
-                                --          (eJustIO (EVar tvrWorld2) (EVar rtVar))
+                cFun $ \rs -> return (ELam tvrWorld,prim (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
+            (False,_,(_:_)) -> do
+                let rets = (rt':ras)
+                rets' <- mapM unboxedVersion rets
+                cFun $ \rs -> do
+                fun <- extractUnboxedTup (prim [ EVar t | t <- rs ] (ltTuple' rets')) $ \vs -> do
+                    rv <- zipWithM marshallFromC vs rets
+                    return $ eTuple' rv
+                return (id,fun)
+            _ -> invalidDecl "foreign declaration is of incorrect form."
+
+    isExtTypeRaw ExtTypeRaw {} = True
+    isExtTypeRaw _ = False
hunk ./src/E/FromHs.hs 458
-            _ -> fail "foreign import of address must be of a boxed type"
+            _ -> invalidDecl "foreign import of address must be of a boxed type"
hunk ./src/E/FromHs.hs 464
-                     (\cts crt io args rt ->
-                      EPrim (Func req (packString rcn) cts crt) args rt)
+                     (\cts crt cras args rt ->
+                      EPrim (Func req (packString rcn) cts crt cras) args rt)
hunk ./src/E/FromHs.hs 474
-
hunk ./src/E/FromHs.hs 475
-                     (\cts crt io args rt ->
+                     (\cts crt cras args rt ->
hunk ./src/E/FromHs.hs 482
-        let --(ts,rt) = argTypes' ty
-            --(isIO,rt') = extractIO' rt
-            (ts,isIO,rt') = extractIO' ty
+        let (ts,isIO,rt') = extractIO' ty
hunk ./src/E/FromHs.hs 490
-            (True,ExtTypeVoid) -> cFun $ \rs -> (,) (ELam tvrWorld) $
+            (True,ExtTypeVoid) -> cFun $ \rs -> return $  (,) (ELam tvrWorld) $
hunk ./src/E/FromHs.hs 492
-            (False,ExtTypeVoid) -> fail "pure foreign function must return a valid value"
+            (False,ExtTypeVoid) -> invalidDecl "pure foreign function must return a valid value"
hunk ./src/E/FromHs.hs 499
-                    False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | t <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
-                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
+                    False -> cFun $ \rs -> return $ (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | t <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
+                    True -> cFun $ \rs -> return $ (,) (ELam tvrWorld) $
hunk ./src/E/FromHs.hs 504
-    cDecl x@HsForeignDecl {} = fail ("Unsupported foreign declaration: "++ show x)
+    cDecl x@HsForeignDecl {} = invalidDecl ("Unsupported foreign declaration: "++ show x)
hunk ./src/E/FromHs.hs 524
-                ExtTypeVoid -> fail "attempt to foreign export function with void argument"
+                ExtTypeVoid -> invalidDecl "attempt to foreign export function with void argument"
hunk ./src/E/FromHs.hs 678
-    cExpr e = fail ("Cannot convert: " ++ show e)
+    cExpr e = invalidDecl ("Cannot convert: " ++ show e)
hunk ./src/E/FromHs.hs 769
-{-
-patVar ::
-    Monad m
-    => HsPat -- ^ the pattern
-    -> E     -- ^ the type of the expression
-    -> Ce m (HsPat,TVr)  -- ^ a new pattern and a binding variable
-patVar HsPWildCard t = return (HsPWildCard,tvr { tvrType = t })
-patVar (HsPVar n) t | isTypePlaceholder n = return (HsPWildCard,tvr { tvrType = t })
-patVar (HsPAsPat n p) t | not (isTypePlaceholder n) = do
-    nn <- convertVar (toName Name.Val n)
-    return (p,nn)
-patVar (HsPAsPat n p) t | isTypePlaceholder n = patVar p t
-patVar p t = do
-    [nv] <- newVars [t]
-    return (p,nv)
-    -}
-
hunk ./src/E/FromHs.hs 1001
+
+unboxedVersion t = do
+    ffiTypeInfo Unknown t $ \eti -> case eti of
+        ExtTypeBoxed _ uv _ -> return uv
+        ExtTypeRaw _ -> return t
+        ExtTypeVoid -> return (eTuple' [])
+
hunk ./src/E/FromHs.hs 1025
+
+extractUnboxedTup :: E -> ([E] -> C E) -> C E
+extractUnboxedTup e f = do
+    vs <- newVars $ concat (fromTuple_ (getType e))
+    a <- f (map EVar vs)
+    return $ eCaseTup' e vs a
hunk ./src/FrontEnd/Syn/Traverse.hs 176
+traverseHsType _ HsTyAssoc = return HsTyAssoc