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

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

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

revision 1.116 by pfdietz, Sun May 1 01:33:08 2005 UTC revision 1.117 by pfdietz, Sun May 1 14:03:54 2005 UTC
# Line 286  the condition to go uncaught if it canno Line 286  the condition to go uncaught if it canno
286                                            (declare (optimize (safety ,safety)))                                            (declare (optimize (safety ,safety)))
287                                            ,form)))                                            ,form)))
288                 (eval ',form))))                 (eval ',form))))
289       (,error-name (c) (printable-p c)))))       (,error-name (c)
290                      (cond
291                       ,@(if (eq error-name 'type-error)
292                             `(((typep (type-error-datum c)
293                                       (type-error-expected-type c))
294                                (values
295                                 nil
296                                 (list (list 'typep (type-error-datum c)
297                                             (type-error-expected-type c))
298                                       "==> true"))))
299                           nil)
300                       (t (printable-p c)))))))
301    
302  (defmacro signals-error-always (form error-name)  (defmacro signals-error-always (form error-name)
303    `(values    `(values
304      (signals-error ,form ,error-name)      (signals-error ,form ,error-name)
305      (signals-error ,form ,error-name :safety 0)))      (signals-error ,form ,error-name :safety 0)))
306    
307    (defmacro signals-type-error (var datum-form form &key (safety 3))
308      (let ((lambda-form
309             `(lambda (,var)
310                (declare (optimize (safety ,safety)))
311                ,form)))
312        `(let ((,var ,datum-form))
313           (handler-bind
314            ((warning #'(lambda (c) (declare (ignore c))
315                          (muffle-warning))))
316                                            ; (proclaim '(optimize (safety 3)))
317            (handler-case
318             (apply #'values
319                    nil
320                    (multiple-value-list
321                     (funcall
322                      (if regression-test::*compile-tests*
323                          (compile nil ',lambda-form)
324                        (eval ',lambda-form))
325                      ,var)))
326             (type-error
327              (c)
328              (let ((datum (type-error-datum c))
329                    (expected-type (type-error-expected-type c)))
330                (cond
331                 ((not (eql ,var datum))
332                  (list :datum-mismatch ,var datum))
333                 ((typep datum expected-type)
334                  (list :is-typep datum expected-type))
335                 (t (printable-p c))))))))))
336    
337  (defun printable-p (obj)  (defun printable-p (obj)
338    "Returns T iff obj can be printed to a string."    "Returns T iff obj can be printed to a string."
339    (with-standard-io-syntax    (with-standard-io-syntax

Legend:
Removed from v.1.116  
changed lines
  Added in v.1.117

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