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 (when *test-verbose* |
---|
35 | (format t "~%Note: ~S not a direct instance of ~A~%" |
---|
36 | ',objform ',(first expected-cpl))) |
---|
37 | t))) |
---|
38 | (and ,(if ordered t `(eql (first cpl) ',(first expected-cpl))) |
---|
39 | (is-noncontiguous-sublist-of ',expected-cpl cpl)))) |
---|
40 | t))) |
---|
41 | |
---|
42 | ;;; Condition types |
---|
43 | |
---|
44 | (defmacro def-cond-cpl-test (expected-cpl) |
---|
45 | `(def-cpl-test (make-condition ',(first expected-cpl)) ,expected-cpl)) |
---|
46 | |
---|
47 | (def-cond-cpl-test (arithmetic-error error serious-condition condition t)) |
---|
48 | (def-cond-cpl-test (cell-error error serious-condition condition t)) |
---|
49 | (def-cond-cpl-test (condition t)) |
---|
50 | (def-cond-cpl-test (control-error error serious-condition condition t)) |
---|
51 | (def-cond-cpl-test (division-by-zero arithmetic-error error |
---|
52 | serious-condition condition t)) |
---|
53 | (def-cond-cpl-test (end-of-file stream-error error serious-condition condition t)) |
---|
54 | (def-cond-cpl-test (error serious-condition condition t)) |
---|
55 | (def-cond-cpl-test (file-error error serious-condition condition t)) |
---|
56 | (def-cond-cpl-test (floating-point-inexact arithmetic-error error |
---|
57 | serious-condition condition t)) |
---|
58 | (def-cond-cpl-test (floating-point-invalid-operation |
---|
59 | arithmetic-error error serious-condition condition t)) |
---|
60 | (def-cond-cpl-test (floating-point-overflow arithmetic-error error |
---|
61 | serious-condition condition t)) |
---|
62 | (def-cond-cpl-test (floating-point-underflow arithmetic-error error |
---|
63 | serious-condition condition t)) |
---|
64 | (def-cond-cpl-test (package-error error serious-condition condition t)) |
---|
65 | (def-cond-cpl-test (parse-error error serious-condition condition t)) |
---|
66 | (def-cond-cpl-test (print-not-readable error serious-condition condition t)) |
---|
67 | (def-cond-cpl-test (program-error error serious-condition condition t)) |
---|
68 | (def-cond-cpl-test (reader-error parse-error stream-error |
---|
69 | error serious-condition condition t)) |
---|
70 | (def-cond-cpl-test (serious-condition condition t)) |
---|
71 | (def-cond-cpl-test (simple-condition condition t)) |
---|
72 | (def-cond-cpl-test (simple-error simple-condition error serious-condition |
---|
73 | condition t)) |
---|
74 | (def-cond-cpl-test (simple-type-error simple-condition type-error |
---|
75 | error serious-condition condition t)) |
---|
76 | (def-cond-cpl-test (simple-warning simple-condition warning condition t)) |
---|
77 | (def-cond-cpl-test (storage-condition serious-condition condition t)) |
---|
78 | (def-cond-cpl-test (stream-error error serious-condition condition t)) |
---|
79 | (def-cond-cpl-test (style-warning warning condition t)) |
---|
80 | (def-cond-cpl-test (type-error error serious-condition condition t)) |
---|
81 | (def-cond-cpl-test (unbound-slot cell-error error serious-condition condition t)) |
---|
82 | (def-cond-cpl-test (unbound-variable cell-error error serious-condition condition t)) |
---|
83 | (def-cond-cpl-test (undefined-function cell-error error serious-condition condition t)) |
---|
84 | (def-cond-cpl-test (warning condition t)) |
---|
85 | |
---|
86 | (def-cpl-test (make-array '(2 3 4)) (array t)) |
---|
87 | (def-cpl-test (make-array '(10) :element-type 'bit :adjustable t :fill-pointer 5) |
---|
88 | (bit-vector vector array sequence t)) |
---|
89 | (def-cpl-test (make-broadcast-stream) (broadcast-stream stream t)) |
---|
90 | (def-cpl-test (class-of 'symbol) (built-in-class class standard-object t)) |
---|
91 | (def-cpl-test #\a (character t) character-cpl.1) |
---|
92 | (def-cpl-test #c(1.0 2.0) (complex number t) complex-cpl.1) |
---|
93 | (def-cpl-test #c(1 2) (complex number t) complex-cpl.2) |
---|
94 | (def-cpl-test #c(1/2 2/3) (complex number t) complex-cpl.3) |
---|
95 | (def-cpl-test (make-concatenated-stream) (concatenated-stream stream t)) |
---|
96 | (def-cpl-test '(a b c) (cons list sequence t)) |
---|
97 | (def-cpl-test (let ((out (make-string-output-stream))) |
---|
98 | (make-echo-stream (make-string-input-stream "foo") out)) |
---|
99 | (echo-stream stream t)) |
---|
100 | |
---|
101 | (def-cpl-test (open "class-precedence-lists.lsp" :direction :probe) |
---|
102 | (file-stream stream t)) |
---|
103 | |
---|
104 | (def-cpl-test 1.0s0 (float real number t) float-cpl.1) |
---|
105 | (def-cpl-test 1.0f0 (float real number t) float-cpl.2) |
---|
106 | (def-cpl-test 1.0d0 (float real number t) float-cpl.3) |
---|
107 | (def-cpl-test 1.0l0 (float real number t) float-cpl.4) |
---|
108 | |
---|
109 | (def-cpl-test #'car (function t)) |
---|
110 | ;; (def-cpl-test #'make-instance (generic-function function t)) |
---|
111 | |
---|
112 | (def-cpl-test (make-hash-table) (hash-table t) hash-table-cpl.1) |
---|
113 | (def-cpl-test (make-hash-table :test 'eq) (hash-table t) hash-table-cpl.2) |
---|
114 | (def-cpl-test (make-hash-table :test 'equal) (hash-table t) hash-table-cpl.3) |
---|
115 | |
---|
116 | (def-cpl-test 0 (integer rational real number t) integer-cpl.1) |
---|
117 | (def-cpl-test (1+ most-positive-fixnum) (integer rational real number t) integer-cpl.2) |
---|
118 | (def-cpl-test (1- most-negative-fixnum) (integer rational real number t) integer-cpl.3) |
---|
119 | |
---|
120 | (def-cpl-test nil (list sequence t) list-cpl.1) |
---|
121 | (def-cpl-test '(a b c) (list sequence t) list-cpl.2) |
---|
122 | |
---|
123 | ;;; Insert a test for LOGICAL-PATHNAME here |
---|
124 | ;;; (def-cpl-test ????? (logical-pathname pathname t)) |
---|
125 | |
---|
126 | ;;; (def-cpl-test (find-method #'class-name nil (list (find-class 'class))) |
---|
127 | ;;; (method t)) |
---|
128 | |
---|
129 | ;;; Insert test for METHOD-COMBINATION here |
---|
130 | |
---|
131 | (def-cpl-test nil (null symbol list sequence t)) |
---|
132 | |
---|
133 | (def-cpl-test (find-package "CL") (package t)) |
---|
134 | (def-cpl-test #p"foo" (pathname t)) |
---|
135 | (def-cpl-test *random-state* (random-state t)) |
---|
136 | (def-cpl-test 5/3 (ratio rational real number t)) |
---|
137 | (def-cpl-test *readtable* (readtable t)) |
---|
138 | |
---|
139 | (defclass cpl-example-class () ()) |
---|
140 | |
---|
141 | (def-cpl-test (find-class 'cpl-example-class) |
---|
142 | (standard-class class standard-object t)) |
---|
143 | |
---|
144 | (defgeneric cpl-example-gf (x y)) |
---|
145 | |
---|
146 | (def-cpl-test #'cpl-example-gf (standard-generic-function generic-function function t)) |
---|
147 | |
---|
148 | (def-cpl-test (eval '(defmethod cpl-example-gf ((x t) (y t)) (list y x))) |
---|
149 | (standard-method method standard-object t)) |
---|
150 | |
---|
151 | (def-cpl-test (make-array '(10) :element-type 'character :initial-element #\a |
---|
152 | :fill-pointer t :adjustable t) |
---|
153 | (string vector array sequence t) string-cpl.1) |
---|
154 | |
---|
155 | (def-cpl-test "abcd" (string vector array sequence t) string-cpl.2) |
---|
156 | |
---|
157 | (def-cpl-test (make-string-input-stream "abcdef") (string-stream stream t)) |
---|
158 | |
---|
159 | (defstruct cpl-example-structure-class a b c) |
---|
160 | |
---|
161 | ;;; No test for STRUCTURE-OBJECT |
---|
162 | |
---|
163 | (def-cpl-test 'a (symbol t)) |
---|
164 | |
---|
165 | (defparameter *cpl-input-stream* (make-string-input-stream "foofoofoofoo")) |
---|
166 | |
---|
167 | (def-cpl-test (make-synonym-stream '*cpl-input-stream*) (synonym-stream stream t)) |
---|
168 | |
---|
169 | (defparameter *cpl-output-stream* (make-string-output-stream)) |
---|
170 | |
---|
171 | (def-cpl-test (make-two-way-stream *cpl-input-stream* *cpl-output-stream*) |
---|
172 | (two-way-stream stream t)) |
---|
173 | |
---|
174 | (def-cpl-test (make-array '(10) :fill-pointer t :adjustable t :initial-element '(a b c)) |
---|
175 | (vector array sequence t)) |
---|