Skip to content
Snippets Groups Projects
Commit c6fa246e authored by pfdietz's avatar pfdietz
Browse files

Style, indentation and comment changes.

parent 40b05dcb
No related branches found
No related tags found
No related merge requests found
...@@ -8,6 +8,9 @@ ...@@ -8,6 +8,9 @@
(declaim (optimize (safety 3))) (declaim (optimize (safety 3)))
;;; Comparison functions that are like various builtins,
;;; but are guaranteed to return T for true.
(defun eqt (x y) (defun eqt (x y)
"Like EQ, but guaranteed to return T for true." "Like EQ, but guaranteed to return T for true."
(if (eq x y) t nil)) (if (eq x y) t nil))
...@@ -28,6 +31,9 @@ ...@@ -28,6 +31,9 @@
"Like =, but guaranteed to return T for true." "Like =, but guaranteed to return T for true."
(if (apply #'= x args) t nil)) (if (apply #'= x args) t nil))
;;; A function for coercing truth values to BOOLEAN
(defun notnot (x) (not (not x))) (defun notnot (x) (not (not x)))
(defun make-int-list (n) (defun make-int-list (n)
...@@ -38,6 +44,9 @@ ...@@ -38,6 +44,9 @@
(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))
a)) a))
;;; Return true if A1 and A2 are arrays with the same rank
;;; and dimensions whose elements are EQUAL
(defun equal-array (a1 a2) (defun equal-array (a1 a2)
(and (typep a1 'array) (and (typep a1 'array)
(typep a2 'array) (typep a2 'array)
...@@ -56,13 +65,14 @@ ...@@ -56,13 +65,14 @@
always (equal (row-major-aref a1 i) always (equal (row-major-aref a1 i)
(row-major-aref a2 i)))))))))) (row-major-aref a2 i))))))))))
;;; *universe* is defined elsewhere -- it is a list of various
;;; lisp objects used when stimulating things in various tests.
(declaim (special *universe*)) (declaim (special *universe*))
(defun check-type-predicate (P TYPE) (defun check-type-predicate (P TYPE)
"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))
by applying both to all elements of *UNIVERSE*. Print message by applying both to all elements of *UNIVERSE*. Print message
when a mismatch is found, and return number of mistakes." when a mismatch is found, and return number of mistakes."
(loop (loop
for x in *universe* count for x in *universe* count
(block failed (block failed
...@@ -193,8 +203,8 @@ the condition to go uncaught if it cannot be classified." ...@@ -193,8 +203,8 @@ the condition to go uncaught if it cannot be classified."
(defun subtypep* (obj type) (defun subtypep* (obj type)
(multiple-value-bind (result good) (multiple-value-bind (result good)
(subtypep obj type) (subtypep obj type)
(values (not (not result)) (values (notnot result)
(not (not good))))) (notnot good))))
;;; (eval-when (load eval compile) ;;; (eval-when (load eval compile)
;;; (unless (fboundp 'complement) ;;; (unless (fboundp 'complement)
...@@ -206,10 +216,10 @@ the condition to go uncaught if it cannot be classified." ...@@ -206,10 +216,10 @@ the condition to go uncaught if it cannot be classified."
#'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x))) #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x)))
(defun evendigitp (c) (defun evendigitp (c)
(not (not (find c "02468")))) (notnot (find c "02468")))
(defun odddigitp (c) (defun odddigitp (c)
(not (not (find c "13579")))) (notnot (find c "13579")))
(defun nextdigit (c) (defun nextdigit (c)
(cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))
...@@ -335,6 +345,7 @@ the condition to go uncaught if it cannot be classified." ...@@ -335,6 +345,7 @@ the condition to go uncaught if it cannot be classified."
(defun make-displaced-array (n displacement) (defun make-displaced-array (n displacement)
(make-array n :displaced-to *displaced* (make-array n :displaced-to *displaced*
:displaced-index-offset displacement)) :displaced-index-offset displacement))
;;; used in fill.lsp ;;; used in fill.lsp
...@@ -366,16 +377,15 @@ the condition to go uncaught if it cannot be classified." ...@@ -366,16 +377,15 @@ the condition to go uncaught if it cannot be classified."
(defun types-6-body () (defun types-6-body ()
(loop (loop
for p in *subtype-table* count for p in *subtype-table* count
(let ((tp (car p))) (let ((tp (car p)))
(cond (when (and (not (member tp '(sequence cons list t)))
((and (not (member tp '(sequence cons list t))) (not (subtypep* tp 'atom)))
(not (subtypep* tp 'atom))) (format t "~%Problem! Did not find to be an atomic type: ~S" tp)
(format t "~%Problem! Did not find to be an atomic type: ~S" tp) t))))
t)))))
(defvar *type-list* nil) (defvar *type-list* nil)
(defvar *supertype-table* nil) (defvar *supertype-table* nil)
(declaim (special *subtype-table* *universe*)) (declaim (special *subtype-table*))
(defun types-9-body () (defun types-9-body ()
(let ((tp-list (append '(keyword atom list) (let ((tp-list (append '(keyword atom list)
...@@ -428,42 +438,42 @@ the condition to go uncaught if it cannot be classified." ...@@ -428,42 +438,42 @@ the condition to go uncaught if it cannot be classified."
(defun types-9a-body () (defun types-9a-body ()
(cond (cond
((not (and *type-list* *supertype-table*)) ((not (and *type-list* *supertype-table*))
(format nil "Run test type-9 first~%") (format nil "Run test type-9 first~%")
nil) nil)
(t (t
(loop (loop
for tp in *type-list* for tp in *type-list*
sum sum
(let ((sups (gethash tp *supertype-table*))) (let ((sups (gethash tp *supertype-table*)))
(loop (loop
for x in *universe* for x in *universe*
sum sum
(handler-case (handler-case
(cond (cond
((not (typep x tp)) 0) ((not (typep x tp)) 0)
(t (t
(loop (loop
for tp2 in sups for tp2 in sups
count count
(handler-case (handler-case
(and (not (typep x tp2)) (and (not (typep x tp2))
(progn (progn
(format t "Found element of ~S not in ~S: ~S~%" (format t "Found element of ~S not in ~S: ~S~%"
tp tp2 x) tp tp2 x)
t)) t))
(condition (c) (format t "Error ~S occured: ~S~%" (condition (c) (format t "Error ~S occured: ~S~%"
c tp2) c tp2)
t))))) t)))))
(condition (c) (format t "Error ~S occured: ~S~%" c tp) (condition (c) (format t "Error ~S occured: ~S~%" c tp)
1)))))))) 1))))))))
(defun even-size-p (a) (defun even-size-p (a)
(some #'evenp (array-dimensions a))) (some #'evenp (array-dimensions a)))
(defun check-cons-copy (x y) (defun check-cons-copy (x y)
"Check that the tree x is a copy of the tree y, "Check that the tree x is a copy of the tree y,
returning t iff it is." returning t if it is, nil if not."
(cond (cond
((consp x) ((consp x)
(and (consp y) (and (consp y)
...@@ -602,30 +612,30 @@ the condition to go uncaught if it cannot be classified." ...@@ -602,30 +612,30 @@ the condition to go uncaught if it cannot be classified."
(let* ((cal (min 2048 call-arguments-limit)) (let* ((cal (min 2048 call-arguments-limit))
(step (max 1 (floor (/ cal) 64)))) (step (max 1 (floor (/ cal) 64))))
(loop (loop
for n from 0 for n from 0
below cal below cal
by step by step
count count
(not (not
(equal (equal
(apply #'append (loop for i from 1 to n (apply #'append (loop for i from 1 to n
collect '(a))) collect '(a)))
(make-list n :initial-element 'a)))))) (make-list n :initial-element 'a))))))
(defun is-intersection (x y z) (defun is-intersection (x y z)
"Check that z is the intersection of x and y." "Check that z is the intersection of x and y."
(and (and
(every #'(lambda (e) (listp x)
(or (not (member e y)) (listp y)
(member e z))) (listp z)
x) (loop for e in x
(every #'(lambda (e) always (or (not (member e y))
(or (not (member e x)) (member e z)))
(member e z))) (loop for e in y
y) always (or (not (member e x))
(every #'(lambda (e) (member e z)))
(and (member e x) (member e y))) (loop for e in z
z) always (and (member e x) (member e y)))
t)) t))
(defun shuffle (x) (defun shuffle (x)
...@@ -650,14 +660,16 @@ the condition to go uncaught if it cannot be classified." ...@@ -650,14 +660,16 @@ the condition to go uncaught if it cannot be classified."
(defun intersection-12-body (size niters &optional (maxelem (* 2 size))) (defun intersection-12-body (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state))) (let ((state (make-random-state)))
(loop (loop
for i from 1 to niters do for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (let ((x (shuffle (loop for j from 1 to size
(y (shuffle (loop for j from 1 to size collect (random maxelem state))))) collect (random maxelem state))))
(let ((z (intersection x y))) (y (shuffle (loop for j from 1 to size
(let ((is-good (is-intersection x y z))) collect (random maxelem state)))))
(unless is-good (return (values x y z))))))) (let ((z (intersection x y)))
nil)) (let ((is-good (is-intersection x y z)))
(unless is-good (return (values x y z)))))))
nil))
(defun nintersection-with-check (x y &key test) (defun nintersection-with-check (x y &key test)
(let ((ycopy (make-scaffold-copy y))) (let ((ycopy (make-scaffold-copy y)))
...@@ -672,8 +684,10 @@ the condition to go uncaught if it cannot be classified." ...@@ -672,8 +684,10 @@ the condition to go uncaught if it cannot be classified."
(let ((state (make-random-state t))) (let ((state (make-random-state t)))
(loop (loop
for i from 1 to niters do for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (let ((x (shuffle (loop for j from 1 to size
(y (shuffle (loop for j from 1 to size collect (random maxelem state))))) collect (random maxelem state))))
(y (shuffle (loop for j from 1 to size
collect (random maxelem state)))))
(let ((z (nintersection-with-check (copy-list x) y))) (let ((z (nintersection-with-check (copy-list x) y)))
(when (eqt z 'failed) (return (values x y z))) (when (eqt z 'failed) (return (values x y z)))
(let ((is-good (is-intersection x y z))) (let ((is-good (is-intersection x y z)))
...@@ -688,8 +702,7 @@ the condition to go uncaught if it cannot be classified." ...@@ -688,8 +702,7 @@ the condition to go uncaught if it cannot be classified."
(test (union x y :test test)) (test (union x y :test test))
(test-not (union x y :test-not test-not)) (test-not (union x y :test-not test-not))
(t (union x y))))) (t (union x y)))))
(if (if (and (check-scaffold-copy x xcopy)
(and (check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)) (check-scaffold-copy y ycopy))
result result
'failed)))) 'failed))))
...@@ -701,8 +714,7 @@ the condition to go uncaught if it cannot be classified." ...@@ -701,8 +714,7 @@ the condition to go uncaught if it cannot be classified."
(test (union x y :key key :test test)) (test (union x y :key key :test test))
(test-not (union x y :key key :test-not test-not)) (test-not (union x y :key key :test-not test-not))
(t (union x y :key key))))) (t (union x y :key key)))))
(if (if (and (check-scaffold-copy x xcopy)
(and (check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)) (check-scaffold-copy y ycopy))
result result
'failed)))) 'failed))))
...@@ -711,11 +723,9 @@ the condition to go uncaught if it cannot be classified." ...@@ -711,11 +723,9 @@ the condition to go uncaught if it cannot be classified."
(and (listp x) (and (listp x)
(listp y) (listp y)
(listp z) (listp z)
(every #'(lambda (e) (or (member e x) (loop for e in z always (or (member e x) (member e y)))
(member e y))) (loop for e in x always (member e z))
z) (loop for e in y always (member e z))
(every #'(lambda (e) (member e z)) x)
(every #'(lambda (e) (member e z)) y)
t)) t))
(defun do-random-unions (size niters &optional (maxelem (* 2 size))) (defun do-random-unions (size niters &optional (maxelem (* 2 size)))
...@@ -781,27 +791,30 @@ the condition to go uncaught if it cannot be classified." ...@@ -781,27 +791,30 @@ the condition to go uncaught if it cannot be classified."
(defun check-set-difference (x y z &key (key #'identity) (defun check-set-difference (x y z &key (key #'identity)
(test #'eql)) (test #'eql))
(and (and
(not (eqt 'failed z)) ;; (not (eqt 'failed z))
(every #'(lambda (e) (member e x :key key :test test)) z) (listp x)
(every #'(lambda (e) (or (member e y :key key :test test) (listp y)
(member e z :key key :test test))) x) (listp z)
(every #'(lambda (e) (not (member e z :key key :test test))) y) (loop for e in z always (member e x :key key :test test))
(loop for e in x always (or (member e y :key key :test test)
(member e z :key key :test test)))
(loop for e in y never (member e z :key key :test test))
t)) t))
(defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) (defun do-random-set-differences (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state))) (let ((state (make-random-state)))
(loop (loop
for i from 1 to niters do for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (let ((x (shuffle (loop for j from 1 to size collect
(random maxelem state)))) (random maxelem state))))
(y (shuffle (loop for j from 1 to size collect (y (shuffle (loop for j from 1 to size collect
(random maxelem state))))) (random maxelem state)))))
(let ((z (set-difference-with-check x y))) (let ((z (set-difference-with-check x y)))
(let ((is-good (check-set-difference x y z))) (let ((is-good (check-set-difference x y z)))
(unless is-good (return (values x y z))))))) (unless is-good (return (values x y z)))))))
nil)) nil))
(defun nset-difference-with-check (x y &key (key 'no-key) (defun nset-difference-with-check (x y &key (key 'no-key)
test test-not) test test-not)
(setf x (copy-list x)) (setf x (copy-list x))
(setf y (copy-list y)) (setf y (copy-list y))
(apply #'nset-difference (apply #'nset-difference
...@@ -811,29 +824,32 @@ the condition to go uncaught if it cannot be classified." ...@@ -811,29 +824,32 @@ the condition to go uncaught if it cannot be classified."
,@(when test-not `(:test-not ,test-not))))) ,@(when test-not `(:test-not ,test-not)))))
(defun check-nset-difference (x y z &key (key #'identity) (defun check-nset-difference (x y z &key (key #'identity)
(test #'eql)) (test #'eql))
(and (and
(every #'(lambda (e) (member e x :key key :test test)) z) (listp x)
(every #'(lambda (e) (or (member e y :key key :test test) (listp y)
(member e z :key key :test test))) x) (listp z)
(every #'(lambda (e) (not (member e z :key key :test test))) y) (loop for e in z always (member e x :key key :test test))
(loop for e in x always (or (member e y :key key :test test)
(member e z :key key :test test)))
(loop for e in y never (member e z :key key :test test))
t)) t))
(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) (defun do-random-nset-differences (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state))) (let ((state (make-random-state)))
(loop (loop
for i from 1 to niters do for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (let ((x (shuffle (loop for j from 1 to size collect
(random maxelem state)))) (random maxelem state))))
(y (shuffle (loop for j from 1 to size collect (y (shuffle (loop for j from 1 to size collect
(random maxelem state))))) (random maxelem state)))))
(let ((z (nset-difference-with-check x y))) (let ((z (nset-difference-with-check x y)))
(let ((is-good (check-nset-difference x y z))) (let ((is-good (check-nset-difference x y z)))
(unless is-good (return (values x y z))))))) (unless is-good (return (values x y z)))))))
nil)) nil))
(defun set-exclusive-or-with-check (x y &key (key 'no-key) (defun set-exclusive-or-with-check (x y &key (key 'no-key)
test test-not) test test-not)
(setf x (copy-list x)) (setf x (copy-list x))
(setf y (copy-list y)) (setf y (copy-list y))
(let ((xcopy (make-scaffold-copy x)) (let ((xcopy (make-scaffold-copy x))
...@@ -841,8 +857,8 @@ the condition to go uncaught if it cannot be classified." ...@@ -841,8 +857,8 @@ the condition to go uncaught if it cannot be classified."
(let ((result (apply #'set-exclusive-or (let ((result (apply #'set-exclusive-or
x y x y
`(,@(unless (eqt key 'no-key) `(:key ,key)) `(,@(unless (eqt key 'no-key) `(:key ,key))
,@(when test `(:test ,test)) ,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not)))))) ,@(when test-not `(:test-not ,test-not))))))
(cond (cond
((and (check-scaffold-copy x xcopy) ((and (check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)) (check-scaffold-copy y ycopy))
...@@ -851,37 +867,37 @@ the condition to go uncaught if it cannot be classified." ...@@ -851,37 +867,37 @@ the condition to go uncaught if it cannot be classified."
'failed))))) 'failed)))))
(defun check-set-exclusive-or (x y z &key (key #'identity) (defun check-set-exclusive-or (x y z &key (key #'identity)
(test #'eql)) (test #'eql))
(and (and
(not (eqt 'failed z)) ;; (not (eqt 'failed z))
(every #'(lambda (e) (or (member e x :key key :test test) (listp x)
(member e y :key key :test test))) (listp y)
z) (listp z)
(every #'(lambda (e) (if (member e y :key key :test test) (loop for e in z always (or (member e x :key key :test test)
(not (member e z :key key :test test)) (member e y :key key :test test)))
(member e z :key key :test test))) (loop for e in x always (if (member e y :key key :test test)
x) (not (member e z :key key :test test))
(every #'(lambda (e) (if (member e x :key key :test test) (member e z :key key :test test)))
(not (member e z :key key :test test)) (loop for e in y always (if (member e x :key key :test test)
(member e z :key key :test test))) (not (member e z :key key :test test))
y) (member e z :key key :test test)))
t)) t))
(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) (defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state))) (let ((state (make-random-state)))
(loop (loop
for i from 1 to niters do for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (let ((x (shuffle (loop for j from 1 to size collect
(random maxelem state)))) (random maxelem state))))
(y (shuffle (loop for j from 1 to size collect (y (shuffle (loop for j from 1 to size collect
(random maxelem state))))) (random maxelem state)))))
(let ((z (set-exclusive-or-with-check x y))) (let ((z (set-exclusive-or-with-check x y)))
(let ((is-good (check-set-exclusive-or x y z))) (let ((is-good (check-set-exclusive-or x y z)))
(unless is-good (return (values x y z))))))) (unless is-good (return (values x y z)))))))
nil)) nil))
(defun nset-exclusive-or-with-check (x y &key (key 'no-key) (defun nset-exclusive-or-with-check (x y &key (key 'no-key)
test test-not) test test-not)
(setf x (copy-list x)) (setf x (copy-list x))
(setf y (copy-list y)) (setf y (copy-list y))
(apply #'nset-exclusive-or (apply #'nset-exclusive-or
...@@ -893,14 +909,14 @@ the condition to go uncaught if it cannot be classified." ...@@ -893,14 +909,14 @@ the condition to go uncaught if it cannot be classified."
(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state))) (let ((state (make-random-state)))
(loop (loop
for i from 1 to niters do for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (let ((x (shuffle (loop for j from 1 to size collect
(random maxelem state)))) (random maxelem state))))
(y (shuffle (loop for j from 1 to size collect (y (shuffle (loop for j from 1 to size collect
(random maxelem state))))) (random maxelem state)))))
(let ((z (nset-exclusive-or-with-check x y))) (let ((z (nset-exclusive-or-with-check x y)))
(let ((is-good (check-set-exclusive-or x y z))) (let ((is-good (check-set-exclusive-or x y z)))
(unless is-good (return (values x y z))))))) (unless is-good (return (values x y z)))))))
nil)) nil))
(defun subsetp-with-check (x y &key (key 'no-key) test test-not) (defun subsetp-with-check (x y &key (key 'no-key) test test-not)
...@@ -910,8 +926,8 @@ the condition to go uncaught if it cannot be classified." ...@@ -910,8 +926,8 @@ the condition to go uncaught if it cannot be classified."
(apply #'subsetp x y (apply #'subsetp x y
`(,@(unless (eqt key 'no-key) `(,@(unless (eqt key 'no-key)
`(:key ,key)) `(:key ,key))
,@(when test `(:test ,test)) ,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not)))))) ,@(when test-not `(:test-not ,test-not))))))
(cond (cond
((and (check-scaffold-copy x xcopy) ((and (check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)) (check-scaffold-copy y ycopy))
...@@ -919,4 +935,4 @@ the condition to go uncaught if it cannot be classified." ...@@ -919,4 +935,4 @@ the condition to go uncaught if it cannot be classified."
(t 'failed))))) (t 'failed)))))
(defun safe-elt (x n) (defun safe-elt (x n)
(classify-error* (elt x n))) (classify-error* (elt x n)))
\ No newline at end of file
...@@ -35,8 +35,8 @@ ...@@ -35,8 +35,8 @@
(cond (cond
((null args) t) ((null args) t)
((car args) ((car args)
(every #'identity (cdr args))) (loop for e in (cdr args) always e))
(t (every #'not (cdr args))))) (t (loop for e in (cdr args) never e))))
;;; From character.lsp ;;; From character.lsp
(defun char-type-error-check (fn) (defun char-type-error-check (fn)
...@@ -86,7 +86,7 @@ ...@@ -86,7 +86,7 @@
(loop for x in *universe* (loop for x in *universe*
always (let ((p (characterp x)) always (let ((p (characterp x))
(q (typep x 'character))) (q (typep x 'character)))
(if p (not (not q)) (not q))))) (if p (notnot q) (not q)))))
(defun alphanumericp.4.body () (defun alphanumericp.4.body ()
(loop for x in *universe* (loop for x in *universe*
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment