From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 23 Jul 1987 21:47:55 +0000 (+0000)
Subject: Add `object_to_long' which is like `Scheme_Integer_To_C_Integer' but a
X-Git-Tag: 20090517-FFI~13227
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=11542e0780c0ca5a9366d39af1f06054be376e5d;p=mit-scheme.git

Add `object_to_long' which is like `Scheme_Integer_To_C_Integer' but a
bit more flexible.
---

diff --git a/v7/src/microcode/generic.c b/v7/src/microcode/generic.c
index 63f778ef6..477477d3f 100644
--- a/v7/src/microcode/generic.c
+++ b/v7/src/microcode/generic.c
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.22 1987/04/16 02:23:19 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.23 1987/07/23 21:47:55 cph Exp $ */
 
 #include "scheme.h"
 #include "primitive.h"
@@ -83,7 +83,7 @@ C_Integer_To_Scheme_Integer(C)
 }
 
 int
-Scheme_Integer_To_C_Integer(Arg1, C)
+Scheme_Integer_To_C_Integer (Arg1, C)
      Pointer Arg1;
      long *C;
 {
@@ -131,6 +131,58 @@ Fetch_Bignum_One()
   return Get_Fixed_Obj_Slot(Bignum_One);
 }
 
+/* This is more suitable than `Scheme_Integer_To_C_Integer'
+   for some purposes. */
+
+long
+object_to_long (object, type_error, range_error)
+     Pointer object;
+     long type_error, range_error;
+{
+  fast long result;
+
+  switch (OBJECT_TYPE (object))
+    {
+    case TC_FIXNUM:
+      {
+	Sign_Extend (object, result);
+	return (result);
+      }
+
+    case TC_BIG_FIXNUM:
+      {
+	fast bigdigit *bignum, *scan;
+	fast long length;
+
+	bignum = (BIGNUM (Get_Pointer (object)));
+	length = (LEN (bignum));
+	if (length == 0)
+	  return (0);
+	if (length > C_INTEGER_LENGTH_AS_BIGNUM)
+	  signal_error_from_primitive (range_error);
+	scan = (Bignum_Top (bignum));
+	result = 0;
+	if (length < C_INTEGER_LENGTH_AS_BIGNUM)
+	  while ((length--) > 0)
+	    result = ((Mul_Radix (result)) + (*scan--));
+	else
+	  while ((length--) > 0)
+	    {
+	      result = (Mul_Radix (result));
+	      if (result < 0)
+		signal_error_from_primitive (range_error);
+	      result = (result + (*scan--));
+	      if (result < 0)
+		signal_error_from_primitive (range_error);
+	    }
+	return ((NEG_BIGNUM (bignum)) ? (- result) : result);
+      }
+
+    default:
+      signal_error_from_primitive (type_error);
+    }
+}
+
 #define Sign_Check(Normal_Op, Big_Op)					\
   Primitive_1_Arg();							\
   Set_Time_Zone(Zone_Math);						\