From 201ab3340e26ebb402665df744f070ab434a9d5b Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Mon, 11 Feb 2019 00:36:36 +0000 Subject: [PATCH] Add some tests of blowing out the stack with SRFI 1. --- tests/check.scm | 1 + tests/runtime/test-list.scm | 151 ++++++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+) create mode 100644 tests/runtime/test-list.scm diff --git a/tests/check.scm b/tests/check.scm index f808e421a..0e594288c 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -82,6 +82,7 @@ USA. ("runtime/test-library-standard" (runtime library)) ("runtime/test-library-imports" (runtime library)) ("runtime/test-library-loader" (runtime library)) + "runtime/test-list" "runtime/test-md5" "runtime/test-mime-codec" "runtime/test-numpar" diff --git a/tests/runtime/test-list.scm b/tests/runtime/test-list.scm new file mode 100644 index 000000000..d3e86700a --- /dev/null +++ b/tests/runtime/test-list.scm @@ -0,0 +1,151 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Test of list operations + +(declare (usual-integrations)) + +(define (carefully procedure if-overflow if-timeout) + (let ((thread #f) + (mutex (make-thread-mutex)) + (condvar (make-condition-variable)) + (gc-env (->environment '(runtime garbage-collector)))) + (define (start-it) + (with-thread-mutex-lock mutex + (lambda () + (do () (thread) + (condition-variable-wait! condvar mutex)))) + (let ((default/stack-overflow (access default/stack-overflow gc-env))) + (define (give-up) + (if (eq? thread (current-thread)) + (exit-current-thread (if-overflow)) + (default/stack-overflow))) + (call-with-current-continuation + (lambda (abort) + (fluid-let (((access hook/stack-overflow gc-env) + (lambda () (within-continuation abort give-up)))) + (exit-current-thread (procedure))))))) + (define (stop-it) + (assert thread) + (signal-thread-event thread + (lambda () + (exit-current-thread (if-timeout))))) + (let ((t (create-thread #f start-it))) + (with-thread-mutex-lock mutex + (lambda () + (set! thread t) + (condition-variable-broadcast! condvar)))) + (let ((result #f)) + (define (done-it thread* value) + (assert (eq? thread* thread)) + (set! result value)) + (join-thread thread done-it) + (let ((timer)) + (dynamic-wind + (lambda () (set! timer (register-timer-event 1000 stop-it))) + (lambda () (do () (result) (suspend-current-thread))) + (lambda () (deregister-timer-event (set! timer)))))))) + +(define (words-in-stack) + (let ((status (gc-space-status))) + (let ((bytes-per-word (vector-ref status 0)) + (stack-start (vector-ref status 8)) + (stack-end (vector-ref status 11))) + (let ((n-bytes (- stack-end stack-start))) + (quotient n-bytes bytes-per-word))))) + +(define-test 'map-long + (lambda () + (let* ((n (words-in-stack)) + (l (make-list n 0))) + (assert-equal + (carefully (lambda () (length (map - l))) + (lambda () 'overflow) + (lambda () 'timeout)) + n)))) + +(define-test 'map-in-order-long + (lambda () + (let* ((n (words-in-stack)) + (l (make-list n 0))) + (expect-failure + (lambda () + (assert-equal + (carefully (lambda () (length (map-in-order - l))) + (lambda () 'overflow) + (lambda () 'timeout)) + n)))))) + +(define-test 'filter-map-long + (lambda () + (let* ((n (words-in-stack)) + (l (make-list n 0))) + (expect-failure + (lambda () + (assert-equal + (carefully (lambda () (length (filter-map zero? l))) + (lambda () 'overflow) + (lambda () 'timeout)) + n)))))) + +(define-test 'filter-long + (lambda () + (let* ((n (words-in-stack)) + (l (make-list n 0))) + (expect-failure + (lambda () + (assert-equal + (carefully (lambda () (length (filter zero? l))) + (lambda () 'overflow) + (lambda () 'timeout)) + n)))))) + +(define-test 'remove-long + (lambda () + (let* ((n (words-in-stack)) + (l (make-list n 0))) + (expect-failure + (lambda () + (assert-equal + (carefully (lambda () (length (remove positive? l))) + (lambda () 'overflow) + (lambda () 'timeout)) + n)))))) + +(define-test 'partition-long + (lambda () + (let* ((n (words-in-stack)) + (n (- n (remainder n 2))) + (l (list-tabulate n (lambda (i) i)))) + (expect-failure + (lambda () + (assert-equal + (carefully (lambda () + (receive (a b) (partition even? l) + (list (length a) (length b)))) + (lambda () 'overflow) + (lambda () 'timeout)) + (list (quotient n 2) (quotient n 2)))))))) \ No newline at end of file -- 2.25.1