/[gcl]/gcl/ansi-tests/rt.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/rt.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by pfdietz, Sun Feb 23 17:11:14 2003 UTC revision 1.6 by pfdietz, Thu Mar 6 03:59:34 2003 UTC
# Line 165  them.") Line 165  them.")
165             r)             r)
166        ;; (declare (special *break-on-warnings*))        ;; (declare (special *break-on-warnings*))
167    
168        (flet ((%do        (block aborted
169                ()          (setf r
170                (setf r                (flet ((%do
171                      (multiple-value-list                        ()
172                       (if *compile-tests*                        (if *compile-tests*
173                           (funcall (compile                            (multiple-value-list
174                                     nil                             (funcall (compile
175                                     `(lambda ()                                       nil
176                                        (declare                                       `(lambda ()
177                                         (optimize ,@*optimization-settings*))                                          (declare
178                                        ,(form entry))))                                           (optimize ,@*optimization-settings*))
179                         (eval (form entry)))))))                                          ,(form entry)))))
180          (block aborted                          (multiple-value-list
181            (if *catch-errors*                           (eval (form entry))))))
182                (handler-bind (#-ecl (style-warning #'muffle-warning)                  (if *catch-errors*
183                                     (error #'(lambda (c)                      (handler-bind
184                                                (setf aborted t)                       (#-ecl (style-warning #'muffle-warning)
185                                                (setf r (list c))                              (error #'(lambda (c)
186                                                (return-from aborted nil))))                                         (setf aborted t)
187                              (%do))                                         (setf r (list c))
188              (%do))))                                         (return-from aborted nil))))
189                               (%do))
190                      (%do)))))
191    
192        (setf (pend entry)        (setf (pend entry)
193              (or aborted              (or aborted
194                  (not (equalp-with-case r (vals entry)))))                  (not (equalp-with-case r (vals entry)))))
195          
196        (when (pend entry)        (when (pend entry)
197          (let ((*print-circle* *print-circle-on-failure*))          (let ((*print-circle* *print-circle-on-failure*))
198            (format s "~&Test ~:@(~S~) failed~            (format s "~&Test ~:@(~S~) failed~

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26