~ chicken-core (chicken-5) 26ffd1a01ec29f723c56f1975044610574225769
commit 26ffd1a01ec29f723c56f1975044610574225769
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Wed Jul 24 21:05:10 2013 +0200
Commit: Jim Ursetto <zbigniewsz@gmail.com>
CommitDate: Fri Jul 26 01:47:24 2013 -0500
Add checks for hitting the rest arg count limit on direct procedure application. Fixes some of the confusion from #910
diff --git a/NEWS b/NEWS
index a13e4232..0f77a4c0 100644
--- a/NEWS
+++ b/NEWS
@@ -46,6 +46,8 @@
- Runtime system
- Special events in poll() are now handled, avoiding hangs in threaded apps.
+ - When invoking procedures with many rest arguments directly (not via APPLY),
+ raise an error when argument count limit was reached instead of crashing.
- C API
- Deprecated C_get_argument[_2] and C_get_environment_variable[_2] functions.
diff --git a/chicken.h b/chicken.h
index 6d5d7f95..d09d3e3d 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1003,7 +1003,7 @@ extern double trunc(double);
#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
#define C_adjust_stack(n) (C_temporary_stack -= (n))
#define C_rescue(x, i) (C_temporary_stack[ i ] = (x))
-#define C_save_rest(s, c, n) for(va_start(v, s); c-- > (n); C_save(va_arg(v, C_word)))
+#define C_save_rest(s, c, n) do { if((C_temporary_stack - (c - (n))) < C_temporary_stack_limit) C_temp_stack_overflow(); for(va_start(v, s); c-- > (n); C_save(va_arg(v, C_word))); }while(0)
#define C_rest_count(c) ((C_temporary_stack_bottom - C_temporary_stack) - (c))
#define C_restore (*(C_temporary_stack++))
#define C_heaptop ((C_word **)(&C_fromspace_top))
@@ -1584,6 +1584,7 @@ C_varextern C_TLS time_t C_startup_time_seconds;
C_varextern C_TLS C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
+ *C_temporary_stack_limit,
*C_stack_limit;
C_varextern C_TLS C_long
C_timer_interrupt_counter,
@@ -1689,6 +1690,7 @@ C_fctexport void C_bad_min_argc(int c, int n) C_noret;
C_fctexport void C_bad_argc_2(int c, int n, C_word closure) C_noret;
C_fctexport void C_bad_min_argc_2(int c, int n, C_word closure) C_noret;
C_fctexport void C_stack_overflow(void) C_noret;
+C_fctexport void C_temp_stack_overflow(void) C_noret;
C_fctexport void C_unbound_error(C_word sym) C_noret;
C_fctexport void C_no_closure_error(C_word x) C_noret;
C_fctexport void C_div_by_zero_error(char *loc) C_noret;
diff --git a/runtime.c b/runtime.c
index d8bea057..bbeb2f62 100644
--- a/runtime.c
+++ b/runtime.c
@@ -2383,6 +2383,13 @@ void C_stack_overflow_with_msg(C_char *msg)
barf(C_STACK_OVERFLOW_ERROR, NULL);
}
+void C_temp_stack_overflow(void)
+{
+ /* Just raise a "too many parameters" error; it isn't very useful to
+ show a different message here. */
+ barf(C_TOO_MANY_PARAMETERS_ERROR, NULL);
+}
+
void C_unbound_error(C_word sym)
{
diff --git a/tests/apply-test.scm b/tests/apply-test.scm
index d05356ba..81697a5c 100644
--- a/tests/apply-test.scm
+++ b/tests/apply-test.scm
@@ -1,14 +1,58 @@
(require-extension srfi-1)
-(define manyargs (feature? 'manyargs))
+(define max-argcount ##sys#apply-argument-limit)
-(when manyargs (print "many arguments supported."))
+(begin-for-syntax
+ (define max-direct-argcount
+ (cond-expand
+ ;; This depends the temp stack's size (as does max-argcount w/ manyargs).
+ ;; We can't use the foreign value for C_TEMPORARY_STACK_SIZE here because
+ ;; we're evaluating this in the compiler, not compiling it (confused yet?)
+ (compiling 2048)
+ ;; But in interpreted mode, everything boils down to "apply", so if no apply
+ ;; hack is available, we're more limited in csi than in csc.
+ (else ##sys#apply-argument-limit))))
+
+(when (feature? 'manyargs) (print "many arguments supported."))
(define (foo . args)
(when (pair? args)
(assert (= (length args) (last args)))))
-(let ((max (if manyargs 500 100)))
- (do ((i 0 (add1 i)))
- ((>= i max))
- (apply foo (iota i 1))))
+(printf "testing 'apply' with 0..~A (maximum apply argument count)...\n" max-argcount)
+(do ((i 0 (add1 i)))
+ ((>= i max-argcount))
+ (apply foo (iota i 1)))
+
+(let-syntax
+ ((invoke-directly
+ (ir-macro-transformer
+ (lambda (i r c)
+ `(begin
+ (print "invoking directly with 0..50...")
+ ;; Lowest edge cases
+ ,@(list-tabulate 50 (lambda (i) `(foo ,@(iota i 1))))
+ (printf "invoking directly with ~A..~A (maximum ~A direct argument count)...\n"
+ ,(- max-direct-argcount 50) ,max-direct-argcount
+ (cond-expand (compiling "compiled") (else "interpreted")))
+ ;; Highest edge cases
+ ,@(list-tabulate
+ 50 (lambda (i) `(foo ,@(iota (- max-direct-argcount i) 1)))))))))
+ (print "If this segfaults on x86-64, try updating GCC (4.5 has a code-generation bug):")
+ (invoke-directly))
+
+(define-syntax assert-argcount-error
+ (syntax-rules ()
+ ((_ expr)
+ (assert (condition-case (begin expr #f)
+ ((exn runtime limit) 'a-okay))))))
+
+(print "testing 'apply' can detect calls of too many arguments...")
+(assert-argcount-error (apply foo (iota (add1 max-argcount) 1)))
+
+(print "testing direct invocation can detect calls of too many arguments...")
+(let-syntax ((invoke-directly-with-too-many-args
+ (ir-macro-transformer
+ (lambda (i r c)
+ `(assert-argcount-error (foo ,@(iota (add1 max-direct-argcount) 1)))))))
+ (invoke-directly-with-too-many-args))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index c56f9a8f..25f77f8d 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -105,6 +105,10 @@ if errorlevel 1 (
echo ======================================== runtime tests ...
%interpret% -s apply-test.scm
if errorlevel 1 exit /b 1
+%compile% apply-test.scm
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
%compile% test-gc-hooks.scm
if errorlevel 1 exit /b 1
a.out
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 83c828db..352c35b6 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -134,6 +134,8 @@ fi
echo "======================================== runtime tests ..."
$interpret -s apply-test.scm
+$compile apply-test.scm
+./a.out
$compile test-gc-hooks.scm
./a.out
Trap