/[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.31 by pfdietz, Wed Jan 29 02:11:54 2003 UTC revision 1.32 by pfdietz, Fri Jan 31 01:58:10 2003 UTC
# Line 136  Results: ~A~%" expected-number form n re Line 136  Results: ~A~%" expected-number form n re
136        (loop for e in *universe*        (loop for e in *universe*
137              always (or (not (typep e type1)) (typep e type2))))))              always (or (not (typep e type1)) (typep e type2))))))
138    
139    ;;; Check that the subtype relationships implied
140    ;;; by disjointness are not contradicted.  Return NIL
141    ;;; if ok, or a list of error messages if not.
142    (defun check-disjointness (type1 type2)
143      (remove 'nil
144              (list
145               (check-subtypep type1 type2 nil)
146               (check-subtypep type2 type1 nil)
147               (check-subtypep type1 `(not ,type2) t)
148               (check-subtypep type2 `(not ,type1) t)
149               (check-subtypep `(and ,type1 ,type2) nil t)
150               (check-subtypep `(and ,type2 ,type1) nil t)
151               )))
152    
153    (defun check-subtypep (type1 type2 is-sub &optional should-be-valid)
154      (multiple-value-bind
155          (sub valid)
156          (subtypep* type1 type2)
157        (cond
158         (valid
159          (cond
160           ((and sub (not is-sub))
161            `((SUBTYPEP ',type1 ',type2)
162              "==> <true>, <true>, expected NIL."))
163           ((and (not sub) is-sub)
164            `((SUBTYPEP ',type1 ',type2)
165              "==> <false>, <true>, expected <true>."))
166           (t nil)))
167         (should-be-valid
168          `((SUBTYPEP ',type1 ',type2) "did not succeed but should have."))
169         (t nil))))  
170    
171  (defun check-type-predicate (P TYPE)  (defun check-type-predicate (P TYPE)
172    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
173     by applying both to all elements of *UNIVERSE*.  Print message     by applying both to all elements of *UNIVERSE*.  Print message
# Line 442  the condition to go uncaught if it canno Line 474  the condition to go uncaught if it canno
474    
475  ;;; From types-and-class.lsp  ;;; From types-and-class.lsp
476    
477    (defparameter +float-types+
478      '(long-float double-float short-float single-float))
479    
480    (defparameter *subtype-table*
481    (let ((table
482           '(
483             (null symbol)
484             (symbol t)
485             #-(and cmu (not sparc)) (boolean symbol)
486             (standard-object t)
487             (function t)
488             (compiled-function function)
489             (generic-function function)
490             (standard-generic-function generic-function)
491             (class standard-object)
492             (built-in-class class)
493             (structure-class class)
494             (standard-class class)
495             (method standard-object)
496             (standard-method method)
497             (structure-object t)
498             (method-combination t)
499             (condition t)
500             (serious-condition condition)
501             (error serious-condition)
502             (type-error error)
503             (simple-type-error type-error)
504             (simple-condition condition)
505             (simple-type-error simple-condition)
506             (parse-error error)
507             (hash-table t)
508             (cell-error error)
509             (unbound-slot cell-error)
510             (warning condition)
511             (style-warning warning)
512             (storage-condition serious-condition)
513             (simple-warning warning)
514             (simple-warning simple-condition)
515             (keyword symbol)
516             (unbound-variable cell-error)
517             (control-error error)
518             (program-error error)
519             (undefined-function cell-error)
520             (package t)
521             (package-error error)
522             (random-state t)
523             (number t)
524             (real number)
525             (complex number)
526             (float real)
527             (short-float float)
528             (single-float float)
529             (double-float float)
530             (long-float float)
531             (rational real)
532             (integer rational)
533             (ratio rational)
534             (signed-byte integer)
535             (integer signed-byte)
536             (unsigned-byte signed-byte)
537             (bit unsigned-byte)
538             (fixnum integer)
539             (bignum integer)
540             (bit fixnum)
541             (arithmetic-error error)
542             (division-by-zero arithmetic-error)
543             (floating-point-invalid-operation arithmetic-error)
544             (floating-point-inexact arithmetic-error)
545             (floating-point-overflow arithmetic-error)
546             (floating-point-underflow arithmetic-error)
547             (character t)
548             (base-char character)
549             (standard-char base-char)
550             (extended-char character)
551             (sequence t)
552             (list sequence)
553             (null list)
554             #-(and cmu (not sparc)) (null boolean)
555             (cons list)
556             (array t)
557             (simple-array array)
558             (vector sequence)
559             (vector array)
560             (string vector)
561             (bit-vector vector)
562             (simple-vector vector)
563             (simple-vector simple-array)
564             (simple-bit-vector bit-vector)
565             (simple-bit-vector simple-array)
566             (base-string string)
567             (simple-string string)
568             (simple-string simple-array)
569             (simple-base-string base-string)
570             (simple-base-string simple-string)
571             (pathname t)
572             (logical-pathname pathname)
573             (file-error error)
574             (stream t)
575             (broadcast-stream stream)
576             (concatenated-stream stream)
577             (echo-stream stream)
578             (file-stream stream)
579             (string-stream stream)
580             (synonym-stream stream)
581             (two-way-stream stream)
582             (stream-error error)
583             (end-of-file stream-error)
584             (print-not-readable error)
585             (readtable t)
586             (reader-error parse-error)
587             (reader-error stream-error)
588             )))
589      (when (subtypep* 'character 'base-char)
590        (setq table
591              (append
592               '((character base-char)
593                 (string base-string)
594                 (simple-string simple-base-string))
595               table)))
596      
597      table))
598    
599  (defvar *disjoint-types-list*  (defvar *disjoint-types-list*
600      '(cons symbol array      '(cons symbol array
601        number character hash-table function readtable package        number character hash-table function readtable package

Legend:
Removed from v.1.31  
changed lines
  Added in v.1.32

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