ansi-aux.lsp 28.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Mar 28 17:10:18 1998
;;;; Contains: Aux. functions for CL-TEST

(in-package :cl-test)

(declaim (optimize (safety 3)))

10
11
12
13
;;; A function for coercing truth values to BOOLEAN

(defun notnot (x) (not (not x)))

14
(defmacro notnot-mv (form)
15
  `(notnot-mv-fn (multiple-value-list ,form)))
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
(defun notnot-mv-fn (results)
  (if (null results)
      (values)
    (apply #'values
	   (not (not (first results)))
	   (rest results))))

(defmacro not-mv (form)
  `(not-mv-fn (multiple-value-list ,form)))

(defun not-mv-fn (results)
  (if (null results)
      (values)
    (apply #'values
	   (not (first results))
	   (rest results))))

34
35
36
37
38
39
40
(declaim (ftype (function (t) function) to-function))

(defun to-function (fn)
  (etypecase fn
    (function fn)
    (symbol (symbol-function fn))
    ((cons (eql setf) symbol) (fdefinition fn))))    
41
42
43
44

;;; Macro to check that a function is returning a specified number of values
;;; (defaults to 1)
(defmacro check-values (form &optional (num 1))
45
46
  (let ((v (gensym))
	(n (gensym)))
47
   `(let ((,v (multiple-value-list ,form))
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
	  (,n ,num))
      (check-values-length ,v ,n ',form)
      (car ,v))))

(defun check-values-length (results expected-number form)
  (declare (type fixnum expected-number))
  (let ((n expected-number))
    (declare (type fixnum n))
    (dolist (e results)
      (declare (ignore e))
      (decf n))
    (unless (= n 0)
      (error "Expected ~A results from ~A, got ~A results instead.~%~
Results: ~A~%" expected-number form n results))))

;;; Do multiple-value-bind, but check # of arguments
(defmacro multiple-value-bind* ((&rest vars) form &body body)
  (let ((len (length vars))
	(v (gensym)))
    `(let ((,v (multiple-value-list ,form)))
       (check-values-length ,v ,len ',form)
       (destructuring-bind ,vars ,v ,@body))))
  
71
72
73
;;; Comparison functions that are like various builtins,
;;; but are guaranteed to return T for true.

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
79
(defun eqlt (x y)
  "Like EQL, but guaranteed to return T for true."
80
  (apply #'values (mapcar #'notnot (multiple-value-list (eql x y)))))
81
82
83

(defun equalt (x y)
  "Like EQUAL, but guaranteed to return T for true."
84
  (apply #'values (mapcar #'notnot (multiple-value-list (equal x y)))))
85
86
87

(defun equalpt (x y)
  "Like EQUALP, but guaranteed to return T for true."
88
  (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y)))))
89

pfdietz's avatar
pfdietz committed
90
91
92
(defun string=t (x y)
  (notnot-mv (string= x y)))

93
94
(defun =t (x &rest args)
  "Like =, but guaranteed to return T for true."
95
  (apply #'values (mapcar #'notnot (multiple-value-list (apply #'=  x args)))))
96

97
(defun make-int-list (n)
98
  (loop for i from 0 below n collect i))
99

100
(defun make-int-array (n &optional (fn #'make-array))
101
102
103
104
105
  (when (symbolp fn)
    (assert (fboundp fn))
    (setf fn (symbol-function (the symbol fn))))
  (let ((a (funcall (the function fn) n)))
    (declare (type (array * *) a))
106
    (loop for i from 0 below n do (setf (aref a i) i))
107
108
    a))

109
110
111
;;; Return true if A1 and A2 are arrays with the same rank
;;; and dimensions whose elements are EQUAL

112
113
114
115
(defun equal-array (a1 a2)
  (and (typep a1 'array)
       (typep a2 'array)
       (= (array-rank a1) (array-rank a2))
116
       (if (= (array-rank a1) 0)
117
	   (equal (regression-test::my-aref a1) (regression-test::my-aref a2))
118
119
	 (let ((ad (array-dimensions a1)))
	   (and (equal ad (array-dimensions a2))
120
121
122
123
124
125
		(locally
		 (declare (type (array * *) a1 a2))
		 (if (= (array-rank a1) 1)
		     (let ((as (first ad)))
		       (loop
			for i from 0 below as
126
127
			always (equal (regression-test::my-aref a1 i)
				      (regression-test::my-aref a2 i))))
128
129
130
131
		   (let ((as (array-total-size a1)))
		     (and (= as (array-total-size a2))
			  (loop
			   for i from 0 below as
132
133
134
135
136
			   always
			   (equal
			    (regression-test::my-row-major-aref a1 i)
			    (regression-test::my-row-major-aref a2 i))
			   ))))))))))
137

138
139
;;; *universe* is defined elsewhere -- it is a list of various
;;; lisp objects used when stimulating things in various tests.
140
141
(declaim (special *universe*))

pfdietz's avatar
pfdietz committed
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
;;; The function EMPIRICAL-SUBTYPEP checks two types
;;; for subtypeness, first using SUBTYPEP*, then (if that
;;; fails) empirically against all the elements of *universe*,
;;; checking if all that are in the first are also in the second.
;;; Return T if this is the case, NIL otherwise.  This will
;;; always return T if type1 is truly a subtype of type2,
;;; but may return T even if this is not the case.

(defun empirical-subtypep (type1 type2)
  (multiple-value-bind (sub good)
      (subtypep* type1 type2)
    (if good
	sub
      (loop for e in *universe*
	    always (or (not (typep e type1)) (typep e type2))))))

158
159
160
161
(defun check-type-predicate (P TYPE)
  "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
   by applying both to all elements of *UNIVERSE*.  Print message
   when a mismatch is found, and return number of mistakes."
162
163
164
165
166
167

  (when (symbolp p)
    (assert (fboundp p))
    (setf p (symbol-function p)))
  (assert (typep p 'function))
  
168
169
170
171
  (loop
      for x in *universe* count
	(block failed
	  (let ((p1 (handler-case
172
			(normally (funcall (the function p) x))
173
174
175
176
		      (error () (format t "(FUNCALL ~S ~S) failed~%"
					P x)
			(return-from failed t))))
		(p2 (handler-case
177
			(normally (typep x TYPE))
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
		      (error () (format t "(TYPEP ~S '~S) failed~%"
					x TYPE)
			(return-from failed t)))))
	      (when (or (and p1 (not p2))
			(and (not p1) p2))
		(format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%"
			P x p1 x TYPE p2)
		t)))))

(declaim (special *catch-error-type*))

(defun catch-continue-debugger-hook (condition dbh)
  "Function that when used as *debugger-hook*, causes
   continuable errors to be continued without user intervention."
  (declare (ignore dbh))
  (let ((r (find-restart 'continue condition)))
    (cond
     ((and *catch-error-type*
	   (not (typep condition *catch-error-type*)))
      (format t "Condition ~S is not a ~A~%" condition *catch-error-type*)
      (cond (r (format t "Its continue restart is ~S~%" r))
	    (t (format t "It has no continue restart~%")))
      (throw 'continue-failed nil))
     (r (invoke-restart r))
     (t (throw 'continue-failed nil)))))

#|
(defun safe (fn &rest args)
  "Apply fn to args, trapping errors.  Convert type-errors to the
   symbol type-error."
  (declare (optimize (safety 3)))
  (handler-case
   (apply fn args)
   (type-error () 'type-error)
   (error (c) c)))
|#

pfdietz's avatar
pfdietz committed
215
;;; Use the next macro in place of SAFE
216
217
218
219
220
221

(defmacro catch-type-error (form)
"Evaluate form in safe mode, returning its value if there is no error.
If an error does occur, return type-error on TYPE-ERRORs, or the error
condition itself on other errors."
`(locally (declare (optimize (safety 3)))
222
  (handler-case (normally ,form)
223
224
225
     (type-error () 'type-error)
     (error (c) c))))

226
(defmacro classify-error* (form)
pfdietz's avatar
pfdietz committed
227
228
229
230
"Evaluate form in safe mode, returning its value if there is no error.
If an error does occur, return a symbol classify the error, or allow
the condition to go uncaught if it cannot be classified."
`(locally (declare (optimize (safety 3)))
231
  (handler-case (normally ,form)
232
     (undefined-function () 'undefined-function)
pfdietz's avatar
pfdietz committed
233
     (program-error () 'program-error)
234
     (package-error () 'package-error)
235
236
     (type-error    () 'type-error)
     (control-error () 'control-error)
237
     (parse-error   () 'parse-error)
pfdietz's avatar
pfdietz committed
238
239
240
241
     (stream-error  () 'stream-error)
     (reader-error  () 'reader-error)
     (file-error    () 'file-error)
     (cell-error    () 'cell-error)
242
     (division-by-zero () 'division-by-zero)
pfdietz's avatar
pfdietz committed
243
244
     (floating-point-overflow () 'floating-point-overflow)
     (floating-point-underflow () 'floating-point-underflow)
pfdietz's avatar
pfdietz committed
245
     (arithmetic-error () 'arithmetic-error)
246
     (error         () 'error)
247
  )))
pfdietz's avatar
pfdietz committed
248

pfdietz's avatar
pfdietz committed
249
(defun classify-error** (form)
250
251
  (handler-bind ((warning #'(lambda (c) (declare (ignore c))
			      (muffle-warning))))
252
		(proclaim '(optimize (safety 3)))
253
		(classify-error*
254
		 (if regression-test::*compile-tests*
255
256
257
258
		     (funcall (compile nil `(lambda ()
					      (declare (optimize (safety 3)))
					      ,form)))
		     (eval form))
259
		 )))
pfdietz's avatar
pfdietz committed
260

261
(defmacro classify-error (form)
262
  `(classify-error** ',form))
263

264
265
266
;;; The above is badly designed, since it fails when some signals
;;; may be in more than one class/

267
(defmacro signals-error (form error-name &key (safety 3))
268
269
270
271
272
  `(handler-bind
    ((warning #'(lambda (c) (declare (ignore c))
			      (muffle-warning))))
    (proclaim '(optimize (safety 3)))
    (handler-case
pfdietz's avatar
pfdietz committed
273
     (apply #'values
274
275
276
	    nil
	    (multiple-value-list
	     (if regression-test::*compile-tests*
pfdietz's avatar
pfdietz committed
277
		 (funcall (compile nil '(lambda ()
278
					  (declare (optimize (safety ,safety)))
279
					  ,form)))
pfdietz's avatar
pfdietz committed
280
	       (eval ',form))))
281
282
     (,error-name (c) (printable-p c)))))

283
284
285
286
287
(defmacro signals-error-always (form error-name)
  `(values
    (signals-error ,form ,error-name)
    (signals-error ,form ,error-name :safety 0)))

288
289
290
291
292
293
294
295
(defun printable-p (obj)
  "Returns T iff obj can be printed to a string."
  (with-standard-io-syntax
   (let ((*print-readably* nil)
	 (*print-escape* nil))
     (declare (optimize safety))
     (handler-case (and (stringp (write-to-string obj)) t)
		   (condition (c) (declare (ignore c)) nil)))))
296

pfdietz's avatar
pfdietz committed
297
;;;
298
299
;;; The function SUBTYPEP should return two generalized booleans.
;;; This auxiliary function returns booleans instead
pfdietz's avatar
pfdietz committed
300
301
;;; (which makes it easier to write tests).
;;;
302
(defun subtypep* (type1 type2)
303
304
  (apply #'values
	 (mapcar #'notnot
305
306
307
308
309
310
311
312
313
314
315
316
317
		 (multiple-value-list (subtypep type1 type2)))))

(defun subtypep*-or-fail (type1 type2)
  (let ((results (multiple-value-list (subtypep type1 type2))))
    (and (= (length results) 2)
	 (or (not (second results))
	     (notnot (first results))))))

(defun subtypep*-not-or-fail (type1 type2)
  (let ((results (multiple-value-list (subtypep type1 type2))))
    (and (= (length results) 2)
	 (or (not (second results))
	     (not (first results))))))
318

319
320
321
322
;;; (eval-when (load eval compile)
;;;   (unless (fboundp 'complement)
;;;     (defun complement (fn)
;;;       #'(lambda (&rest args) (not (apply fn args))))))
323

324
325
326
327

(declaim (ftype (function (&rest function) (values function &optional))
		compose))

328
329
(defun compose (&rest fns)
  (let ((rfns (reverse fns)))
330
331
    #'(lambda (x) (loop for f
			in rfns do (setf x (funcall (the function f) x))) x)))
332
333

(defun evendigitp (c)
334
  (notnot (find c "02468")))
335
336

(defun odddigitp (c)
337
  (notnot (find c "13579")))
338
339
340
341

(defun nextdigit (c)
  (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))

342
343
(defun is-eq-p (x) #'(lambda (y) (eqt x y)))
(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y))))
344

345
346
347
348
349
(defun is-eql-p (x) #'(lambda (y) (eqlt x y)))
(defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y))))

(defun onep (x) (eql x 1))

350
351
352
353
354
355
(defun char-invertcase (c)
  (if (upper-case-p c) (char-downcase c)
    (char-upcase c)))

(defun string-invertcase (s)
  (map 'string #'char-invertcase s))
356

357
358
(defun symbol< (x &rest args)
  (apply #'string< (symbol-name x) (mapcar #'symbol-name args)))
359
360


361
362
363
364
365
366
367
368
369
(defun make-list-expr (args)
  "Build an expression for computing (LIST . args), but that evades
   CALL-ARGUMENTS-LIMIT."
  (if (cddddr args)
      (list 'list*
	    (first args) (second args) (third args) (fourth args)
	    (make-list-expr (cddddr args)))
    (cons 'list args)))  

370
(defparameter +standard-chars+
371
  (coerce
372
  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./
373
 " 'simple-base-string))
374

375
(defparameter
376
377
378
379
380
381
382
383
  +base-chars+ #.(coerce
		  (concatenate 'string
			       "abcdefghijklmnopqrstuvwxyz"
			       "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
			       "0123456789"
			       "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")
		  'simple-base-string))
		  
384

385
(declaim (type simple-base-string +base-chars+))
386

387
(defparameter +num-base-chars+ (length +base-chars+))
388
389
390
391
392
393

(defparameter +alpha-chars+ (subseq +standard-chars+ 0 52))
(defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26))
(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52))
(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62))
(defparameter +digit-chars+ "0123456789")
394
395
396
(defparameter +extended-digit-chars+ (coerce
				      "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
				      'simple-base-string))
397
398

(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+
399
400
	       +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+
	       +standard-chars+))
401

402
(defparameter +code-chars+
403
404
405
  (coerce (loop for i from 0 below 256
		for c = (code-char i)
		when c collect c)
406
407
408
	  'simple-string))

(declaim (type simple-string +code-chars+))
409

410
(defparameter +rev-code-chars+ (reverse +code-chars+))
411
412
413
414
415

;;; Used in checking for continuable errors

(defun has-non-abort-restart (c)
  (throw 'handled
416
	 (if (position 'abort (the list (compute-restarts c))
417
418
419
420
421
422
423
424
425
		       :key #'restart-name :test-not #'eq)
	     'success
	   'fail)))

(defmacro handle-non-abort-restart (&body body)
  `(catch 'handled
     (handler-bind ((error #'has-non-abort-restart))
		   ,@body)))

426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
;;; used in elt.lsp
(defun elt-v-6-body ()
  (let ((x (make-int-list 1000)))
    (let ((a (make-array '(1000) :initial-contents x)))
      (loop
	  for i from 0 to 999 do
	    (unless (eql i (elt a i)) (return nil))
	  finally (return t)))))

(defun make-adj-array (n &key initial-contents)
  (if initial-contents
      (make-array n :adjustable t :initial-contents initial-contents)
    (make-array n :adjustable t)))

;;; used in elt.lsp
(defun elt-adj-array-6-body ()
  (let ((x (make-int-list 1000)))
    (let ((a (make-adj-array '(1000) :initial-contents x)))
      (loop
	  for i from 0 to 999 do
	    (unless (eql i (elt a i)) (return nil))
	  finally (return t)))))

(defparameter *displaced* (make-int-array 100000))

(defun make-displaced-array (n displacement)
  (make-array n :displaced-to *displaced*
453

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
	      :displaced-index-offset displacement))

;;; used in fill.lsp
(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args)
  (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size)
			:initial-contents '(1 2 3 4 5)))
	 (b (apply #'fill a fill-args)))
    (values (eqt a b)
	    (map 'list #'identity a))))

;;; used in fill-strings.lsp
(defun array-string-fill-test-fn (a &rest fill-args)
  (setq a (copy-seq a))
  (let ((b (apply #'fill a fill-args)))
    (values (eqt a b) b)))

;;; From types-and-class.lsp

pfdietz's avatar
pfdietz committed
472
473
474
475
476
477
478
479
(defparameter +float-types+
  '(long-float double-float short-float single-float))

(defparameter *subtype-table*
(let ((table
       '(
	 (null symbol)
	 (symbol t)
480
	 (boolean symbol)
pfdietz's avatar
pfdietz committed
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
	 (standard-object t)
	 (function t)
	 (compiled-function function)
	 (generic-function function)
	 (standard-generic-function generic-function)
	 (class standard-object)
	 (built-in-class class)
	 (structure-class class)
	 (standard-class class)
	 (method standard-object)
	 (standard-method method)
	 (structure-object t)
	 (method-combination t)
	 (condition t)
	 (serious-condition condition)
	 (error serious-condition)
	 (type-error error)
	 (simple-type-error type-error)
	 (simple-condition condition)
	 (simple-type-error simple-condition)
	 (parse-error error)
	 (hash-table t)
	 (cell-error error)
	 (unbound-slot cell-error)
	 (warning condition)
	 (style-warning warning)
	 (storage-condition serious-condition)
	 (simple-warning warning)
	 (simple-warning simple-condition)
	 (keyword symbol)
	 (unbound-variable cell-error)
	 (control-error error)
	 (program-error error)
	 (undefined-function cell-error)
	 (package t)
	 (package-error error)
	 (random-state t)
	 (number t)
	 (real number)
	 (complex number)
	 (float real)
	 (short-float float)
	 (single-float float)
	 (double-float float)
	 (long-float float)
	 (rational real)
	 (integer rational)
	 (ratio rational)
	 (signed-byte integer)
	 (integer signed-byte)
	 (unsigned-byte signed-byte)
	 (bit unsigned-byte)
	 (fixnum integer)
	 (bignum integer)
	 (bit fixnum)
	 (arithmetic-error error)
	 (division-by-zero arithmetic-error)
	 (floating-point-invalid-operation arithmetic-error)
	 (floating-point-inexact arithmetic-error)
	 (floating-point-overflow arithmetic-error)
	 (floating-point-underflow arithmetic-error)
	 (character t)
	 (base-char character)
	 (standard-char base-char)
	 (extended-char character)
	 (sequence t)
	 (list sequence)
	 (null list)
549
	 (null boolean)
pfdietz's avatar
pfdietz committed
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
	 (cons list)
	 (array t)
	 (simple-array array)
	 (vector sequence)
	 (vector array)
	 (string vector)
	 (bit-vector vector)
	 (simple-vector vector)
	 (simple-vector simple-array)
	 (simple-bit-vector bit-vector)
	 (simple-bit-vector simple-array)
	 (base-string string)
	 (simple-string string)
	 (simple-string simple-array)
	 (simple-base-string base-string)
	 (simple-base-string simple-string)
	 (pathname t)
	 (logical-pathname pathname)
	 (file-error error)
	 (stream t)
	 (broadcast-stream stream)
	 (concatenated-stream stream)
	 (echo-stream stream)
	 (file-stream stream)
	 (string-stream stream)
	 (synonym-stream stream)
	 (two-way-stream stream)
	 (stream-error error)
	 (end-of-file stream-error)
	 (print-not-readable error)
	 (readtable t)
	 (reader-error parse-error)
	 (reader-error stream-error)
	 )))
  (when (subtypep* 'character 'base-char)
    (setq table
	  (append
	   '((character base-char)
588
589
590
	     ;; (string base-string)
	     ;; (simple-string simple-base-string)
	     )
pfdietz's avatar
pfdietz committed
591
592
593
594
	   table)))
  
  table))

pfdietz's avatar
pfdietz committed
595
(defparameter *disjoint-types-list*
596
597
598
599
    '(cons symbol array
      number character hash-table function readtable package
      pathname stream random-state condition restart))

pfdietz's avatar
pfdietz committed
600
(defparameter *disjoint-types-list2*
601
602
  `((cons (cons t t) (cons t (cons t t)) (eql (nil)))
    (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *))
pfdietz's avatar
pfdietz committed
603
    (array vector simple-array simple-vector string simple-string
604
605
606
607
608
609
610
611
	   base-string simple-base-string (eql #()))
    (character base-char standard-char (eql #\a)
	       ,@(if (subtypep 'character 'base-char) nil
		   (list 'extended-char)))
    (function compiled-function generic-function standard-generic-function
	      (eql ,#'car))
    (package (eql ,(find-package "COMMON-LISP")))
    (pathname logical-pathname (eql #p""))
pfdietz's avatar
pfdietz committed
612
613
    (stream broadcast-stream concatenated-stream echo-stream
	    file-stream string-stream synonym-stream two-way-stream)
pfdietz's avatar
pfdietz committed
614
    (number real complex float integer rational ratio fixnum
pfdietz's avatar
pfdietz committed
615
	    bit (integer 0 100) (float 0.0 100.0) (integer 0 *)
616
617
618
619
	    (rational 0 *) (mod 10)
	    (eql 0)
	    ,@(and (not (subtypep 'bignum nil))
		   (list 'bignum)))
pfdietz's avatar
pfdietz committed
620
621
622
623
624
    (random-state)
    ,*condition-types*
    (restart)
    (readtable)))

625
626
627
628
629
630
631
632
633
(defparameter *types-list3*
  (reduce #'append *disjoint-types-list2* :from-end t))

(defun trim-list (list n)
  (let ((len (length list)))
    (if (<= len n) list
      (append (subseq list 0 n)
	      (format nil "And ~A more omitted." (- len n))))))

634
635
636
(defun is-t-or-nil (e)
  (or (eqt e t) (eqt e nil)))

637
638
639
640
(defun is-builtin-class (type)
  (when (symbolp type) (setq type (find-class type nil)))
  (typep type 'built-in-class))

641
642
643
644
645
(defun even-size-p (a)
  (some #'evenp (array-dimensions a)))


(defun safe-elt (x n)
646
  (classify-error* (elt x n)))
pfdietz's avatar
pfdietz committed
647
648

(defmacro defstruct* (&body args)
649
  `(eval-when (:load-toplevel :compile-toplevel :execute)
650
     (handler-case (eval '(defstruct ,@args))
651
		      (serious-condition () nil))))
652
653
654
655
656
657
658
659
660

(defun safely-delete-package (package-designator)
  (let ((package (find-package package-designator)))
    (when package
      (let ((used-by (package-used-by-list package)))
	(dolist (using-package used-by)
	  (unuse-package package using-package)))
      (delete-package package))))

661
#-(or allegro openmcl)
pfdietz's avatar
pfdietz committed
662
663
664
665
666
667
668
(defun delete-all-versions (pathspec)
  "Replace the versions field of the pathname specified by pathspec with
   :wild, and delete all the files this refers to."
  (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec)))
	 (truenames (directory wild-pathname)))
    (mapc #'delete-file truenames)))    

669
670
671
;;; This is a hack to get around an ACL bug; OpenMCL also apparently
;;; needs it
#+(or allegro openmcl)
672
673
674
(defun delete-all-versions (pathspec)
  (when (probe-file pathspec) (delete-file pathspec)))

675
676
(defconstant +fail-count-limit+ 20)

677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
(defun frob-simple-condition (c expected-fmt &rest expected-args)
  "Try out the format control and format arguments of a simple-condition C,
   but make no assumptions about what they print as, only that they
   do print."
  (declare (ignore expected-fmt expected-args))
  (and (typep c 'simple-condition)
       (let ((fc (simple-condition-format-control c))
	     (args (simple-condition-format-arguments c)))
	 (and
	  (stringp (apply #'format nil fc args))
	  t))))

(defun frob-simple-error (c expected-fmt &rest expected-args)
  (and (typep c 'simple-error)
       (apply #'frob-simple-condition c expected-fmt expected-args)))

693
694
695
(defun frob-simple-warning (c expected-fmt &rest expected-args)
  (and (typep c 'simple-warning)
       (apply #'frob-simple-condition c expected-fmt expected-args)))
696
697
698
699
700
701
702

(defparameter *array-element-types*
  '(t (integer 0 0)
      bit (unsigned-byte 8) (unsigned-byte 16)
      (unsigned-byte 32) float short-float
      single-float double-float long-float
      nil character base-char symbol boolean null))
703
704
705
706
707
708

(defun collect-properties (plist prop)
  "Collect all the properties in plist for a property prop."
  (loop for e on plist by #'cddr
	when (eql (car e) prop)
	collect (cadr e)))
709
710
711
712
713
714

(defmacro def-macro-test (test-name macro-form)
  (let ((macro-name (car macro-form)))
    (assert (symbolp macro-name))
    `(deftest ,test-name
       (values
715
716
717
718
719
720
721
722
	(signals-error (funcall (macro-function ',macro-name))
		       program-error)
	(signals-error (funcall (macro-function ',macro-name)
				',macro-form)
		       program-error)
	(signals-error (funcall (macro-function ',macro-name)
				',macro-form nil nil)
		       program-error))
723
724
725
726
727
728
       t t t)))

(defun typep* (element type)
  (not (not (typep element type))))

(defun applyf (fn &rest args)
729
730
731
732
733
  (etypecase fn
    (symbol
     #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args))))
    (function
     #'(lambda (&rest more-args) (apply (the function fn) (append args more-args))))))
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751

(defun slot-boundp* (object slot)
  (notnot (slot-boundp object slot)))

(defun slot-exists-p* (object slot)
  (notnot (slot-exists-p object slot)))

(defun map-slot-boundp* (c slots)
  (mapcar (applyf #'slot-boundp c) slots))

(defun map-slot-exists-p* (c slots)
  (mapcar (applyf #'slot-exists-p* c) slots))

(defun map-slot-value (c slots)
  (mapcar (applyf #'slot-value c) slots))

(defun map-typep* (object types)
  (mapcar (applyf #'typep* object) types))
pfdietz's avatar
pfdietz committed
752
753
754
755

(defun slot-value-or-nil (object slot-name)
  (and (slot-exists-p object slot-name)
       (slot-boundp object slot-name)
756
       (slot-value object slot-name)))
757
758
759
760
761
762
763
764

(defun is-noncontiguous-sublist-of (list1 list2)
  (loop
   for x in list1
   do (loop
       when (null list2) do (return-from is-noncontiguous-sublist-of nil)
       when (eql x (pop list2)) do (return))
   finally (return t)))
765
766
767
768
769
770
771
772

;;; This defines a new metaclass to allow us to get around
;;; the restriction in section 11.1.2.1.2, bullet 19 in some
;;; object system tests

;;; (when (typep (find-class 'standard-class) 'standard-class)
;;;  (defclass substandard-class (standard-class) ())
;;;  (defparameter *can-define-metaclasses* t))
773
774
775
776
777
778
779
780
781
782
783
784
785

;;; Macro for testing that something is undefined but 'harmless'

(defmacro defharmless (name form)
  `(deftest ,name
     (block done
       (let ((*debugger-hook* #'(lambda (&rest args)
				  (declare (ignore args))
				  (return-from done :good))))
	 (handler-case
	  (unwind-protect (eval ',form) (return-from done :good))
	  (condition () :good))))
     :good))
786

787
788
789
790
791
792
793
794
795
796
797
798
799
800
(defun rational-safely (x)
  "Rational a floating point number, making sure the rational
   number isn't 'too big'.  This is important in implementations such
   as clisp where the floating bounds can be very large."
  (assert (floatp x))
  (multiple-value-bind (significand exponent sign)
      (integer-decode-float x)
    (let ((limit 1000)
	  (radix (float-radix x)))
      (cond
       ((< exponent (- limit))
	(* significand (expt radix (- limit)) sign))
       ((> exponent limit)
	(* significand (expt radix limit) sign))
pfdietz's avatar
pfdietz committed
801
802
       (t (rational x))))))

803
804
(defun random-partition* (n p)
  "Partition n into p numbers, each >= 0.  Return list of numbers."
pfdietz's avatar
pfdietz committed
805
806
807
808
809
810
811
812
  (assert (<= 1 p))
  (cond
   ((= p 1) (list n))
   ((= n 0) (make-list p :initial-element 0))
   (t (let* ((r (random p))
	     (n1 (random (1+ n))))
	(cond
	 ((= r 0)
813
	  (cons n1 (random-partition* (- n n1) (1- p))))
pfdietz's avatar
pfdietz committed
814
	 ((= r (1- p))
815
	  (append (random-partition* (- n n1) (1- p)) (list n1)))
pfdietz's avatar
pfdietz committed
816
817
818
	 (t
	  (let* ((n2 (random (1+ (- n n1))))
		 (n3 (- n n1 n2)))
819
	    (append (random-partition* n2 r)
pfdietz's avatar
pfdietz committed
820
		    (list n1)
821
822
823
824
825
826
827
828
		    (random-partition* n3 (- p 1 r))))))))))

(defun random-partition (n p)
  "Partition n into p numbers, each >= 1 (if possible.)"
  (cond
   ((<= n p)
    (make-list p :initial-element 1))
   (t (mapcar #'1+ (random-partition* (- n p) p)))))
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923

(declaim (special *similarity-list*))

(defun is-similar (x y)
  (let ((*similarity-list* nil))
    (is-similar* x y)))

(defgeneric is-similar* (x y))

(defmethod is-similar* ((x number) (y number))
  (and (eq (class-of x) (class-of y))
       (= x y)
       t))

(defmethod is-similar* ((x character) (y character))
  (and (char= x y) t))

(defmethod is-similar* ((x symbol) (y symbol))
  (if (null (symbol-package x))
      (and (null (symbol-package y))
	   (is-similar* (symbol-name x) (symbol-name y)))
    ;; I think the requirements for interned symbols in
    ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp
    (eq x y))
  t)

(defmethod is-similar* ((x random-state) (y random-state))
  (let ((copy-of-x (make-random-state x))
	(copy-of-y (make-random-state y))
	(bound (1- (ash 1 24))))
    (and
     ;; Try 50 values, and assume the random state are the same
     ;; if all the values are the same.  Assuming the RNG is not
     ;; very pathological, this should be acceptable.
     (loop repeat 50
	   always (eql (random bound copy-of-x)
		       (random bound copy-of-y)))
     t)))

(defmethod is-similar* ((x cons) (y cons))
  (or (and (eq x y) t)
      (and (loop for (x2 . y2) in *similarity-list*
		 thereis (and (eq x x2) (eq y y2)))
	   t)
      (let ((*similarity-list*
	     (cons (cons x y) *similarity-list*)))
	(and (is-similar* (car x) (car y))
	     ;; If this causes stack problems,
	     ;; convert to a loop
	     (is-similar* (car x) (car y))))))

(defmethod is-similar* ((x vector) (y vector))
  (or (and (eq x y) t)
      (and
       (or (not (typep x 'simple-array))
	   (typep x 'simple-array))
       (= (length x) (length y))
       (is-similar* (array-element-type x)
		    (array-element-type y))
       (loop for i below (length x)
	     always (is-similar* (aref x i) (aref y i)))
       t)))

(defmethod is-similar* ((x array) (y array))
  (or (and (eq x y) t)
      (and
       (or (not (typep x 'simple-array))
	   (typep x 'simple-array))
       (= (array-rank x) (array-rank y))
       (equal (array-dimensions x) (array-dimensions y))
       (is-similar* (array-element-type x)
		    (array-element-type y))
       (let ((*similarity-list*
	      (cons (cons x y) *similarity-list*)))
	 (loop for i below (array-total-size x)
	       always (is-similar* (row-major-aref x i)
				   (row-major-aref y i))))
       t)))

(defmethod is-similar* ((x hash-table) (y hash-table))
  ;; FIXME  Add similarity check for hash tables
  (error "Sorry, we're not computing this yet."))

(defmethod is-similar* ((x pathname) (y pathname))
  (and
   (is-similar* (pathname-host x) (pathname-host y))
   (is-similar* (pathname-device x) (pathname-device y))
   (is-similar* (pathname-directory x) (pathname-directory y))
   (is-similar* (pathname-name x) (pathname-name y))
   (is-similar* (pathname-type x) (pathname-type y))
   (is-similar* (pathname-version x) (pathname-version y))
   t))

(defmethod is-similar* ((x t) (y t))
  (and (eql x y) t))
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951

(defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*)
						  *print-pprint-dispatch*
						nil))

(defmacro my-with-standard-io-syntax (&body body)
  `(let ((*package* (find-package "COMMON-LISP-USER"))
	 (*print-array* t)
	 (*print-base* 10)
	 (*print-case* :upcase)
	 (*print-circle* nil)
	 (*print-escape* t)
	 (*print-gensym* t)
	 (*print-length* nil)
	 (*print-level* nil)
	 (*print-lines* nil)
	 (*print-miser-width* nil)
	 (*print-pprint-dispatch* *initial-print-pprint-dispatch*)
	 (*print-pretty* nil)
	 (*print-radix* nil)
	 (*print-readably* t)
	 (*print-right-margin* nil)
	 (*read-base* 10)
	 (*read-default-float-format* 'single-float)
	 (*read-eval* t)
	 (*read-suppress* nil)
	 (*readtable* (copy-readtable nil)))
     ,@body))