;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 17:10:18 1998 ;;;; Contains: Aux. functions for CL-TEST (in-package :cl-test) (use-package :rt) (declaim (optimize (safety 3))) (defun make-int-list (n) (loop for i from 0 to (1- n) collect i)) (declaim (special *universe*)) (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." (loop for x in *universe* count (block failed (let ((p1 (handler-case (funcall P x) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case (typep x TYPE) (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))) |# ;; Use the next macro in place of SAFE (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))) (handler-case ,form (type-error () 'type-error) (error (c) c)))) ;; ;; A scaffold is a structure that is used to remember the object ;; identities of the cons cells in a (noncircular) data structure. ;; This lets us check if the data structure has been changed by ;; an operation. ;; (defstruct scaffold node car cdr) (defun make-scaffold-copy (x) "Make a tree that will be used to check if a tree has been changed." (if (consp x) (make-scaffold :node x :car (make-scaffold-copy (car x)) :cdr (make-scaffold-copy (cdr x))) (make-scaffold :node x :car nil :cdr nil))) (defun check-scaffold-copy (x xcopy) "Return t if xcopy were produced from x by make-scaffold-copy, and none of the cons cells in the tree rooted at x have been changed." (and (eq x (scaffold-node xcopy)) (or (not (consp x)) (and (check-scaffold-copy (car x) (scaffold-car xcopy)) (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) ;; ;; The function SUBTYPEP returns two generalized booleans. ;; This auxiliary function returns two booleans instead ;; (which makes it easier to write tests). ;; (defun subtypep* (obj type) (multiple-value-bind (result good) (subtypep obj type) (values (not (not result)) (not (not good))))) (eval-when (load eval compile) (unless (fboundp 'complement) (defun complement (fn) #'(lambda (&rest args) (not (apply fn args)))))) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x))) (defun evendigitp (c) (not (not (find c "02468")))) (defun odddigitp (c) (not (not (find c "13579")))) (defun nextdigit (c) (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) (defun is-eq-p (x) #'(lambda (y) (eq x y))) (defun is-not-eq-p (x) #'(lambda (y) (not (eq x y))))