[foo-cvs] fooelk/examples/tests gc-stress.scm, NONE, 1.1 Makefile.am, 1.1.1.1, 1.2

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/fooelk/examples/tests
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv1916

Modified Files:
	Makefile.am 
Added Files:
	gc-stress.scm 
Log Message:
added gc stress test according to r265 of original elk

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/fooelk/examples/tests/Makefile.am,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -d -r1.1.1.1 -r1.2
*** Makefile.am	6 Aug 2004 20:56:43 -0000	1.1.1.1
--- Makefile.am	26 Apr 2010 15:02:31 -0000	1.2
***************
*** 2,6 ****
  CLEANFILES = $(allstamps) mytest.scm tmp1 tmp2 tmp3
  
! allstamps = stamp-r4rs
  
  if NATIVE_BUILD
--- 2,6 ----
  CLEANFILES = $(allstamps) mytest.scm tmp1 tmp2 tmp3
  
! allstamps = stamp-r4rs stamp-gc
  
  if NATIVE_BUILD
***************
*** 10,19 ****
  stamp-r4rs: $(top_builddir)/src/fooelk
  	rm -f $@ mytest.scm
- 
  	sed -e 's/r4rstest/mytest/g' < $(srcdir)/r4rstest.scm > mytest.scm
  	echo '(test-cont) (test-sc4) (test-delay)' >> mytest.scm
- 
  	-$(top_builddir)/src/fooelk -p .:$(top_srcdir)/scm -l mytest.scm
  	rm -f mytest.scm tmp1 tmp2 tmp3
  	printf "" > $@
  
--- 10,20 ----
  stamp-r4rs: $(top_builddir)/src/fooelk
  	rm -f $@ mytest.scm
  	sed -e 's/r4rstest/mytest/g' < $(srcdir)/r4rstest.scm > mytest.scm
  	echo '(test-cont) (test-sc4) (test-delay)' >> mytest.scm
  	-$(top_builddir)/src/fooelk -p .:$(top_srcdir)/scm -l mytest.scm
  	rm -f mytest.scm tmp1 tmp2 tmp3
  	printf "" > $@
  
+ stamp-gc: $(top_builddir)/src/elk
+ 	-$(top_builddir)/src/elk -p .:$(top_srcdir)/scm -l gc-stress.scm
+ 

--- NEW FILE: gc-stress.scm ---

;; this test sometimes crashes the GC with the well-known
;; Panic: Visit: object not in prev space at 0x40210b2c ('pair') 8199 8201 (dumping core).

(display "testing garbage collector integrity (1000 loops)\n")
;(set! garbage-collect-notify? #t)
(define c 0)
(define cb
  (lambda ignore
    (let ((s '()))
      (set! c (+ 1 c))
        (call/cc
          (lambda (return)
            (do ((i 0 (+ i 1)))
                ((= i 100))
                (let ((a (+ i 1)))
                  (set! s (append s (list i))))
                (if (= i 60) (return #t))))))))
(do ((i 0 (+ i 1))) ((= i 1000)) (cb))
(display "test passed.\n")

;; This test used to crash the GC, too.

(display "testing deep calls (2000 calls)\n")
(define crash
  (lambda (x)
    (begin
      (if (> x 0)
        (crash (- x 1)))
      (collect))))
(crash 2000)
(display "test passed.\n")