[project @ 2000-04-04 13:40:27 by panne]

Enable Bool in foreign import/export

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 6170b1b..030f98a 100644 (file)
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -34,11 +34,16 @@ import Type         ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
                          splitTyConApp_maybe, tyVarsOfType, mkForAllTys, Type
                        )
 import TysPrim         ( byteArrayPrimTy, realWorldStatePrimTy,
-                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
-import TysWiredIn      ( unitDataConId, stringTy,
+                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+                         intPrimTy
+                       )
+import TysWiredIn      ( unitDataConId, stringTy, boolTy,
+                         falseDataCon, falseDataConId,
+                         trueDataCon, trueDataConId,
                          unboxedPairDataCon,
                          mkUnboxedTupleTy, unboxedTupleCon
                        )
+import Literal         ( mkMachInt )
 import CStrings                ( CLabelString )
 import Unique          ( Unique )
 import VarSet          ( varSetElems )
@@ -174,6 +179,16 @@ unboxArg arg
              \ body -> Case arg case_bndr [(DataAlt box_data_con,[prim_arg],body)]
     )
 
+  -- Booleans; Hacking alert: the 0/1 literals should match the HsFalse/HsTrue constants
+  | arg_ty == boolTy
+  = newSysLocalDs intPrimTy            `thenDs` \ prim_arg ->
+    returnDs (Var prim_arg,
+             \ body -> Case (Case arg (mkWildId arg_ty) [
+                                (DataAlt falseDataCon,[],mkIntLit 0),
+                                (DataAlt trueDataCon, [],mkIntLit 1)])
+                             prim_arg [(DEFAULT,[],body)]
+    )
+
   | otherwise
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
@@ -248,6 +263,13 @@ boxResult result_ty
     returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt]
     )
 
+  -- Booleans
+  | result_ty == boolTy
+  = returnDs (mkUnboxedTupleTy 2 [realWorldStatePrimTy, intPrimTy],
+              \ prim_app -> Case prim_app (mkWildId intPrimTy) [
+                               (LitAlt (mkMachInt 0),[],Var falseDataConId),
+                               (DEFAULT             ,[],Var trueDataConId )])
+
   | otherwise
   = pprPanic "boxResult: " (ppr result_ty)
   where

diff --git a/ghc/includes/StgTypes.h b/ghc/includes/StgTypes.h
index 35f4fa7..19e377c 100644 (file)
--- a/ghc/includes/StgTypes.h
+++ b/ghc/includes/StgTypes.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgTypes.h,v 1.7 2000/01/25 14:36:53 panne Exp $
+ * $Id: StgTypes.h,v 1.8 2000/04/04 13:40:27 panne Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -90,7 +90,7 @@ typedef void*              StgAddr;
  */
 
 typedef StgWord8           StgChar;
-
+typedef int                StgBool;
 /*
  * If a double fits in an StgWord, don't bother using floats.
  */

diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c
index e729972..8d28d8d 100644 (file)
--- a/ghc/rts/RtsAPI.c
+++ b/ghc/rts/RtsAPI.c
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.13 2000/03/31 03:09:36 hwloidl Exp $
+ * $Id: RtsAPI.c,v 1.14 2000/04/04 13:40:27 panne Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -176,7 +176,7 @@ rts_mkAddr (void *a)
 
 #ifdef COMPILER /* GHC has em, Hugs doesn't */
 HaskellObj
-rts_mkBool (int b)
+rts_mkBool (StgBool b)
 {
   if (b) {
     return (StgClosure *)True_closure;
@@ -316,9 +316,9 @@ int
 rts_getBool (HaskellObj p)
 {
   if (p == True_closure) {
-    return 1;
+    return 1; /* NOTE: This should better be HsTrue */
   } else if (p == False_closure) {
-    return 0;
+    return 0; /* ... and this HsFalse */
   } else {
     barf("getBool: not a Bool");
   }