91 |
(loop for i from 0 below n collect i)) |
(loop for i from 0 below n collect i)) |
92 |
|
|
93 |
(defun make-int-array (n &optional (fn #'make-array)) |
(defun make-int-array (n &optional (fn #'make-array)) |
94 |
(let ((a (funcall fn n))) |
(when (symbolp fn) |
95 |
|
(assert (fboundp fn)) |
96 |
|
(setf fn (symbol-function (the symbol fn)))) |
97 |
|
(let ((a (funcall (the function fn) n))) |
98 |
|
(declare (type (array * *) a)) |
99 |
(loop for i from 0 below n do (setf (aref a i) i)) |
(loop for i from 0 below n do (setf (aref a i) i)) |
100 |
a)) |
a)) |
101 |
|
|
110 |
(equal (aref a1) (aref a2)) |
(equal (aref a1) (aref a2)) |
111 |
(let ((ad (array-dimensions a1))) |
(let ((ad (array-dimensions a1))) |
112 |
(and (equal ad (array-dimensions a2)) |
(and (equal ad (array-dimensions a2)) |
113 |
(if (= (array-rank a1) 1) |
(locally |
114 |
(let ((as (first ad))) |
(declare (type (array * *) a1 a2)) |
115 |
(loop |
(if (= (array-rank a1) 1) |
116 |
for i from 0 below as |
(let ((as (first ad))) |
117 |
always (equal (aref a1 i) (aref a2 i)))) |
(loop |
118 |
(let ((as (array-total-size a1))) |
for i from 0 below as |
119 |
(and (= as (array-total-size a2)) |
always (equal (aref a1 i) (aref a2 i)))) |
120 |
(loop |
(let ((as (array-total-size a1))) |
121 |
for i from 0 below as |
(and (= as (array-total-size a2)) |
122 |
always (equal (row-major-aref a1 i) |
(loop |
123 |
(row-major-aref a2 i))))))))))) |
for i from 0 below as |
124 |
|
always (equal (row-major-aref a1 i) |
125 |
|
(row-major-aref a2 i)))))))))))) |
126 |
|
|
127 |
;;; *universe* is defined elsewhere -- it is a list of various |
;;; *universe* is defined elsewhere -- it is a list of various |
128 |
;;; lisp objects used when stimulating things in various tests. |
;;; lisp objects used when stimulating things in various tests. |
213 |
"Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) |
"Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) |
214 |
by applying both to all elements of *UNIVERSE*. Print message |
by applying both to all elements of *UNIVERSE*. Print message |
215 |
when a mismatch is found, and return number of mistakes." |
when a mismatch is found, and return number of mistakes." |
216 |
|
|
217 |
|
(when (symbolp p) |
218 |
|
(assert (fboundp p)) |
219 |
|
(setf p (symbol-function p))) |
220 |
|
(assert (typep p 'function)) |
221 |
|
|
222 |
(loop |
(loop |
223 |
for x in *universe* count |
for x in *universe* count |
224 |
(block failed |
(block failed |
225 |
(let ((p1 (handler-case |
(let ((p1 (handler-case |
226 |
(funcall P x) |
(funcall (the function p) x) |
227 |
(error () (format t "(FUNCALL ~S ~S) failed~%" |
(error () (format t "(FUNCALL ~S ~S) failed~%" |
228 |
P x) |
P x) |
229 |
(return-from failed t)))) |
(return-from failed t)))) |
388 |
|
|
389 |
(defun compose (&rest fns) |
(defun compose (&rest fns) |
390 |
(let ((rfns (reverse fns))) |
(let ((rfns (reverse fns))) |
391 |
#'(lambda (x) (loop for f of-type function |
#'(lambda (x) (loop for f |
392 |
in rfns do (setf x (funcall f x))) x))) |
in rfns do (setf x (funcall (the function f) x))) x))) |
393 |
|
|
394 |
(defun evendigitp (c) |
(defun evendigitp (c) |
395 |
(notnot (find c "02468"))) |
(notnot (find c "02468"))) |
429 |
(cons 'list args))) |
(cons 'list args))) |
430 |
|
|
431 |
(defparameter +standard-chars+ |
(defparameter +standard-chars+ |
432 |
|
(coerce |
433 |
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ |
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ |
434 |
") |
" 'simple-base-string)) |
435 |
|
|
436 |
(defparameter |
(defparameter |
437 |
+base-chars+ #.(concatenate 'simple-base-string |
+base-chars+ #.(concatenate 'simple-base-string |
449 |
(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) |
(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) |
450 |
(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) |
(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) |
451 |
(defparameter +digit-chars+ "0123456789") |
(defparameter +digit-chars+ "0123456789") |
452 |
(defparameter +extended-digit-chars+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") |
(defparameter +extended-digit-chars+ (coerce |
453 |
|
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" |
454 |
|
'simple-base-string)) |
455 |
|
|
456 |
(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ |
(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ |
457 |
+upper-case-chars+ +alphanumeric-chars+)) |
+upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ |
458 |
|
+standard-chars+)) |
459 |
|
|
460 |
(defparameter +code-chars+ |
(defparameter +code-chars+ |
461 |
(coerce (loop for i from 0 below 256 |
(coerce (loop for i from 0 below 256 |
462 |
for c = (code-char i) |
for c = (code-char i) |
463 |
when c collect c) |
when c collect c) |
464 |
'string)) |
'simple-string)) |
465 |
|
|
466 |
|
(declaim (type simple-string +code-chars+)) |
467 |
|
|
468 |
(defparameter +rev-code-chars+ (reverse +code-chars+)) |
(defparameter +rev-code-chars+ (reverse +code-chars+)) |
469 |
|
|
471 |
|
|
472 |
(defun has-non-abort-restart (c) |
(defun has-non-abort-restart (c) |
473 |
(throw 'handled |
(throw 'handled |
474 |
(if (position 'abort (compute-restarts c) |
(if (position 'abort (the list (compute-restarts c)) |
475 |
:key #'restart-name :test-not #'eq) |
:key #'restart-name :test-not #'eq) |
476 |
'success |
'success |
477 |
'fail))) |
'fail))) |
1274 |
(classify-error* (elt x n))) |
(classify-error* (elt x n))) |
1275 |
|
|
1276 |
(defmacro defstruct* (&body args) |
(defmacro defstruct* (&body args) |
1277 |
`(eval-when (load eval compile) |
`(eval-when #+gcl (load eval compile) |
1278 |
|
#-gcl (:load-toplevel :compile-toplevel :execute) |
1279 |
(handler-case (eval '(defstruct ,@args)) |
(handler-case (eval '(defstruct ,@args)) |
1280 |
(serious-condition () nil)))) |
(serious-condition () nil)))) |
1281 |
|
|
|
|
|
1282 |
(defun sort-package-list (x) |
(defun sort-package-list (x) |
1283 |
(sort (copy-list x) |
(sort (copy-list x) |
1284 |
#'string< |
#'string< |