From 4fb1702144929e5ac7868a895446a985e08344a7 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Thu, 6 Mar 2003 03:59:34 +0000 Subject: [PATCH] Modified some tests so they don't make ecl crash (instead they just fail). Also, modified the RT test harness to work around other obnoxious bugs in ecl. --- ansi-tests/iteration.lsp | 14 +++++++----- ansi-tests/rt.lsp | 47 +++++++++++++++++++++------------------- 2 files changed, 33 insertions(+), 28 deletions(-) diff --git a/ansi-tests/iteration.lsp b/ansi-tests/iteration.lsp index 5b6d13bc..5de230e7 100644 --- a/ansi-tests/iteration.lsp +++ b/ansi-tests/iteration.lsp @@ -391,14 +391,16 @@ nil) (deftest dotimes.6 - (let ((x nil)) - (dotimes (i -1 x) (push i x))) - nil) + (block done + (dotimes (i -1 'good) + (return-from done 'bad))) + good) (deftest dotimes.7 - (let ((x nil)) - (dotimes (i (1- most-negative-fixnum) x) (push i x))) - nil) + (block done + (dotimes (i (1- most-negative-fixnum) 'good) + (return-from done 'bad))) + good) ;;; Implicit nil block has the right scope (deftest dotimes.8 diff --git a/ansi-tests/rt.lsp b/ansi-tests/rt.lsp index 2e3ce500..b1aa31aa 100644 --- a/ansi-tests/rt.lsp +++ b/ansi-tests/rt.lsp @@ -165,31 +165,34 @@ them.") r) ;; (declare (special *break-on-warnings*)) - (flet ((%do - () - (setf r - (multiple-value-list - (if *compile-tests* - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry)))) - (eval (form entry))))))) - (block aborted - (if *catch-errors* - (handler-bind (#-ecl (style-warning #'muffle-warning) - (error #'(lambda (c) - (setf aborted t) - (setf r (list c)) - (return-from aborted nil)))) - (%do)) - (%do)))) - + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + (#-ecl (style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + (setf (pend entry) (or aborted (not (equalp-with-case r (vals entry))))) + (when (pend entry) (let ((*print-circle* *print-circle-on-failure*)) (format s "~&Test ~:@(~S~) failed~ -- GitLab