~ chicken-core (chicken-5) fe1325920d875c1fd7322aa42d09164a067369c9

commit fe1325920d875c1fd7322aa42d09164a067369c9
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jan 17 16:25:35 2011 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Jan 17 16:25:35 2011 +0100

    fixed broken integer64 check (thanks to Sven Hartrumpf)

diff --git a/library.scm b/library.scm
index df45376b..ec341757 100644
--- a/library.scm
+++ b/library.scm
@@ -1062,7 +1062,7 @@ EOF
 		(##sys#check-integer n2 'lcm)
 		(loop
 		 (cons
-		  (##sys#lcm head (##sys#slot next 0))
+		  (##sys#lcm head n2)
 		  (##sys#slot next 1)) #f) ) ) ) ) ) )
 
 (define (##sys#string->number str #!optional (radix 10))
diff --git a/runtime.c b/runtime.c
index 6e6821bb..45107fa6 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5679,10 +5679,8 @@ C_regparm C_word C_fcall C_i_foreign_integer64_argumentp(C_word x)
 {
   double m;
 
-  if((x & C_FIXNUM_BIT) != 0) return x;
-
-  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)
-    return C_flonum_magnitude(x);
+  if((x & C_FIXNUM_BIT) != 0 || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG))
+    return x;
 
   barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
   return C_SCHEME_UNDEFINED;
@@ -5695,8 +5693,11 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
 
   if((x & C_FIXNUM_BIT) != 0) return x;
 
-  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)
-    return C_flonum_magnitude(x);
+  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+    m = C_flonum_magnitude(x);
+
+    if(m >= 0 && m <= C_UWORD_MAX) return x;
+  }
 
   barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
   return C_SCHEME_UNDEFINED;
@@ -5709,11 +5710,8 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
 
   if((x & C_FIXNUM_BIT) != 0) return x;
 
-  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
-    m = C_flonum_magnitude(x);
-
-    if(m >= 0 && m <= C_UWORD64_MAX) return x;
-  }
+  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)
+    return C_flonum_magnitude(x);
 
   barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
   return C_SCHEME_UNDEFINED;
diff --git a/tests/embedded3.c b/tests/embedded3.c
new file mode 100644
index 00000000..c5672be3
--- /dev/null
+++ b/tests/embedded3.c
@@ -0,0 +1,44 @@
+/* embedded3-c.c */
+ 
+#include <chicken.h>
+#include <assert.h>
+ 
+extern double baz(int);
+ 
+int main() {
+  char buffer[ 256 ];
+  int status;
+  C_word val = C_SCHEME_UNDEFINED;
+  C_word *data[ 1 ];
+ 
+  data[ 0 ] = &val;
+ 
+  CHICKEN_run(C_toplevel);
+ 
+  status = CHICKEN_read("(bar 99)", &val);
+  assert(status);
+ 
+  C_gc_protect(data, 1);
+ 
+  printf("data: %08x\n", val);
+ 
+  status = CHICKEN_eval_string_to_string("(bar)", buffer, 255);
+  assert(!status);
+ 
+  CHICKEN_get_error_message(buffer, 255);
+  printf("ouch: %s\n", buffer);
+ 
+  status = CHICKEN_eval_string_to_string("(bar 23)", buffer, 255);
+  assert(status);
+ 
+  printf("-> %s\n", buffer);
+  printf("data: %08x\n", val);
+ 
+  status = CHICKEN_eval_to_string(val, buffer, 255);
+  assert(status);
+  printf("-> %s\n", buffer);
+ 
+  printf("->` %g\n", baz(22));
+ 
+  return 0;
+}
diff --git a/tests/embedded4.scm b/tests/embedded4.scm
new file mode 100644
index 00000000..cb188116
--- /dev/null
+++ b/tests/embedded4.scm
@@ -0,0 +1,8 @@
+;;; x.scm
+ 
+(define (bar x) (gc) (* x x))
+ 
+(define-external (baz (int i)) double
+  (sqrt i))
+
+(return-to-host)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 61a8c61d..09f95a05 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -273,6 +273,10 @@ echo "======================================== embedding (2) ..."
 $compile -e embedded2.scm
 ./a.out
 
+echo "======================================== embedding (3) ..."
+$compile -e embedded3.c embedded4.scm
+./a.out
+
 echo "======================================== private repository test ..."
 mkdir -p tmp
 $compile private-repository-test.scm -private-repository -o tmp/xxx