/[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.120 by pfdietz, Thu May 5 03:08:00 2005 UTC revision 1.121 by pfdietz, Fri May 6 01:13:40 2005 UTC
# Line 272  the condition to go uncaught if it canno Line 272  the condition to go uncaught if it canno
272  ;;; The above is badly designed, since it fails when some signals  ;;; The above is badly designed, since it fails when some signals
273  ;;; may be in more than one class/  ;;; may be in more than one class/
274    
275  (defmacro signals-error (form error-name &key (safety 3) (name nil name-p))  (defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil))
276    `(handler-bind    `(handler-bind
277      ((warning #'(lambda (c) (declare (ignore c))      ((warning #'(lambda (c) (declare (ignore c))
278                                (muffle-warning))))                                (muffle-warning))))
# Line 281  the condition to go uncaught if it canno Line 281  the condition to go uncaught if it canno
281       (apply #'values       (apply #'values
282              nil              nil
283              (multiple-value-list              (multiple-value-list
284               (if regression-test::*compile-tests*               ,(cond
285                   (funcall (compile nil '(lambda ()                 (inline form)
286                   (regression-test::*compile-tests*
287                    `(funcall (compile nil '(lambda ()
288                                            (declare (optimize (safety ,safety)))                                            (declare (optimize (safety ,safety)))
289                                            ,form)))                                            ,form))))
290                 (eval ',form))))                 (t `(eval ',form)))))
291       (,error-name (c)       (,error-name (c)
292                    (cond                    (cond
293                     ,@(case error-name                     ,@(case error-name
# Line 326  the condition to go uncaught if it canno Line 328  the condition to go uncaught if it canno
328      (signals-error ,form ,error-name)      (signals-error ,form ,error-name)
329      (signals-error ,form ,error-name :safety 0)))      (signals-error ,form ,error-name :safety 0)))
330    
331  (defmacro signals-type-error (var datum-form form &key (safety 3))  (defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil))
332    (let ((lambda-form    (let ((lambda-form
333           `(lambda (,var)           `(lambda (,var)
334              (declare (optimize (safety ,safety)))              (declare (optimize (safety ,safety)))
335              ,form)))              ,form)))
336      `(let ((,var ,datum-form))      `(let ((,var ,datum-form))
337           (declare (optimize safety))
338         (handler-bind         (handler-bind
339          ((warning #'(lambda (c) (declare (ignore c))          ((warning #'(lambda (c) (declare (ignore c))
340                        (muffle-warning))))                        (muffle-warning))))
# Line 341  the condition to go uncaught if it canno Line 344  the condition to go uncaught if it canno
344                  nil                  nil
345                  (multiple-value-list                  (multiple-value-list
346                   (funcall                   (funcall
347                    (if regression-test::*compile-tests*                   ,(cond
348                        (compile nil ',lambda-form)                     (inline `(function ,lambda-form))
349                      (eval ',lambda-form))                     (regression-test::*compile-tests*
350                         `(compile nil ',lambda-form))
351                       (t `(eval ',lambda-form)))
352                    ,var)))                    ,var)))
353           (type-error           (type-error
354            (c)            (c)
# Line 356  the condition to go uncaught if it canno Line 361  the condition to go uncaught if it canno
361                (list :is-typep datum expected-type))                (list :is-typep datum expected-type))
362               (t (printable-p c))))))))))               (t (printable-p c))))))))))
363    
364    (declaim (special *mini-universe*))
365    
366    (defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*))
367      "Check that for all elements in some set, either guard-fn is true or
368       pred-fn signals a type error."
369      (let (val)
370        (loop for e in universe
371              unless (or (funcall guard-fn e)
372                         (equal
373                          (setf val (multiple-value-list
374                                     (signals-type-error x e (funcall pred-fn x) :inline t)))
375                          '(t)))
376            collect (list e val))))
377    
378    (defmacro check-type-error (&body args)
379      `(locally (declare (optimize safety)) (check-type-error* ,@args)))
380    
381  (defun printable-p (obj)  (defun printable-p (obj)
382    "Returns T iff obj can be printed to a string."    "Returns T iff obj can be printed to a string."
383    (with-standard-io-syntax    (with-standard-io-syntax
# Line 1120  the condition to go uncaught if it canno Line 1142  the condition to go uncaught if it canno
1142      (double-float double-float-negative-epsilon)      (double-float double-float-negative-epsilon)
1143      (long-float long-float-negative-epsilon)      (long-float long-float-negative-epsilon)
1144      (rational 0)))      (rational 0)))
1145    
1146    (defun sequencep (x) (typep x 'sequence))

Legend:
Removed from v.1.120  
changed lines
  Added in v.1.121

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