source: trunk/source/tests/ansi-tests/class-precedence-lists.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 7.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Jun  4 20:18:29 2003
4;;;; Contains: Tests that builtin classes have the right CPLs
5
6(in-package :cl-test)
7
8(eval-when (:load-toplevel :compile-toplevel :execute)
9  (unless #| (fboundp 'class-precedence-list-foo) |# nil
10    (report-and-ignore-errors
11      (defgeneric class-precedence-list-foo (x)
12        (:method-combination list)
13        .
14        #.(loop for s in *cl-types-that-are-classes-symbols*
15                collect
16                `(:method list ((x ,s))  ',s))))))
17
18(defmacro def-cpl-test (objform expected-cpl &optional name)
19  (let* ((ordered (loop for e = expected-cpl then (cdr e)
20                        for x = (car e)
21                        for y = (cadr e)
22                        while y
23                        always (subtypep x y))))
24    `(deftest ,(or name
25                   (intern (concatenate 'string
26                                        (symbol-name (first expected-cpl))
27                                        "-CPL")
28                           :cl-test))
29       (let* ((obj ,objform)
30              (cpl (class-precedence-list-foo obj)))
31         (or ,(if ordered
32                  nil
33                `(and (not (eql (class-of obj) (find-class ',(first expected-cpl))))
34                      (progn (format t "~%Note: ~S not a direct instance of ~A~%"
35                                     ',objform ',(first expected-cpl))
36                             t)))               
37             (and ,(if ordered t `(eql (first cpl) ',(first expected-cpl)))
38                  (is-noncontiguous-sublist-of ',expected-cpl cpl))))
39       t)))
40
41;;; Condition types
42
43(defmacro def-cond-cpl-test (expected-cpl)
44  `(def-cpl-test (make-condition ',(first expected-cpl)) ,expected-cpl))
45
46(def-cond-cpl-test (arithmetic-error error serious-condition condition t))
47(def-cond-cpl-test (cell-error error serious-condition condition t))
48(def-cond-cpl-test (condition t))
49(def-cond-cpl-test (control-error error serious-condition condition t))
50(def-cond-cpl-test (division-by-zero arithmetic-error error
51                                     serious-condition condition t))
52(def-cond-cpl-test (end-of-file stream-error error serious-condition condition t))
53(def-cond-cpl-test (error serious-condition condition t))
54(def-cond-cpl-test (file-error error serious-condition condition t))
55(def-cond-cpl-test (floating-point-inexact arithmetic-error error
56                                           serious-condition condition t))
57(def-cond-cpl-test (floating-point-invalid-operation
58                    arithmetic-error error serious-condition condition t))
59(def-cond-cpl-test (floating-point-overflow arithmetic-error error
60                                            serious-condition condition t))
61(def-cond-cpl-test (floating-point-underflow arithmetic-error error
62                                             serious-condition condition t))
63(def-cond-cpl-test (package-error error serious-condition condition t))
64(def-cond-cpl-test (parse-error error serious-condition condition t))
65(def-cond-cpl-test (print-not-readable error serious-condition condition t))
66(def-cond-cpl-test (program-error error serious-condition condition t))
67(def-cond-cpl-test (reader-error parse-error stream-error
68                                 error serious-condition condition t))
69(def-cond-cpl-test (serious-condition condition t))
70(def-cond-cpl-test (simple-condition condition t))
71(def-cond-cpl-test (simple-error simple-condition error serious-condition
72                                 condition t))
73(def-cond-cpl-test (simple-type-error simple-condition type-error
74                                      error serious-condition condition t))
75(def-cond-cpl-test (simple-warning simple-condition warning condition t))
76(def-cond-cpl-test (storage-condition serious-condition condition t))
77(def-cond-cpl-test (stream-error error serious-condition condition t))
78(def-cond-cpl-test (style-warning warning condition t))
79(def-cond-cpl-test (type-error error serious-condition condition t))
80(def-cond-cpl-test (unbound-slot cell-error error serious-condition condition t))
81(def-cond-cpl-test (unbound-variable cell-error error serious-condition condition t))
82(def-cond-cpl-test (undefined-function cell-error error serious-condition condition t))
83(def-cond-cpl-test (warning condition t))
84
85(def-cpl-test (make-array '(2 3 4)) (array t))
86(def-cpl-test (make-array '(10) :element-type 'bit :adjustable t :fill-pointer 5)
87  (bit-vector vector array sequence t))
88(def-cpl-test (make-broadcast-stream) (broadcast-stream stream t))
89(def-cpl-test (class-of 'symbol) (built-in-class class standard-object t))
90(def-cpl-test #\a (character t) character-cpl.1)
91(def-cpl-test #c(1.0 2.0) (complex number t) complex-cpl.1)
92(def-cpl-test #c(1 2) (complex number t) complex-cpl.2)
93(def-cpl-test #c(1/2 2/3) (complex number t) complex-cpl.3)
94(def-cpl-test (make-concatenated-stream) (concatenated-stream stream t))
95(def-cpl-test '(a b c) (cons list sequence t))
96(def-cpl-test (let ((out (make-string-output-stream)))
97                (make-echo-stream (make-string-input-stream "foo") out))
98  (echo-stream stream t))
99
100(def-cpl-test (open "class-precedence-lists.lsp" :direction :probe)
101  (file-stream stream t))
102
103(def-cpl-test 1.0s0 (float real number t) float-cpl.1)
104(def-cpl-test 1.0f0 (float real number t) float-cpl.2)
105(def-cpl-test 1.0d0 (float real number t) float-cpl.3)
106(def-cpl-test 1.0l0 (float real number t) float-cpl.4)
107
108(def-cpl-test #'car (function t))
109;; (def-cpl-test #'make-instance (generic-function function t))
110
111(def-cpl-test (make-hash-table) (hash-table t) hash-table-cpl.1)
112(def-cpl-test (make-hash-table :test 'eq) (hash-table t) hash-table-cpl.2)
113(def-cpl-test (make-hash-table :test 'equal) (hash-table t) hash-table-cpl.3)
114
115(def-cpl-test 0 (integer rational real number t) integer-cpl.1)
116(def-cpl-test (1+ most-positive-fixnum) (integer rational real number t) integer-cpl.2)
117(def-cpl-test (1- most-negative-fixnum) (integer rational real number t) integer-cpl.3)
118
119(def-cpl-test nil (list sequence t) list-cpl.1)
120(def-cpl-test '(a b c) (list sequence t) list-cpl.2)
121
122;;; Insert a test for LOGICAL-PATHNAME here
123;;; (def-cpl-test ????? (logical-pathname pathname t))
124
125;;; (def-cpl-test (find-method #'class-name nil (list (find-class 'class)))
126;;;  (method t))
127
128;;; Insert test for METHOD-COMBINATION here
129
130(def-cpl-test nil (null symbol list sequence t))
131
132(def-cpl-test (find-package "CL") (package t))
133(def-cpl-test #p"foo" (pathname t))
134(def-cpl-test *random-state* (random-state t))
135(def-cpl-test 5/3 (ratio rational real number t))
136(def-cpl-test *readtable* (readtable t))
137
138(defclass cpl-example-class () ())
139
140(def-cpl-test (find-class 'cpl-example-class)
141  (standard-class class standard-object t))
142
143(defgeneric cpl-example-gf (x y))
144
145(def-cpl-test #'cpl-example-gf (standard-generic-function generic-function function t))
146
147(def-cpl-test (eval '(defmethod cpl-example-gf ((x t) (y t)) (list y x)))
148  (standard-method method standard-object t))
149
150(def-cpl-test (make-array '(10) :element-type 'character :initial-element #\a
151                          :fill-pointer t :adjustable t)
152  (string vector array sequence t) string-cpl.1)
153
154(def-cpl-test "abcd" (string vector array sequence t) string-cpl.2)
155
156(def-cpl-test (make-string-input-stream "abcdef") (string-stream stream t))
157
158(defstruct cpl-example-structure-class a b c)
159
160;;; No test for STRUCTURE-OBJECT
161
162(def-cpl-test 'a (symbol t))
163
164(defparameter *cpl-input-stream* (make-string-input-stream "foofoofoofoo"))
165
166(def-cpl-test (make-synonym-stream '*cpl-input-stream*) (synonym-stream stream t))
167
168(defparameter *cpl-output-stream* (make-string-output-stream))
169
170(def-cpl-test (make-two-way-stream *cpl-input-stream* *cpl-output-stream*)
171  (two-way-stream stream t))
172
173(def-cpl-test (make-array '(10) :fill-pointer t :adjustable t :initial-element '(a b c))
174  (vector array sequence t))
Note: See TracBrowser for help on using the repository browser.