mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Add stack overflow test
* libguile/throw.c (throw_without_pre_unwind): Newline after the unwind-only warning. * test-suite/standalone/Makefile.am: * test-suite/standalone/test-stack-overflow: New test to handle mmap/malloc failure.
This commit is contained in:
parent
f764e2590f
commit
4189a5c0bd
3 changed files with 43 additions and 2 deletions
|
@ -185,7 +185,7 @@ throw_without_pre_unwind (SCM tag, SCM args)
|
||||||
|
|
||||||
if (scm_is_true (scm_c_vector_ref (eh, 3)))
|
if (scm_is_true (scm_c_vector_ref (eh, 3)))
|
||||||
fprintf (stderr, "\nWarning: unwind-only exception, perhaps due to "
|
fprintf (stderr, "\nWarning: unwind-only exception, perhaps due to "
|
||||||
"stack overflow; not running pre-unwind handlers.");
|
"stack overflow; not running pre-unwind handlers.\n");
|
||||||
|
|
||||||
prompt_tag = scm_c_vector_ref (eh, 2);
|
prompt_tag = scm_c_vector_ref (eh, 2);
|
||||||
if (scm_is_true (prompt_tag))
|
if (scm_is_true (prompt_tag))
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
## Process this file with automake to produce Makefile.in.
|
## Process this file with automake to produce Makefile.in.
|
||||||
##
|
##
|
||||||
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
|
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
|
||||||
## 2011, 2012, 2013 Free Software Foundation, Inc.
|
## 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||||
##
|
##
|
||||||
## This file is part of GUILE.
|
## This file is part of GUILE.
|
||||||
##
|
##
|
||||||
|
@ -264,4 +264,7 @@ test_smob_mark_LDADD = $(LIBGUILE_LDADD)
|
||||||
check_PROGRAMS += test-smob-mark
|
check_PROGRAMS += test-smob-mark
|
||||||
TESTS += test-smob-mark
|
TESTS += test-smob-mark
|
||||||
|
|
||||||
|
check_SCRIPTS += test-stack-overflow
|
||||||
|
TESTS += test-stack-overflow
|
||||||
|
|
||||||
EXTRA_DIST += ${check_SCRIPTS}
|
EXTRA_DIST += ${check_SCRIPTS}
|
||||||
|
|
38
test-suite/standalone/test-stack-overflow
Executable file
38
test-suite/standalone/test-stack-overflow
Executable file
|
@ -0,0 +1,38 @@
|
||||||
|
#!/bin/sh
|
||||||
|
exec guile -q -s "$0" "$@"
|
||||||
|
!#
|
||||||
|
|
||||||
|
(unless (defined? 'setrlimit)
|
||||||
|
;; Without an rlimit, this test can take down your system, as it
|
||||||
|
;; consumes all of your memory in stack space. That doesn't seem like
|
||||||
|
;; something we should run as part of an automated test suite.
|
||||||
|
(exit 0))
|
||||||
|
|
||||||
|
;; 100 MB.
|
||||||
|
(define *limit* (* 100 1024 1024))
|
||||||
|
|
||||||
|
(call-with-values (lambda () (getrlimit 'as))
|
||||||
|
(lambda (soft hard)
|
||||||
|
(unless (and soft (< soft *limit*))
|
||||||
|
(setrlimit 'as (if hard (min *limit* hard) *limit*) hard))))
|
||||||
|
|
||||||
|
(define (test)
|
||||||
|
(catch 'stack-overflow
|
||||||
|
(lambda ()
|
||||||
|
(let lp ()
|
||||||
|
(lp)
|
||||||
|
(error "should not be reached")))
|
||||||
|
(lambda _
|
||||||
|
#t)))
|
||||||
|
|
||||||
|
;; Run the test a few times. The stack will only be enlarged and
|
||||||
|
;; relocated on the first one.
|
||||||
|
(test)
|
||||||
|
(test)
|
||||||
|
(test)
|
||||||
|
(test)
|
||||||
|
(test)
|
||||||
|
|
||||||
|
;; Local Variables:
|
||||||
|
;; mode: scheme
|
||||||
|
;; End:
|
Loading…
Add table
Add a link
Reference in a new issue