1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Generalized equal function for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: equal.lisp,v 1.12 2003/03/25 13:41:54 kevin Exp $
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
24 (defun generalized-equal (obj1 obj2)
25 (if (not (equal (type-of obj1) (type-of obj2)))
33 (let ((diff (abs (/ (- obj1 obj2) obj1))))
34 (if (> diff (* 10 double-float-epsilon))
38 (and (generalized-equal (realpart obj1) (realpart obj2))
39 (generalized-equal (imagpart obj1) (imagpart obj2))))
41 (generalized-equal-fielded-object obj1 obj2))
43 (generalized-equal-fielded-object obj1 obj2))
45 (generalized-equal-hash-table obj1 obj2)
48 (generalized-equal-function obj1 obj2))
52 (generalized-equal-array obj1 obj2))
57 (defun generalized-equal-function (obj1 obj2)
58 (string= (function-to-string obj1) (function-to-string obj2)))
60 (defun generalized-equal-array (obj1 obj2)
62 (when (not (= (array-total-size obj1) (array-total-size obj2)))
63 (return-from test nil))
64 (dotimes (i (array-total-size obj1))
65 (unless (generalized-equal (aref obj1 i) (aref obj2 i))
66 (return-from test nil)))
67 (return-from test t)))
69 (defun generalized-equal-hash-table (obj1 obj2)
71 (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
72 (return-from test nil))
75 (multiple-value-bind (value found) (gethash k obj2)
76 (unless (and found (generalized-equal v value))
77 (return-from test nil))))
79 (return-from test t)))
81 (defun generalized-equal-fielded-object (obj1 obj2)
83 (when (not (equal (class-of obj1) (class-of obj2)))
84 (return-from test nil))
85 (dolist (field (class-slot-names (class-name (class-of obj1))))
86 (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
87 (return-from test nil)))
88 (return-from test t)))
91 (eval-when (:compile-toplevel :load-toplevel :execute)
92 (if (find-package 'sb-mop)
93 (pushnew :sb-mop cl:*features*)
94 (pushnew :sb-pcl cl:*features*)))
96 (defun class-slot-names (c-name)
97 "Given a CLASS-NAME, returns a list of the slots in the class."
98 #+(or allegro lispworks scl)
99 (mapcar #'clos:slot-definition-name
100 (clos:class-slots (find-class c-name)))
101 #+sbcl-mop (mapcar #'sb-mop::slot-definition-name
102 (sb-mop:class-slots (find-class c-name)))
103 #+sbcl-pcl (mapcar #'sb-pcl::slot-definition-name
104 (sb-pcl:class-slots (sb-pcl::find-class c-name)))
105 #+cmu (mapcar #'pcl::slot-definition-name
106 (pcl:class-slots (pcl:find-class c-name)))
108 (let* ((class (find-class c-name nil)))
109 (when (typep class 'standard-class)
110 (nconc (mapcar #'car (ccl:class-instance-slots class))
111 (mapcar #'car (ccl:class-class-slots class)))))
112 #-(or allegro lispworks cmu mcl sbcl scl)
113 (error "class-slot-names is not defined on this platform")
116 (defun structure-slot-names (s-name)
117 "Given a STRUCTURE-NAME, returns a list of the slots in the structure."
118 #+allegro (class-slot-names s-name)
119 #+lispworks (structure:structure-class-slot-names
121 #+sbcl-mop (mapcar #'sb-mop::slot-definition-name
122 (sb-mop:class-slots (find-class s-name)))
123 #+sbcl-pcl (mapcar #'sb-pcl::slot-definition-name
124 (sb-pcl:class-slots (sb-pcl::find-class s-name)))
125 #+cmu (mapcar #'pcl::slot-definition-name
126 (pcl:class-slots (pcl:find-class s-name)))
127 #+scl (mapcar #'kernel:dsd-name
130 (kernel:class-layout (find-class s-name)))))
131 #+mcl (let* ((sd (gethash s-name ccl::%defstructs%))
132 (slots (if sd (ccl::sd-slots sd))))
133 (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
134 #-(or allegro lispworks cmu sbcl scl mcl)
135 (error "structure-slot-names is not defined on this platform")
139 (eval-when (:compile-toplevel :load-toplevel :execute)
140 (if (find-package 'sb-mop)
141 (setq cl:*features* (delete :sb-mop cl:*features*))
142 (setq cl:*features* (delete :sb-pcl cl:*features*))))
144 (defun function-to-string (obj)
145 "Returns the lambda code for a function. Relies on
146 Allegro implementation-dependent features."
147 (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
148 (declare (ignore closurep))
150 (format nil "#'~s" lambda)
152 (format nil "#'~s" name)