~ chicken-core (chicken-5) c157ff502829c6f2856df4a963d81a88ee241ebf

commit c157ff502829c6f2856df4a963d81a88ee241ebf
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Dec 6 04:58:45 2010 -0500
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Dec 6 04:58:45 2010 -0500

    more useful error message in case equal? recurses too deep

diff --git a/chicken.h b/chicken.h
index 25cd834f..c228f028 100644
--- a/chicken.h
+++ b/chicken.h
@@ -581,6 +581,7 @@ typedef unsigned __int64   uint64_t;
 #define C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR           33
 #define C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR          34
 #define C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR            35
+#define C_CIRCULAR_DATA_ERROR                         36
 
 
 /* Platform information */
@@ -1004,13 +1005,15 @@ extern double trunc(double);
 #if C_STACK_GROWS_DOWNWARD
 # define C_demand(n)              (C_stress && ((C_word)(C_stack_pointer - C_stack_limit) > (n)))
 # define C_stack_probe(p)         (C_stress && ((C_word *)(p) >= C_stack_limit))
-# define C_stack_check            if(!C_disable_overflow_check && (C_byte*)(C_stack_pointer) + C_STACK_RESERVE < (C_byte *)C_stack_limit) C_stack_overflow()
+# define C_stack_test             (!C_disable_overflow_check && (C_byte*)(C_stack_pointer) + C_STACK_RESERVE < (C_byte *)C_stack_limit)
 #else
 # define C_demand(n)              (C_stress && ((C_word)(C_stack_limit - C_stack_pointer) > (n)))
 # define C_stack_probe(p)         (C_stress && ((C_word *)(p) < C_stack_limit))
-# define C_stack_check            if(!C_disable_overflow_check && (C_byte*)(C_stack_pointer) - C_STACK_RESERVE > (C_byte *)C_stack_limit) C_stack_overflow()
+# define C_stack_test             (!C_disable_overflow_check && (C_byte*)(C_stack_pointer) - C_STACK_RESERVE > (C_byte *)C_stack_limit)
 #endif
 
+#define C_stack_check             if(C_stack_test) C_stack_overflow()
+
 #define C_zero_length_p(x)        C_mk_bool(C_header_size(x) == 0)
 #define C_boundp(x)               C_mk_bool(((C_SCHEME_BLOCK *)(x))->data[ 0 ] != C_SCHEME_UNBOUND)
 #define C_unboundvaluep(x)        C_mk_bool((x) == C_SCHEME_UNBOUND)
diff --git a/library.scm b/library.scm
index ffb9ff6d..30fbce6b 100644
--- a/library.scm
+++ b/library.scm
@@ -3970,6 +3970,7 @@ EOF
 	((33) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))
 	((34) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))
 	((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - invalid base" args))
+	((36) (apply ##sys#signal-hook #:limit-error loc "recursion too deep or circular data encountered" args))
 	(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
 
 
diff --git a/runtime.c b/runtime.c
index 7e20f67c..08ca44f8 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1601,6 +1601,11 @@ void barf(int code, char *loc, ...)
     c = 1;
     break;
 
+  case C_CIRCULAR_DATA_ERROR:
+    msg = C_text("recursion too deep or circular data encountered");
+    c = 0;
+    break;
+
   default: panic(C_text("illegal internal error code"));
   }
   
@@ -2205,6 +2210,12 @@ void C_stack_overflow(void)
 }
 
 
+void C_stack_overflow_with_msg(C_char *msg)
+{
+  barf(C_STACK_OVERFLOW_ERROR, NULL);
+}
+
+
 void C_unbound_error(C_word sym)
 {
   barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
@@ -3865,7 +3876,8 @@ C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
   C_header header;
   C_word bits, n, i;
 
-  C_stack_check;
+  if(C_stack_test)
+    barf(C_CIRCULAR_DATA_ERROR, "equal?");
 
  loop:
   if(x == y) return 1;