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

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

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

File size: 7.8 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 (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))
Note: See TracBrowser for help on using the repository browser.