;-*- 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))) ;;; A function for coercing truth values to BOOLEAN (defun notnot (x) (not (not x))) (defmacro notnot-mv (form) `(notnot-mv-fn (multiple-value-list ,form))) (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)))) (declaim (ftype (function (t) function) to-function)) (defun to-function (fn) (etypecase fn (function fn) (symbol (symbol-function fn)) ((cons (eql setf) (cons symbol null)) (fdefinition fn)))) ;;; Macro to check that a function is returning a specified number of values ;;; (defaults to 1) (defmacro check-values (form &optional (num 1)) (let ((v (gensym)) (n (gensym))) `(let ((,v (multiple-value-list ,form)) (,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)))) ;;; Comparison functions that are like various builtins, ;;; but are guaranteed to return T for true. (defun eqt (x y) "Like EQ, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) (defun eqlt (x y) "Like EQL, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) (defun equalt (x y) "Like EQUAL, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) (defun equalpt (x y) "Like EQUALP, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) (defun equalpt-or-report (x y) "Like EQUALPT, but return either T or a list of the arguments." (or (equalpt x y) (list x y))) (defun string=t (x y) (notnot-mv (string= x y))) (defun =t (x &rest args) "Like =, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) (defun <=t (x &rest args) "Like <=, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (apply #'<= x args))))) (defun make-int-list (n) (loop for i from 0 below n collect i)) (defun make-int-array (n &optional (fn #'make-array)) (when (symbolp fn) (assert (fboundp fn)) (setf fn (symbol-function (the symbol fn)))) (let ((a (funcall (the function fn) n))) (declare (type (array * *) a)) (loop for i from 0 below n do (setf (aref a i) i)) a)) ;;; Return true if A1 and A2 are arrays with the same rank ;;; and dimensions whose elements are EQUAL (defun equal-array (a1 a2) (and (typep a1 'array) (typep a2 'array) (= (array-rank a1) (array-rank a2)) (if (= (array-rank a1) 0) (equal (regression-test::my-aref a1) (regression-test::my-aref a2)) (let ((ad (array-dimensions a1))) (and (equal ad (array-dimensions a2)) (locally (declare (type (array * *) a1 a2)) (if (= (array-rank a1) 1) (let ((as (first ad))) (loop for i from 0 below as always (equal (regression-test::my-aref a1 i) (regression-test::my-aref a2 i)))) (let ((as (array-total-size a1))) (and (= as (array-total-size a2)) (loop for i from 0 below as always (equal (regression-test::my-row-major-aref a1 i) (regression-test::my-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*)) ;;; 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)))))) (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." (when (symbolp p) (assert (fboundp p)) (setf p (symbol-function p))) (assert (typep p 'function)) (loop for x in *universe* when (block failed (let ((p1 (handler-case (normally (funcall (the function p) x)) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case (normally (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))) collect x)) ;;; We have a common idiom where a guarded predicate should be ;;; true everywhere (defun check-predicate (predicate &optional guard (universe *universe*)) "Return all elements of UNIVERSE for which the guard (if present) is false and for which PREDICATE is false." (remove-if #'(lambda (e) (or (and guard (funcall guard e)) (funcall predicate e))) universe)) (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 (normally ,form) (type-error () 'type-error) (error (c) c)))) (defmacro classify-error* (form) "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))) (handler-case (normally ,form) (undefined-function () 'undefined-function) (program-error () 'program-error) (package-error () 'package-error) (type-error () 'type-error) (control-error () 'control-error) (parse-error () 'parse-error) (stream-error () 'stream-error) (reader-error () 'reader-error) (file-error () 'file-error) (cell-error () 'cell-error) (division-by-zero () 'division-by-zero) (floating-point-overflow () 'floating-point-overflow) (floating-point-underflow () 'floating-point-underflow) (arithmetic-error () 'arithmetic-error) (error () 'error) ))) (defun classify-error** (form) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) (proclaim '(optimize (safety 3))) (classify-error* (if regression-test::*compile-tests* (funcall (compile nil `(lambda () (declare (optimize (safety 3))) ,form))) (eval form)) ))) (defmacro classify-error (form) `(classify-error** ',form)) ;;; The above is badly designed, since it fails when some signals ;;; may be in more than one class/ (defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) `(handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) (proclaim '(optimize (safety 3))) (handler-case (apply #'values nil (multiple-value-list ,(cond (inline form) (regression-test::*compile-tests* `(funcall (compile nil '(lambda () (declare (optimize (safety ,safety))) ,form)))) (t `(eval ',form))))) (,error-name (c) (cond ,@(case error-name (type-error `(((typep (type-error-datum c) (type-error-expected-type c)) (values nil (list (list 'typep (list 'quote (type-error-datum c)) (list 'quote (type-error-expected-type c))) "==> true"))))) ((undefined-function unbound-variable) (and name-p `(((not (eq (cell-error-name c) ',name)) (values nil (list 'cell-error-name "==>" (cell-error-name c))))))) ((stream-error end-of-file reader-error) `(((not (streamp (stream-error-stream c))) (values nil (list 'stream-error-stream "==>" (stream-error-stream c)))))) (file-error `(((not (pathnamep (pathname (file-error-pathname c)))) (values nil (list 'file-error-pathname "==>" (file-error-pathname c)))))) (t nil)) (t (printable-p c))))))) (defmacro signals-error-always (form error-name) `(values (signals-error ,form ,error-name) (signals-error ,form ,error-name :safety 0))) (defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) (let ((lambda-form `(lambda (,var) (declare (optimize (safety ,safety))) ,form))) `(let ((,var ,datum-form)) (declare (optimize safety)) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) ; (proclaim '(optimize (safety 3))) (handler-case (apply #'values nil (multiple-value-list (funcall ,(cond (inline `(function ,lambda-form)) (regression-test::*compile-tests* `(compile nil ',lambda-form)) (t `(eval ',lambda-form))) ,var))) (type-error (c) (let ((datum (type-error-datum c)) (expected-type (type-error-expected-type c))) (cond ((not (eql ,var datum)) (list :datum-mismatch ,var datum)) ((typep datum expected-type) (list :is-typep datum expected-type)) (t (printable-p c)))))))))) (declaim (special *mini-universe*)) (defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) "Check that for all elements in some set, either guard-fn is true or pred-fn signals a type error." (let (val) (loop for e in universe unless (or (funcall guard-fn e) (equal (setf val (multiple-value-list (signals-type-error x e (funcall pred-fn x) :inline t))) '(t))) collect (list e val)))) (defmacro check-type-error (&body args) `(locally (declare (optimize safety)) (check-type-error* ,@args))) (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))))) ;;; ;;; The function SUBTYPEP should return two generalized booleans. ;;; This auxiliary function returns booleans instead ;;; (which makes it easier to write tests). ;;; (defun subtypep* (type1 type2) (apply #'values (mapcar #'notnot (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)))))) ;; (declaim (ftype (function (&rest function) (values function &optional)) ;; compose)) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f in rfns do (setf x (funcall (the function f) x))) x))) (defun evendigitp (c) (notnot (find c "02468"))) (defun odddigitp (c) (notnot (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) (eqt x y))) (defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) (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)) (defun char-invertcase (c) (if (upper-case-p c) (char-downcase c) (char-upcase c))) (defun string-invertcase (s) (map 'string #'char-invertcase s)) (defun symbol< (x &rest args) (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) (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))) (defparameter +standard-chars+ (coerce "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ " 'simple-base-string)) (defparameter +base-chars+ #.(coerce (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") 'simple-base-string)) (declaim (type simple-base-string +base-chars+)) (defparameter +num-base-chars+ (length +base-chars+)) (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") (defparameter +extended-digit-chars+ (coerce "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'simple-base-string)) (declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ +standard-chars+)) (defparameter +code-chars+ (coerce (loop for i from 0 below 256 for c = (code-char i) when c collect c) 'simple-string)) (declaim (type simple-string +code-chars+)) (defparameter +rev-code-chars+ (reverse +code-chars+)) ;;; Used in checking for continuable errors (defun has-non-abort-restart (c) (throw 'handled (if (position 'abort (the list (compute-restarts c)) :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))) ;;; 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* :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 (defparameter +float-types+ '(long-float double-float short-float single-float)) (defparameter *subtype-table* (let ((table '( (null symbol) (symbol t) (boolean symbol) (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) (null boolean) (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) ;; (string base-string) ;; (simple-string simple-base-string) ) table))) table)) (defparameter *disjoint-types-list* '(cons symbol array number character hash-table function readtable package pathname stream random-state condition restart)) (defparameter *disjoint-types-list2* `((cons (cons t t) (cons t (cons t t)) (eql (nil))) (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) (array vector simple-array simple-vector string simple-string 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"")) (stream broadcast-stream concatenated-stream echo-stream file-stream string-stream synonym-stream two-way-stream) (number real complex float integer rational ratio fixnum bit (integer 0 100) (float 0.0 100.0) (integer 0 *) (rational 0 *) (mod 10) (eql 0) ,@(and (not (subtypep 'bignum nil)) (list 'bignum))) (random-state) ,*condition-types* (restart) (readtable))) (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)))))) (defun is-t-or-nil (e) (or (eqt e t) (eqt e nil))) (defun is-builtin-class (type) (when (symbolp type) (setq type (find-class type nil))) (typep type 'built-in-class)) (defun even-size-p (a) (some #'evenp (array-dimensions a))) (defun safe-elt (x n) (classify-error* (elt x n))) (defmacro defstruct* (&body args) `(eval-when (:load-toplevel :compile-toplevel :execute) (handler-case (eval '(defstruct ,@args)) (serious-condition () nil)))) (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)))) #-(or allegro openmcl lispworks) (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))) ;;; This is a hack to get around an ACL bug; OpenMCL also apparently ;;; needs it #+(or allegro openmcl lispworks) (defun delete-all-versions (pathspec) (when (probe-file pathspec) (delete-file pathspec))) (defconstant +fail-count-limit+ 20) (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))) (defun frob-simple-warning (c expected-fmt &rest expected-args) (and (typep c 'simple-warning) (apply #'frob-simple-condition c expected-fmt expected-args))) (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)) (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))) (defmacro def-macro-test (test-name macro-form) (let ((macro-name (car macro-form))) (assert (symbolp macro-name)) `(deftest ,test-name (values (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)) t t t))) (defun typep* (element type) (not (not (typep element type)))) (defun applyf (fn &rest args) (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)))))) (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)) (defun slot-value-or-nil (object slot-name) (and (slot-exists-p object slot-name) (slot-boundp object slot-name) (slot-value object slot-name))) (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))) ;;; 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)) ;;; 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)) (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)) (t (rational x)))))) (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* (cdr x) (cdr 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)) (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)) ;;; Function to produce a non-simple string (defun make-special-string (string &key fill adjust displace base) (let* ((len (length string)) (len2 (if fill (+ len 4) len)) (etype (if base 'base-char 'character))) (if displace (let ((s0 (make-array (+ len2 5) :initial-contents (concatenate 'string (make-string 2 :initial-element #\X) string (make-string (if fill 7 3) :initial-element #\Y)) :element-type etype))) (make-array len2 :element-type etype :adjustable adjust :fill-pointer (if fill len nil) :displaced-to s0 :displaced-index-offset 2)) (make-array len2 :element-type etype :initial-contents (if fill (concatenate 'string string "ZZZZ") string) :fill-pointer (if fill len nil) :adjustable adjust)))) (defmacro do-special-strings ((var string-form &optional ret-form) &body forms) (let ((string (gensym)) (fill (gensym "FILL")) (adjust (gensym "ADJUST")) (base (gensym "BASE")) (displace (gensym "DISPLACE"))) `(let ((,string ,string-form)) (dolist (,fill '(nil t) ,ret-form) (dolist (,adjust '(nil t)) (dolist (,base '(nil t)) (dolist (,displace '(nil t)) (let ((,var (make-special-string ,string :fill ,fill :adjust ,adjust :base ,base :displace ,displace))) ,@forms)))))))) (defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) (let* ((len (length contents)) (min (reduce #'min contents)) (max (reduce #'max contents)) (len2 (if fill (+ len 4) len))) (unless (and (typep min etype) (typep max etype)) (setq etype `(integer ,min ,max))) (if displace (let ((s0 (make-array (+ len2 5) :initial-contents (concatenate 'list (make-list 2 :initial-element (if (typep 0 etype) 0 min)) contents (make-list (if fill 7 3) :initial-element (if (typep 1 etype) 1 max))) :element-type etype))) (make-array len2 :element-type etype :adjustable adjust :fill-pointer (if fill len nil) :displaced-to s0 :displaced-index-offset 2)) (make-array len2 :element-type etype :initial-contents (if fill (concatenate 'list contents (make-list 4 :initial-element (if (typep 2 etype) 2 (floor (+ min max) 2)))) contents) :fill-pointer (if fill len nil) :adjustable adjust)))) (defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) (let ((vector (gensym)) (fill (gensym "FILL")) (adjust (gensym "ADJUST")) (etype (gensym "ETYPE")) (displace (gensym "DISPLACE"))) `(let ((,vector ,vec-form)) (dolist (,fill '(nil t) ,ret-form) (dolist (,adjust '(nil t)) (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) (loop for i from 2 to 32 collect `(signed-byte ,i)) '(integer))) (dolist (,displace '(nil t)) (let ((,var (make-special-integer-vector ,vector :fill ,fill :adjust ,adjust :etype ,etype :displace ,displace))) ,@forms)))))))) ;;; Return T if arg X is a string designator in this implementation (defun string-designator-p (x) (handler-case (progn (string x) t) (error nil))) ;;; Approximate comparison of numbers #| (defun approx= (x y) (let ((eps 1.0d-4)) (<= (abs (- x y)) (* eps (max (abs x) (abs y)))))) |# ;;; Approximate equality function (defun approx= (x y &optional (eps (epsilon x))) (<= (abs (/ (- x y) (max (abs x) 1))) eps)) (defun epsilon (number) (etypecase number (complex (* 2 (epsilon (realpart number)))) ;; crude (short-float short-float-epsilon) (single-float single-float-epsilon) (double-float double-float-epsilon) (long-float long-float-epsilon) (rational 0))) (defun negative-epsilon (number) (etypecase number (complex (* 2 (negative-epsilon (realpart number)))) ;; crude (short-float short-float-negative-epsilon) (single-float single-float-negative-epsilon) (double-float double-float-negative-epsilon) (long-float long-float-negative-epsilon) (rational 0))) (defun sequencep (x) (typep x 'sequence)) (defun typef (type) #'(lambda (x) (typep x type))) (defun package-designator-p (x) "TRUE if x could be a package designator. The package need not actually exist." (or (packagep x) (handler-case (and (locally (declare (optimize safety)) (string x)) t) (type-error () nil)))) (defmacro def-fold-test (name form) "Create a test that FORM, which should produce a fresh value, does not improperly introduce sharing during constant folding." `(deftest ,name (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) (debug 0))) ,form)) (eq (%f) (%f))) nil)) ;;; Macro used in tests of environments in system macros ;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP ;;; was being called in some system macros without the proper ;;; environment argument (defmacro expand-in-current-env (macro-form &environment env) (macroexpand macro-form env))