From 1454d97e184bdcde988529d9d2cee72bababb606 Mon Sep 17 00:00:00 2001
From: panne <unknown>
Date: Tue, 4 Apr 2000 13:40:27 +0000
Subject: [PATCH] [project @ 2000-04-04 13:40:27 by panne] Enable Bool in
 foreign import/export

---
 ghc/compiler/deSugar/DsCCall.lhs |   26 ++++++++++++++++++++++++--
 ghc/includes/StgTypes.h          |    4 ++--
 ghc/rts/RtsAPI.c                 |    8 ++++----
 3 files changed, 30 insertions(+), 8 deletions(-)

diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 6170b1b..030f98a 100644
--- 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
--- 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
--- 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");
   }
-- 
1.7.10.4