X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=equal.lisp;h=2b063b99caa675a446c37738cb698900e879b8a1;hp=abc8e399f4f3ce1ebd137da1cf9a936d7f8ce73c;hb=03712fbb06acbb103602bae10f41aeae7fa05127;hpb=739b14ee8844dc777b174105646df3abcb865282 diff --git a/equal.lisp b/equal.lisp index abc8e39..2b063b9 100644 --- a/equal.lisp +++ b/equal.lisp @@ -23,19 +23,19 @@ (defun generalized-equal (obj1 obj2) (if (not (equal (type-of obj1) (type-of obj2))) (progn - (terpri) - (describe obj1) - (describe obj2) - nil) + (terpri) + (describe obj1) + (describe obj2) + nil) (typecase obj1 (double-float (let ((diff (abs (/ (- obj1 obj2) obj1)))) - (if (> diff (* 10 double-float-epsilon)) - nil - t))) + (if (> diff (* 10 double-float-epsilon)) + nil + t))) (complex (and (generalized-equal (realpart obj1) (realpart obj2)) - (generalized-equal (imagpart obj1) (imagpart obj2)))) + (generalized-equal (imagpart obj1) (imagpart obj2)))) (structure-object (generalized-equal-fielded-object obj1 obj2)) (standard-object @@ -62,7 +62,7 @@ (return-from test nil)) (dotimes (i (array-total-size obj1)) (unless (generalized-equal (aref obj1 i) (aref obj2 i)) - (return-from test nil))) + (return-from test nil))) (return-from test t))) (defun generalized-equal-hash-table (obj1 obj2) @@ -71,9 +71,9 @@ (return-from test nil)) (maphash #'(lambda (k v) - (multiple-value-bind (value found) (gethash k obj2) - (unless (and found (generalized-equal v value)) - (return-from test nil)))) + (multiple-value-bind (value found) (gethash k obj2) + (unless (and found (generalized-equal v value)) + (return-from test nil)))) obj1) (return-from test t))) @@ -83,14 +83,14 @@ (return-from test nil)) (dolist (field (class-slot-names (class-name (class-of obj1)))) (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field)) - (return-from test nil))) + (return-from test nil))) (return-from test t))) (defun class-slot-names (c-name) "Given a CLASS-NAME, returns a list of the slots in the class." #+(or allegro cmu lispworks sbcl scl) (mapcar #'kmr-mop:slot-definition-name - (kmr-mop:class-slots (kmr-mop:find-class c-name))) + (kmr-mop:class-slots (kmr-mop:find-class c-name))) #+(and mcl (not openmcl)) (let* ((class (find-class c-name nil))) (when (typep class 'standard-class) @@ -106,17 +106,17 @@ "Given a STRUCTURE-NAME, returns a list of the slots in the structure." #+allegro (class-slot-names s-name) #+lispworks (structure:structure-class-slot-names - (find-class s-name)) + (find-class s-name)) #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name - (kmr-mop:class-slots (kmr-mop:find-class s-name))) + (kmr-mop:class-slots (kmr-mop:find-class s-name))) #+scl (mapcar #'kernel:dsd-name - (kernel:dd-slots - (kernel:layout-info - (kernel:class-layout (find-class s-name))))) + (kernel:dd-slots + (kernel:layout-info + (kernel:class-layout (find-class s-name))))) #+(and mcl (not openmcl)) (let* ((sd (gethash s-name ccl::%defstructs%)) - (slots (if sd (ccl::sd-slots sd)))) - (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) + (slots (if sd (ccl::sd-slots sd)))) + (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) (declare (ignore s-name)) #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) @@ -129,10 +129,10 @@ Allegro implementation-dependent features." (multiple-value-bind (lambda closurep name) (function-lambda-expression obj) (declare (ignore closurep)) (if lambda - (format nil "#'~s" lambda) + (format nil "#'~s" lambda) (if name - (format nil "#'~s" name) - (progn - (print obj) - (break)))))) + (format nil "#'~s" name) + (progn + (print obj) + (break))))))