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.~%~ |
---|
59 | Results: ~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. |
---|
237 | If an error does occur, return type-error on TYPE-ERRORs, or the error |
---|
238 | condition 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. |
---|
246 | If an error does occur, return a symbol classify the error, or allow |
---|
247 | the 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)) |
---|