X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=equal.lisp;h=2b063b99caa675a446c37738cb698900e879b8a1;hp=0e98719577bd41c18427b07b6a43669fae715c99;hb=b7f3a2b6318514a93a08c67254eb145e1a3a29e2;hpb=f5f45301a1206dbc46999e983d21c760bf9654b9 diff --git a/equal.lisp b/equal.lisp index 0e98719..2b063b9 100644 --- a/equal.lisp +++ b/equal.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: equal.lisp,v 1.12 2003/03/25 13:41:54 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -17,27 +17,26 @@ ;;;; ************************************************************************* -(in-package :kmrcl) -(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) +(in-package #:kmrcl) + - (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)))) - (standard-xstructure + (generalized-equal (imagpart obj1) (imagpart obj2)))) + (structure-object (generalized-equal-fielded-object obj1 obj2)) (standard-object (generalized-equal-fielded-object obj1 obj2)) @@ -63,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) @@ -72,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))) @@ -84,32 +83,22 @@ (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))) -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (if (find-package 'sb-mop) - (pushnew :sb-mop cl:*features*) - (pushnew :sb-pcl cl:*features*))) - (defun class-slot-names (c-name) "Given a CLASS-NAME, returns a list of the slots in the class." - #+(or allegro lispworks scl) - (mapcar #'clos:slot-definition-name - (clos:class-slots (find-class c-name))) - #+sbcl-mop (mapcar #'sb-mop::slot-definition-name - (sb-mop:class-slots (find-class c-name))) - #+sbcl-pcl (mapcar #'sb-pcl::slot-definition-name - (sb-pcl:class-slots (sb-pcl::find-class c-name))) - #+cmu (mapcar #'pcl::slot-definition-name - (pcl:class-slots (pcl:find-class c-name))) - #+mcl + #+(or allegro cmu lispworks sbcl scl) + (mapcar #'kmr-mop:slot-definition-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) (nconc (mapcar #'car (ccl:class-instance-slots class)) (mapcar #'car (ccl:class-class-slots class))))) - #-(or allegro lispworks cmu mcl sbcl scl) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (declare (ignore c-name)) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) (error "class-slot-names is not defined on this platform") ) @@ -117,40 +106,33 @@ "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)) - #+sbcl-mop (mapcar #'sb-mop::slot-definition-name - (sb-mop:class-slots (find-class s-name))) - #+sbcl-pcl (mapcar #'sb-pcl::slot-definition-name - (sb-pcl:class-slots (sb-pcl::find-class s-name))) - #+cmu (mapcar #'pcl::slot-definition-name - (pcl:class-slots (pcl: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))) #+scl (mapcar #'kernel:dsd-name - (kernel:dd-slots - (kernel:layout-info - (kernel:class-layout (find-class s-name))))) - #+mcl (let* ((sd (gethash s-name ccl::%defstructs%)) - (slots (if sd (ccl::sd-slots sd)))) - (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) - #-(or allegro lispworks cmu sbcl scl mcl) + (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)))) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (declare (ignore s-name)) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) (error "structure-slot-names is not defined on this platform") ) -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (if (find-package 'sb-mop) - (setq cl:*features* (delete :sb-mop cl:*features*)) - (setq cl:*features* (delete :sb-pcl cl:*features*)))) - (defun function-to-string (obj) "Returns the lambda code for a function. Relies on 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))))))