source: trunk/tests/ansi-tests/ansi-aux.lsp @ 9045

Last change on this file since 9045 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: 35.4 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Mar 28 17:10:18 1998
4;;;; Contains: Aux. functions for CL-TEST
5
6(in-package :cl-test)
7
8(declaim (optimize (safety 3)))
9
10;;; A function for coercing truth values to BOOLEAN
11
12(defun notnot (x) (not (not x)))
13
14(defmacro notnot-mv (form)
15  `(notnot-mv-fn (multiple-value-list ,form)))
16
17(defun notnot-mv-fn (results)
18  (if (null results)
19      (values)
20    (apply #'values
21           (not (not (first results)))
22           (rest results))))
23
24(defmacro not-mv (form)
25  `(not-mv-fn (multiple-value-list ,form)))
26
27(defun not-mv-fn (results)
28  (if (null results)
29      (values)
30    (apply #'values
31           (not (first results))
32           (rest results))))
33
34(declaim (ftype (function (t) function) to-function))
35
36(defun to-function (fn)
37  (etypecase fn
38    (function fn)
39    (symbol (symbol-function fn))
40    ((cons (eql setf) (cons symbol null)) (fdefinition fn))))
41
42;;; Macro to check that a function is returning a specified number of values
43;;; (defaults to 1)
44(defmacro check-values (form &optional (num 1))
45  (let ((v (gensym))
46        (n (gensym)))
47   `(let ((,v (multiple-value-list ,form))
48          (,n ,num))
49      (check-values-length ,v ,n ',form)
50      (car ,v))))
51
52(defun check-values-length (results expected-number form)
53  (declare (type fixnum expected-number))
54  (let ((n expected-number))
55    (declare (type fixnum n))
56    (decf n (length results))
57    (unless (= n 0)
58      (error "Expected ~A results from ~A, got ~A results instead.~%~
59Results: ~A~%" expected-number form n results))))
60
61;;; Do multiple-value-bind, but check # of arguments
62(defmacro multiple-value-bind* ((&rest vars) form &body body)
63  (let ((len (length vars))
64        (v (gensym)))
65    `(let ((,v (multiple-value-list ,form)))
66       (check-values-length ,v ,len ',form)
67       (destructuring-bind ,vars ,v ,@body))))
68 
69;;; Comparison functions that are like various builtins,
70;;; but are guaranteed to return T for true.
71
72(defun eqt (x y)
73  "Like EQ, but guaranteed to return T for true."
74  (apply #'values (mapcar #'notnot (multiple-value-list (eq x y)))))
75
76(defun eqlt (x y)
77  "Like EQL, but guaranteed to return T for true."
78  (apply #'values (mapcar #'notnot (multiple-value-list (eql x y)))))
79
80(defun equalt (x y)
81  "Like EQUAL, but guaranteed to return T for true."
82  (apply #'values (mapcar #'notnot (multiple-value-list (equal x y)))))
83
84(defun equalpt (x y)
85  "Like EQUALP, but guaranteed to return T for true."
86  (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y)))))
87
88(defun equalpt-or-report (x y)
89  "Like EQUALPT, but return either T or a list of the arguments."
90  (or (equalpt x y) (list x y)))
91
92(defun string=t (x y)
93  (notnot-mv (string= x y)))
94
95(defun =t (x &rest args)
96  "Like =, but guaranteed to return T for true."
97  (apply #'values (mapcar #'notnot (multiple-value-list (apply #'=  x args)))))
98
99(defun <=t (x &rest args)
100  "Like <=, but guaranteed to return T for true."
101  (apply #'values (mapcar #'notnot (multiple-value-list (apply #'<=  x args)))))
102
103(defun make-int-list (n)
104  (loop for i from 0 below n collect i))
105
106(defun make-int-array (n &optional (fn #'make-array))
107  (when (symbolp fn)
108    (assert (fboundp fn))
109    (setf fn (symbol-function (the symbol fn))))
110  (let ((a (funcall (the function fn) n)))
111    (declare (type (array * *) a))
112    (loop for i from 0 below n do (setf (aref a i) i))
113    a))
114
115;;; Return true if A1 and A2 are arrays with the same rank
116;;; and dimensions whose elements are EQUAL
117
118(defun equal-array (a1 a2)
119  (and (typep a1 'array)
120       (typep a2 'array)
121       (= (array-rank a1) (array-rank a2))
122       (if (= (array-rank a1) 0)
123           (equal (regression-test::my-aref a1) (regression-test::my-aref a2))
124         (let ((ad (array-dimensions a1)))
125           (and (equal ad (array-dimensions a2))
126                (locally
127                 (declare (type (array * *) a1 a2))
128                 (if (= (array-rank a1) 1)
129                     (let ((as (first ad)))
130                       (loop
131                        for i from 0 below as
132                        always (equal (regression-test::my-aref a1 i)
133                                      (regression-test::my-aref a2 i))))
134                   (let ((as (array-total-size a1)))
135                     (and (= as (array-total-size a2))
136                          (loop
137                           for i from 0 below as
138                           always
139                           (equal
140                            (regression-test::my-row-major-aref a1 i)
141                            (regression-test::my-row-major-aref a2 i))
142                           ))))))))))
143
144;;; *universe* is defined elsewhere -- it is a list of various
145;;; lisp objects used when stimulating things in various tests.
146(declaim (special *universe*))
147
148;;; The function EMPIRICAL-SUBTYPEP checks two types
149;;; for subtypeness, first using SUBTYPEP*, then (if that
150;;; fails) empirically against all the elements of *universe*,
151;;; checking if all that are in the first are also in the second.
152;;; Return T if this is the case, NIL otherwise.  This will
153;;; always return T if type1 is truly a subtype of type2,
154;;; but may return T even if this is not the case.
155
156(defun empirical-subtypep (type1 type2)
157  (multiple-value-bind (sub good)
158      (subtypep* type1 type2)
159    (if good
160        sub
161      (loop for e in *universe*
162            always (or (not (typep e type1)) (typep e type2))))))
163
164(defun check-type-predicate (P TYPE)
165  "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
166   by applying both to all elements of *UNIVERSE*.  Print message
167   when a mismatch is found, and return number of mistakes."
168
169  (when (symbolp p)
170    (assert (fboundp p))
171    (setf p (symbol-function p)))
172  (assert (typep p 'function))
173
174  (loop
175      for x in *universe*
176      when
177        (block failed
178          (let ((p1 (handler-case
179                        (normally (funcall (the function p) x))
180                      (error () (format t "(FUNCALL ~S ~S) failed~%"
181                                        P x)
182                        (return-from failed t))))
183                (p2 (handler-case
184                        (normally (typep x TYPE))
185                      (error () (format t "(TYPEP ~S '~S) failed~%"
186                                        x TYPE)
187                        (return-from failed t)))))
188              (when (or (and p1 (not p2))
189                        (and (not p1) p2))
190                (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%"
191                        P x p1 x TYPE p2)
192                t)))
193        collect x))
194
195;;; We have a common idiom where a guarded predicate should be
196;;; true everywhere
197
198(defun check-predicate (predicate &optional guard (universe *universe*))
199  "Return all elements of UNIVERSE for which the guard (if present) is false
200   and for which PREDICATE is false."
201  (remove-if #'(lambda (e) (or (and guard (funcall guard e))
202                               (funcall predicate e)))
203             universe))
204
205(declaim (special *catch-error-type*))
206
207(defun catch-continue-debugger-hook (condition dbh)
208  "Function that when used as *debugger-hook*, causes
209   continuable errors to be continued without user intervention."
210  (declare (ignore dbh))
211  (let ((r (find-restart 'continue condition)))
212    (cond
213     ((and *catch-error-type*
214           (not (typep condition *catch-error-type*)))
215      (format t "Condition ~S is not a ~A~%" condition *catch-error-type*)
216      (cond (r (format t "Its continue restart is ~S~%" r))
217            (t (format t "It has no continue restart~%")))
218      (throw 'continue-failed nil))
219     (r (invoke-restart r))
220     (t (throw 'continue-failed nil)))))
221
222#|
223(defun safe (fn &rest args)
224  "Apply fn to args, trapping errors.  Convert type-errors to the
225   symbol type-error."
226  (declare (optimize (safety 3)))
227  (handler-case
228   (apply fn args)
229   (type-error () 'type-error)
230   (error (c) c)))
231|#
232
233;;; Use the next macro in place of SAFE
234
235(defmacro catch-type-error (form)
236"Evaluate form in safe mode, returning its value if there is no error.
237If an error does occur, return type-error on TYPE-ERRORs, or the error
238condition itself on other errors."
239`(locally (declare (optimize (safety 3)))
240  (handler-case (normally ,form)
241     (type-error () 'type-error)
242     (error (c) c))))
243
244(defmacro classify-error* (form)
245"Evaluate form in safe mode, returning its value if there is no error.
246If an error does occur, return a symbol classify the error, or allow
247the condition to go uncaught if it cannot be classified."
248`(locally (declare (optimize (safety 3)))
249  (handler-case (normally ,form)
250     (undefined-function () 'undefined-function)
251     (program-error () 'program-error)
252     (package-error () 'package-error)
253     (type-error    () 'type-error)
254     (control-error () 'control-error)
255     (parse-error   () 'parse-error)
256     (stream-error  () 'stream-error)
257     (reader-error  () 'reader-error)
258     (file-error    () 'file-error)
259     (cell-error    () 'cell-error)
260     (division-by-zero () 'division-by-zero)
261     (floating-point-overflow () 'floating-point-overflow)
262     (floating-point-underflow () 'floating-point-underflow)
263     (arithmetic-error () 'arithmetic-error)
264     (error         () 'error)
265  )))
266
267(defun classify-error** (form)
268  (handler-bind ((warning #'(lambda (c) (declare (ignore c))
269                              (muffle-warning))))
270                (proclaim '(optimize (safety 3)))
271                (classify-error*
272                 (if regression-test::*compile-tests*
273                     (funcall (compile nil `(lambda ()
274                                              (declare (optimize (safety 3)))
275                                              ,form)))
276                     (eval form))
277                 )))
278
279(defmacro classify-error (form)
280  `(classify-error** ',form))
281
282;;; The above is badly designed, since it fails when some signals
283;;; may be in more than one class/
284
285(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil))
286  `(handler-bind
287    ((warning #'(lambda (c) (declare (ignore c))
288                              (muffle-warning))))
289    (proclaim '(optimize (safety 3)))
290    (handler-case
291     (apply #'values
292            nil
293            (multiple-value-list
294             ,(cond
295               (inline form)
296               (regression-test::*compile-tests*
297                `(funcall (compile nil '(lambda ()
298                                          (declare (optimize (safety ,safety)))
299                                          ,form))))
300               (t `(eval ',form)))))
301     (,error-name (c)
302       (declare (ignorable c))
303                  (cond
304                   ,@(case error-name
305                       (type-error
306                        `(((typep (type-error-datum c)
307                                  (type-error-expected-type c))
308                           (values
309                            nil
310                            (list (list 'typep (list 'quote
311                                                     (type-error-datum c))
312                                        (list 'quote
313                                              (type-error-expected-type c)))
314                                  "==> true")))))
315                       ((undefined-function unbound-variable)
316                        (and name-p
317                             `(((not (eq (cell-error-name c) ',name))
318                                (values
319                                 nil
320                                 (list 'cell-error-name "==>"
321                                       (cell-error-name c)))))))
322                       ((stream-error end-of-file reader-error)
323                        `(((not (streamp (stream-error-stream c)))
324                           (values
325                            nil
326                            (list 'stream-error-stream "==>"
327                                  (stream-error-stream c))))))
328                       (file-error
329                        `(((not (pathnamep (pathname (file-error-pathname c))))
330                           (values
331                            nil
332                            (list 'file-error-pathname "==>"
333                                  (file-error-pathname c))))))
334                       (t nil))
335                   (t (printable-p c)))))))
336
337(defmacro signals-error-always (form error-name)
338  `(values
339    (signals-error ,form ,error-name)
340    (signals-error ,form ,error-name :safety 0)))
341
342(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil))
343  (let ((lambda-form
344         `(lambda (,var)
345            (declare (optimize (safety ,safety)))
346            ,form)))
347    `(let ((,var ,datum-form))
348       (declare (optimize safety))
349       (handler-bind
350        ((warning #'(lambda (c) (declare (ignore c))
351                      (muffle-warning))))
352                                        ; (proclaim '(optimize (safety 3)))
353        (handler-case
354         (apply #'values
355                nil
356                (multiple-value-list
357                 (funcall
358                 ,(cond
359                   (inline `(function ,lambda-form))
360                   (regression-test::*compile-tests*
361                     `(compile nil ',lambda-form))
362                   (t `(eval ',lambda-form)))
363                  ,var)))
364         (type-error
365          (c)
366          (let ((datum (type-error-datum c))
367                (expected-type (type-error-expected-type c)))
368            (cond
369             ((not (eql ,var datum))
370              (list :datum-mismatch ,var datum))
371             ((typep datum expected-type)
372              (list :is-typep datum expected-type))
373             (t (printable-p c))))))))))
374
375(declaim (special *mini-universe*))
376
377(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*))
378  "Check that for all elements in some set, either guard-fn is true or
379   pred-fn signals a type error."
380  (let (val)
381    (loop for e in universe
382          unless (or (funcall guard-fn e)
383                     (equal
384                      (setf val (multiple-value-list
385                                 (signals-type-error x e (funcall pred-fn x) :inline t)))
386                      '(t)))
387        collect (list e val))))
388
389(defmacro check-type-error (&body args)
390  `(locally (declare (optimize safety)) (check-type-error* ,@args)))
391
392(defun printable-p (obj)
393  "Returns T iff obj can be printed to a string."
394  (with-standard-io-syntax
395   (let ((*print-readably* nil)
396         (*print-escape* nil))
397     (declare (optimize safety))
398     (handler-case (and (stringp (write-to-string obj)) t)
399                   (condition (c) (declare (ignore c)) nil)))))
400
401;;;
402;;; The function SUBTYPEP should return two generalized booleans.
403;;; This auxiliary function returns booleans instead
404;;; (which makes it easier to write tests).
405;;;
406(defun subtypep* (type1 type2)
407  (apply #'values
408         (mapcar #'notnot
409                 (multiple-value-list (subtypep type1 type2)))))
410
411(defun subtypep*-or-fail (type1 type2)
412  (let ((results (multiple-value-list (subtypep type1 type2))))
413    (and (= (length results) 2)
414         (or (not (second results))
415             (notnot (first results))))))
416
417(defun subtypep*-not-or-fail (type1 type2)
418  (let ((results (multiple-value-list (subtypep type1 type2))))
419    (and (= (length results) 2)
420         (or (not (second results))
421             (not (first results))))))
422
423;; (declaim (ftype (function (&rest function) (values function &optional))
424;;              compose))
425
426(defun compose (&rest fns)
427  (let ((rfns (reverse fns)))
428    #'(lambda (x) (loop for f
429                        in rfns do (setf x (funcall (the function f) x))) x)))
430
431(defun evendigitp (c)
432  (notnot (find c "02468")))
433
434(defun odddigitp (c)
435  (notnot (find c "13579")))
436
437(defun nextdigit (c)
438  (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))
439
440(defun is-eq-p (x) #'(lambda (y) (eqt x y)))
441(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y))))
442
443(defun is-eql-p (x) #'(lambda (y) (eqlt x y)))
444(defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y))))
445
446(defun onep (x) (eql x 1))
447
448(defun char-invertcase (c)
449  (if (upper-case-p c) (char-downcase c)
450    (char-upcase c)))
451
452(defun string-invertcase (s)
453  (map 'string #'char-invertcase s))
454
455(defun symbol< (x &rest args)
456  (apply #'string< (symbol-name x) (mapcar #'symbol-name args)))
457
458
459(defun make-list-expr (args)
460  "Build an expression for computing (LIST . args), but that evades
461   CALL-ARGUMENTS-LIMIT."
462  (if (cddddr args)
463      (list 'list*
464            (first args) (second args) (third args) (fourth args)
465            (make-list-expr (cddddr args)))
466    (cons 'list args))) 
467
468(defparameter +standard-chars+
469  (coerce
470  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./
471 " 'simple-base-string))
472
473(defparameter
474  +base-chars+ #.(coerce
475                  (concatenate 'string
476                               "abcdefghijklmnopqrstuvwxyz"
477                               "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
478                               "0123456789"
479                               "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")
480                  'simple-base-string))
481                 
482
483(declaim (type simple-base-string +base-chars+))
484
485(defparameter +num-base-chars+ (length +base-chars+))
486
487(defparameter +alpha-chars+ (subseq +standard-chars+ 0 52))
488(defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26))
489(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52))
490(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62))
491(defparameter +digit-chars+ "0123456789")
492(defparameter +extended-digit-chars+ (coerce
493                                      "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
494                                      'simple-base-string))
495
496(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+
497               +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+
498               +standard-chars+))
499
500(defparameter +code-chars+
501  (coerce (loop for i from 0 below 256
502                for c = (code-char i)
503                when c collect c)
504          'simple-string))
505
506(declaim (type simple-string +code-chars+))
507
508(defparameter +rev-code-chars+ (reverse +code-chars+))
509
510;;; Used in checking for continuable errors
511
512(defun has-non-abort-restart (c)
513  (throw 'handled
514         (if (position 'abort (the list (compute-restarts c))
515                       :key #'restart-name :test-not #'eq)
516             'success
517           'fail)))
518
519(defmacro handle-non-abort-restart (&body body)
520  `(catch 'handled
521     (handler-bind ((error #'has-non-abort-restart))
522                   ,@body)))
523
524;;; used in elt.lsp
525(defun elt-v-6-body ()
526  (let ((x (make-int-list 1000)))
527    (let ((a (make-array '(1000) :initial-contents x)))
528      (loop
529          for i from 0 to 999 do
530            (unless (eql i (elt a i)) (return nil))
531          finally (return t)))))
532
533(defun make-adj-array (n &key initial-contents)
534  (if initial-contents
535      (make-array n :adjustable t :initial-contents initial-contents)
536    (make-array n :adjustable t)))
537
538;;; used in elt.lsp
539(defun elt-adj-array-6-body ()
540  (let ((x (make-int-list 1000)))
541    (let ((a (make-adj-array '(1000) :initial-contents x)))
542      (loop
543          for i from 0 to 999 do
544            (unless (eql i (elt a i)) (return nil))
545          finally (return t)))))
546
547(defparameter *displaced* (make-int-array 100000))
548
549(defun make-displaced-array (n displacement)
550  (make-array n :displaced-to *displaced*
551
552              :displaced-index-offset displacement))
553
554;;; used in fill.lsp
555(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args)
556  (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size)
557                        :initial-contents '(1 2 3 4 5)))
558         (b (apply #'fill a fill-args)))
559    (values (eqt a b)
560            (map 'list #'identity a))))
561
562;;; used in fill-strings.lsp
563(defun array-string-fill-test-fn (a &rest fill-args)
564  (setq a (copy-seq a))
565  (let ((b (apply #'fill a fill-args)))
566    (values (eqt a b) b)))
567
568;;; From types-and-class.lsp
569
570(defparameter +float-types+
571  '(long-float double-float short-float single-float))
572
573(defparameter *subtype-table*
574(let ((table
575       '(
576         (null symbol)
577         (symbol t)
578         (boolean symbol)
579         (standard-object t)
580         (function t)
581         (compiled-function function)
582         (generic-function function)
583         (standard-generic-function generic-function)
584         (class standard-object)
585         (built-in-class class)
586         (structure-class class)
587         (standard-class class)
588         (method standard-object)
589         (standard-method method)
590         (structure-object t)
591         (method-combination t)
592         (condition t)
593         (serious-condition condition)
594         (error serious-condition)
595         (type-error error)
596         (simple-type-error type-error)
597         (simple-condition condition)
598         (simple-type-error simple-condition)
599         (parse-error error)
600         (hash-table t)
601         (cell-error error)
602         (unbound-slot cell-error)
603         (warning condition)
604         (style-warning warning)
605         (storage-condition serious-condition)
606         (simple-warning warning)
607         (simple-warning simple-condition)
608         (keyword symbol)
609         (unbound-variable cell-error)
610         (control-error error)
611         (program-error error)
612         (undefined-function cell-error)
613         (package t)
614         (package-error error)
615         (random-state t)
616         (number t)
617         (real number)
618         (complex number)
619         (float real)
620         (short-float float)
621         (single-float float)
622         (double-float float)
623         (long-float float)
624         (rational real)
625         (integer rational)
626         (ratio rational)
627         (signed-byte integer)
628         (integer signed-byte)
629         (unsigned-byte signed-byte)
630         (bit unsigned-byte)
631         (fixnum integer)
632         (bignum integer)
633         (bit fixnum)
634         (arithmetic-error error)
635         (division-by-zero arithmetic-error)
636         (floating-point-invalid-operation arithmetic-error)
637         (floating-point-inexact arithmetic-error)
638         (floating-point-overflow arithmetic-error)
639         (floating-point-underflow arithmetic-error)
640         (character t)
641         (base-char character)
642         (standard-char base-char)
643         (extended-char character)
644         (sequence t)
645         (list sequence)
646         (null list)
647         (null boolean)
648         (cons list)
649         (array t)
650         (simple-array array)
651         (vector sequence)
652         (vector array)
653         (string vector)
654         (bit-vector vector)
655         (simple-vector vector)
656         (simple-vector simple-array)
657         (simple-bit-vector bit-vector)
658         (simple-bit-vector simple-array)
659         (base-string string)
660         (simple-string string)
661         (simple-string simple-array)
662         (simple-base-string base-string)
663         (simple-base-string simple-string)
664         (pathname t)
665         (logical-pathname pathname)
666         (file-error error)
667         (stream t)
668         (broadcast-stream stream)
669         (concatenated-stream stream)
670         (echo-stream stream)
671         (file-stream stream)
672         (string-stream stream)
673         (synonym-stream stream)
674         (two-way-stream stream)
675         (stream-error error)
676         (end-of-file stream-error)
677         (print-not-readable error)
678         (readtable t)
679         (reader-error parse-error)
680         (reader-error stream-error)
681         )))
682  (when (subtypep* 'character 'base-char)
683    (setq table
684          (append
685           '((character base-char)
686             ;; (string base-string)
687             ;; (simple-string simple-base-string)
688             )
689           table)))
690 
691  table))
692
693(defparameter *disjoint-types-list*
694    '(cons symbol array
695      number character hash-table function readtable package
696      pathname stream random-state condition restart))
697
698(defparameter *disjoint-types-list2*
699  `((cons (cons t t) (cons t (cons t t)) (eql (nil)))
700    (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *))
701    (array vector simple-array simple-vector string simple-string
702           base-string simple-base-string (eql #()))
703    (character base-char standard-char (eql #\a)
704               ,@(if (subtypep 'character 'base-char) nil
705                   (list 'extended-char)))
706    (function compiled-function generic-function standard-generic-function
707              (eql ,#'car))
708    (package (eql ,(find-package "COMMON-LISP")))
709    (pathname logical-pathname (eql #p""))
710    (stream broadcast-stream concatenated-stream echo-stream
711            file-stream string-stream synonym-stream two-way-stream)
712    (number real complex float integer rational ratio fixnum
713            bit (integer 0 100) (float 0.0 100.0) (integer 0 *)
714            (rational 0 *) (mod 10)
715            (eql 0)
716            ,@(and (not (subtypep 'bignum nil))
717                   (list 'bignum)))
718    (random-state)
719    ,*condition-types*
720    (restart)
721    (readtable)))
722
723(defparameter *types-list3*
724  (reduce #'append *disjoint-types-list2* :from-end t))
725
726(defun trim-list (list n)
727  (let ((len (length list)))
728    (if (<= len n) list
729      (append (subseq list 0 n)
730              (format nil "And ~A more omitted." (- len n))))))
731
732(defun is-t-or-nil (e)
733  (or (eqt e t) (eqt e nil)))
734
735(defun is-builtin-class (type)
736  (when (symbolp type) (setq type (find-class type nil)))
737  (typep type 'built-in-class))
738
739(defun even-size-p (a)
740  (some #'evenp (array-dimensions a)))
741
742
743(defun safe-elt (x n)
744  (classify-error* (elt x n)))
745
746(defmacro defstruct* (&body args)
747  `(eval-when (:load-toplevel :compile-toplevel :execute)
748     (handler-case (eval '(defstruct ,@args))
749                      (serious-condition () nil))))
750
751(defun safely-delete-package (package-designator)
752  (let ((package (find-package package-designator)))
753    (when package
754      (let ((used-by (package-used-by-list package)))
755        (dolist (using-package used-by)
756          (unuse-package package using-package)))
757      (delete-package package))))
758
759#-(or allegro openmcl lispworks)
760(defun delete-all-versions (pathspec)
761  "Replace the versions field of the pathname specified by pathspec with
762   :wild, and delete all the files this refers to."
763  (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec)))
764         (truenames (directory wild-pathname)))
765    (mapc #'delete-file truenames)))   
766
767;;; This is a hack to get around an ACL bug; OpenMCL also apparently
768;;; needs it
769#+(or allegro openmcl lispworks)
770(defun delete-all-versions (pathspec)
771  (when (probe-file pathspec) (delete-file pathspec)))
772
773(defconstant +fail-count-limit+ 20)
774
775(defun frob-simple-condition (c expected-fmt &rest expected-args)
776  "Try out the format control and format arguments of a simple-condition C,
777   but make no assumptions about what they print as, only that they
778   do print."
779  (declare (ignore expected-fmt expected-args))
780  (and (typep c 'simple-condition)
781       (let ((fc (simple-condition-format-control c))
782             (args (simple-condition-format-arguments c)))
783         (and
784          (stringp (apply #'format nil fc args))
785          t))))
786
787(defun frob-simple-error (c expected-fmt &rest expected-args)
788  (and (typep c 'simple-error)
789       (apply #'frob-simple-condition c expected-fmt expected-args)))
790
791(defun frob-simple-warning (c expected-fmt &rest expected-args)
792  (and (typep c 'simple-warning)
793       (apply #'frob-simple-condition c expected-fmt expected-args)))
794
795(defparameter *array-element-types*
796  '(t (integer 0 0)
797      bit (unsigned-byte 8) (unsigned-byte 16)
798      (unsigned-byte 32) float short-float
799      single-float double-float long-float
800      nil character base-char symbol boolean null))
801
802(defun collect-properties (plist prop)
803  "Collect all the properties in plist for a property prop."
804  (loop for e on plist by #'cddr
805        when (eql (car e) prop)
806        collect (cadr e)))
807
808(defmacro def-macro-test (test-name macro-form)
809  (let ((macro-name (car macro-form)))
810    (assert (symbolp macro-name))
811    `(deftest ,test-name
812       (values
813        (signals-error (funcall (macro-function ',macro-name))
814                       program-error)
815        (signals-error (funcall (macro-function ',macro-name)
816                                ',macro-form)
817                       program-error)
818        (signals-error (funcall (macro-function ',macro-name)
819                                ',macro-form nil nil)
820                       program-error))
821       t t t)))
822
823(defun typep* (element type)
824  (not (not (typep element type))))
825
826(defun applyf (fn &rest args)
827  (etypecase fn
828    (symbol
829     #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args))))
830    (function
831     #'(lambda (&rest more-args) (apply (the function fn) (append args more-args))))))
832
833(defun slot-boundp* (object slot)
834  (notnot (slot-boundp object slot)))
835
836(defun slot-exists-p* (object slot)
837  (notnot (slot-exists-p object slot)))
838
839(defun map-slot-boundp* (c slots)
840  (mapcar (applyf #'slot-boundp c) slots))
841
842(defun map-slot-exists-p* (c slots)
843  (mapcar (applyf #'slot-exists-p* c) slots))
844
845(defun map-slot-value (c slots)
846  (mapcar (applyf #'slot-value c) slots))
847
848(defun map-typep* (object types)
849  (mapcar (applyf #'typep* object) types))
850
851(defun slot-value-or-nil (object slot-name)
852  (and (slot-exists-p object slot-name)
853       (slot-boundp object slot-name)
854       (slot-value object slot-name)))
855
856(defun is-noncontiguous-sublist-of (list1 list2)
857  (loop
858   for x in list1
859   do (loop
860       when (null list2) do (return-from is-noncontiguous-sublist-of nil)
861       when (eql x (pop list2)) do (return))
862   finally (return t)))
863
864;;; This defines a new metaclass to allow us to get around
865;;; the restriction in section 11.1.2.1.2, bullet 19 in some
866;;; object system tests
867
868;;; (when (typep (find-class 'standard-class) 'standard-class)
869;;;  (defclass substandard-class (standard-class) ())
870;;;  (defparameter *can-define-metaclasses* t))
871
872;;; Macro for testing that something is undefined but 'harmless'
873
874(defmacro defharmless (name form)
875  `(deftest ,name
876     (block done
877       (let ((*debugger-hook* #'(lambda (&rest args)
878                                  (declare (ignore args))
879                                  (return-from done :good))))
880         (handler-case
881          (unwind-protect (eval ',form) (return-from done :good))
882          (condition () :good))))
883     :good))
884
885(defun rational-safely (x)
886  "Rational a floating point number, making sure the rational
887   number isn't 'too big'.  This is important in implementations such
888   as clisp where the floating bounds can be very large."
889  (assert (floatp x))
890  (multiple-value-bind (significand exponent sign)
891      (integer-decode-float x)
892    (let ((limit 1000)
893          (radix (float-radix x)))
894      (cond
895       ((< exponent (- limit))
896        (* significand (expt radix (- limit)) sign))
897       ((> exponent limit)
898        (* significand (expt radix limit) sign))
899       (t (rational x))))))
900
901(declaim (special *similarity-list*))
902
903(defun is-similar (x y)
904  (let ((*similarity-list* nil))
905    (is-similar* x y)))
906
907(defgeneric is-similar* (x y))
908
909(defmethod is-similar* ((x number) (y number))
910  (and (eq (class-of x) (class-of y))
911       (= x y)
912       t))
913
914(defmethod is-similar* ((x character) (y character))
915  (and (char= x y) t))
916
917(defmethod is-similar* ((x symbol) (y symbol))
918  (if (null (symbol-package x))
919      (and (null (symbol-package y))
920           (is-similar* (symbol-name x) (symbol-name y)))
921    ;; I think the requirements for interned symbols in
922    ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp
923    (eq x y))
924  t)
925
926(defmethod is-similar* ((x random-state) (y random-state))
927  (let ((copy-of-x (make-random-state x))
928        (copy-of-y (make-random-state y))
929        (bound (1- (ash 1 24))))
930    (and
931     ;; Try 50 values, and assume the random state are the same
932     ;; if all the values are the same.  Assuming the RNG is not
933     ;; very pathological, this should be acceptable.
934     (loop repeat 50
935           always (eql (random bound copy-of-x)
936                       (random bound copy-of-y)))
937     t)))
938
939(defmethod is-similar* ((x cons) (y cons))
940  (or (and (eq x y) t)
941      (and (loop for (x2 . y2) in *similarity-list*
942                 thereis (and (eq x x2) (eq y y2)))
943           t)
944      (let ((*similarity-list*
945             (cons (cons x y) *similarity-list*)))
946        (and (is-similar* (car x) (car y))
947             ;; If this causes stack problems,
948             ;; convert to a loop
949             (is-similar* (cdr x) (cdr y))))))
950
951(defmethod is-similar* ((x vector) (y vector))
952  (or (and (eq x y) t)
953      (and
954       (or (not (typep x 'simple-array))
955           (typep x 'simple-array))
956       (= (length x) (length y))
957       (is-similar* (array-element-type x)
958                    (array-element-type y))
959       (loop for i below (length x)
960             always (is-similar* (aref x i) (aref y i)))
961       t)))
962
963(defmethod is-similar* ((x array) (y array))
964  (or (and (eq x y) t)
965      (and
966       (or (not (typep x 'simple-array))
967           (typep x 'simple-array))
968       (= (array-rank x) (array-rank y))
969       (equal (array-dimensions x) (array-dimensions y))
970       (is-similar* (array-element-type x)
971                    (array-element-type y))
972       (let ((*similarity-list*
973              (cons (cons x y) *similarity-list*)))
974         (loop for i below (array-total-size x)
975               always (is-similar* (row-major-aref x i)
976                                   (row-major-aref y i))))
977       t)))
978
979(defmethod is-similar* ((x hash-table) (y hash-table))
980  ;; FIXME  Add similarity check for hash tables
981  (error "Sorry, we're not computing this yet."))
982
983(defmethod is-similar* ((x pathname) (y pathname))
984  (and
985   (is-similar* (pathname-host x) (pathname-host y))
986   (is-similar* (pathname-device x) (pathname-device y))
987   (is-similar* (pathname-directory x) (pathname-directory y))
988   (is-similar* (pathname-name x) (pathname-name y))
989   (is-similar* (pathname-type x) (pathname-type y))
990   (is-similar* (pathname-version x) (pathname-version y))
991   t))
992
993(defmethod is-similar* ((x t) (y t))
994  (and (eql x y) t))
995
996(defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*)
997                                                  *print-pprint-dispatch*
998                                                nil))
999
1000(defmacro my-with-standard-io-syntax (&body body)
1001  `(let ((*package* (find-package "COMMON-LISP-USER"))
1002         (*print-array* t)
1003         (*print-base* 10)
1004         (*print-case* :upcase)
1005         (*print-circle* nil)
1006         (*print-escape* t)
1007         (*print-gensym* t)
1008         (*print-length* nil)
1009         (*print-level* nil)
1010         (*print-lines* nil)
1011         (*print-miser-width* nil)
1012         (*print-pprint-dispatch* *initial-print-pprint-dispatch*)
1013         (*print-pretty* nil)
1014         (*print-radix* nil)
1015         (*print-readably* t)
1016         (*print-right-margin* nil)
1017         (*read-base* 10)
1018         (*read-default-float-format* 'single-float)
1019         (*read-eval* t)
1020         (*read-suppress* nil)
1021         (*readtable* (copy-readtable nil)))
1022     ,@body))
1023
1024;;; Function to produce a non-simple string
1025
1026(defun make-special-string (string &key fill adjust displace base)
1027  (let* ((len (length string))
1028         (len2 (if fill (+ len 4) len))
1029         (etype (if base 'base-char 'character)))
1030    (if displace
1031        (let ((s0 (make-array (+ len2 5)
1032                              :initial-contents
1033                              (concatenate 'string
1034                                           (make-string 2 :initial-element #\X)
1035                                           string
1036                                           (make-string (if fill 7 3)
1037                                                        :initial-element #\Y))
1038                              :element-type etype)))
1039          (make-array len2 :element-type etype
1040                      :adjustable adjust
1041                      :fill-pointer (if fill len nil)
1042                      :displaced-to s0
1043                      :displaced-index-offset 2))
1044      (make-array len2 :element-type etype
1045                  :initial-contents
1046                  (if fill (concatenate 'string string "ZZZZ") string)
1047                  :fill-pointer (if fill len nil)
1048                  :adjustable adjust))))
1049
1050(defmacro do-special-strings ((var string-form &optional ret-form) &body forms)
1051  (let ((string (gensym))
1052        (fill (gensym "FILL"))
1053        (adjust (gensym "ADJUST"))
1054        (base (gensym "BASE"))
1055        (displace (gensym "DISPLACE")))
1056    `(let ((,string ,string-form))
1057       (dolist (,fill '(nil t) ,ret-form)
1058         (dolist (,adjust '(nil t))
1059           (dolist (,base '(nil t))
1060             (dolist (,displace '(nil t))
1061               (let ((,var (make-special-string
1062                            ,string
1063                            :fill ,fill :adjust ,adjust
1064                            :base ,base :displace ,displace)))
1065                 ,@forms))))))))
1066
1067(defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer))
1068  (let* ((len (length contents))
1069         (min (reduce #'min contents))
1070         (max (reduce #'max contents))
1071         (len2 (if fill (+ len 4) len)))
1072    (unless (and (typep min etype)
1073                 (typep max etype))
1074      (setq etype `(integer ,min ,max)))
1075    (if displace
1076        (let ((s0 (make-array (+ len2 5)
1077                              :initial-contents
1078                              (concatenate 'list
1079                                           (make-list 2 :initial-element
1080                                                      (if (typep 0 etype) 0 min))
1081                                           contents
1082                                           (make-list (if fill 7 3)
1083                                                      :initial-element
1084                                                      (if (typep 1 etype) 1 max)))
1085                              :element-type etype)))
1086          (make-array len2 :element-type etype
1087                      :adjustable adjust
1088                      :fill-pointer (if fill len nil)
1089                      :displaced-to s0
1090                      :displaced-index-offset 2))
1091      (make-array len2 :element-type etype
1092                  :initial-contents
1093                  (if fill (concatenate 'list
1094                                        contents
1095                                        (make-list 4 :initial-element
1096                                                   (if (typep 2 etype) 2 (floor (+ min max) 2))))
1097                    contents)
1098                  :fill-pointer (if fill len nil)
1099                  :adjustable adjust))))
1100
1101(defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms)
1102  (let ((vector (gensym))
1103        (fill (gensym "FILL"))
1104        (adjust (gensym "ADJUST"))
1105        (etype (gensym "ETYPE"))
1106        (displace (gensym "DISPLACE")))
1107    `(let ((,vector ,vec-form))
1108       (dolist (,fill '(nil t) ,ret-form)
1109         (dolist (,adjust '(nil t))
1110           (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i))
1111                                     (loop for i from 2 to 32 collect `(signed-byte ,i))
1112                                     '(integer)))
1113             (dolist (,displace '(nil t))
1114               (let ((,var (make-special-integer-vector
1115                            ,vector
1116                            :fill ,fill :adjust ,adjust
1117                            :etype ,etype :displace ,displace)))
1118                 ,@forms))))))))
1119
1120;;; Return T if arg X is a string designator in this implementation
1121
1122(defun string-designator-p (x)
1123  (handler-case
1124   (progn (string x) t)
1125   (error nil)))
1126
1127;;; Approximate comparison of numbers
1128#|
1129(defun approx= (x y)
1130  (let ((eps 1.0d-4))
1131    (<= (abs (- x y))
1132       (* eps (max (abs x) (abs y))))))
1133|#
1134
1135;;; Approximate equality function
1136(defun approx= (x y &optional (eps (epsilon x)))
1137  (<= (abs (/ (- x y) (max (abs x) 1))) eps))
1138
1139(defun epsilon (number)
1140  (etypecase number
1141    (complex (* 2 (epsilon (realpart number)))) ;; crude
1142    (short-float short-float-epsilon)
1143    (single-float single-float-epsilon)
1144    (double-float double-float-epsilon)
1145    (long-float long-float-epsilon)
1146    (rational 0)))
1147
1148(defun negative-epsilon (number)
1149  (etypecase number
1150    (complex (* 2 (negative-epsilon (realpart number)))) ;; crude
1151    (short-float short-float-negative-epsilon)
1152    (single-float single-float-negative-epsilon)
1153    (double-float double-float-negative-epsilon)
1154    (long-float long-float-negative-epsilon)
1155    (rational 0)))
1156
1157(defun sequencep (x) (typep x 'sequence))
1158
1159(defun typef (type) #'(lambda (x) (typep x type)))
1160
1161(defun package-designator-p (x)
1162  "TRUE if x could be a package designator.  The package need not
1163   actually exist."
1164  (or (packagep x)
1165      (handler-case (and (locally (declare (optimize safety))
1166                                  (string x))
1167                         t)
1168                    (type-error () nil))))
1169
1170(defmacro def-fold-test (name form)
1171  "Create a test that FORM, which should produce a fresh value,
1172   does not improperly introduce sharing during constant folding."
1173  `(deftest ,name
1174     (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0)
1175                                      (compilation-speed 0) (debug 0)))
1176               ,form))
1177       (eq (%f) (%f)))
1178     nil))
1179
1180;;; Macro used in tests of environments in system macros
1181;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP
1182;;; was being called in some system macros without the proper
1183;;; environment argument
1184
1185(defmacro expand-in-current-env (macro-form &environment env)
1186  (macroexpand macro-form env))
Note: See TracBrowser for help on using the repository browser.