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