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 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; KMRCL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
21 (defun generalized-equal (obj1 obj2)
22 (if (not (equal (type-of obj1) (type-of obj2)))
30 (let ((diff (abs (/ (- obj1 obj2) obj1))))
31 (if (> diff (* 10 double-float-epsilon))
35 (and (generalized-equal (realpart obj1) (realpart obj2))
36 (generalized-equal (imagpart obj1) (imagpart obj2))))
38 (generalized-equal-fielded-object obj1 obj2))
40 (generalized-equal-fielded-object obj1 obj2))
42 (generalized-equal-hash-table obj1 obj2)
45 (generalized-equal-function obj1 obj2))
49 (generalized-equal-array obj1 obj2))
54 (defun generalized-equal-function (obj1 obj2)
55 (string= (function-to-string obj1) (function-to-string obj2)))
57 (defun generalized-equal-array (obj1 obj2)
59 (when (not (= (array-total-size obj1) (array-total-size obj2)))
60 (return-from test nil))
61 (dotimes (i (array-total-size obj1))
62 (unless (generalized-equal (aref obj1 i) (aref obj2 i))
63 (return-from test nil)))
64 (return-from test t)))
66 (defun generalized-equal-hash-table (obj1 obj2)
68 (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
69 (return-from test nil))
72 (multiple-value-bind (value found) (gethash k obj2)
73 (unless (and found (generalized-equal v value))
74 (return-from test nil))))
76 (return-from test t)))
78 (defun generalized-equal-fielded-object (obj1 obj2)
80 (when (not (equal (class-of obj1) (class-of obj2)))
81 (return-from test nil))
82 (dolist (field (class-slot-names (class-name (class-of obj1))))
83 (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
84 (return-from test nil)))
85 (return-from test t)))
87 (defun class-slot-names (c-name)
88 "Given a CLASS-NAME, returns a list of the slots in the class."
89 #+(or allegro cmu lispworks sbcl scl)
90 (mapcar #'kmr-mop:slot-definition-name
91 (kmr-mop:class-slots (kmr-mop:find-class c-name)))
92 #+(and mcl (not openmcl))
93 (let* ((class (find-class c-name nil)))
94 (when (typep class 'standard-class)
95 (nconc (mapcar #'car (ccl:class-instance-slots class))
96 (mapcar #'car (ccl:class-class-slots class)))))
97 #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
98 (declare (ignore c-name))
99 #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
100 (error "class-slot-names is not defined on this platform")
103 (defun structure-slot-names (s-name)
104 "Given a STRUCTURE-NAME, returns a list of the slots in the structure."
105 #+allegro (class-slot-names s-name)
106 #+lispworks (structure:structure-class-slot-names
108 #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name
109 (kmr-mop:class-slots (kmr-mop:find-class s-name)))
110 #+scl (mapcar #'kernel:dsd-name
113 (kernel:class-layout (find-class s-name)))))
114 #+(and mcl (not openmcl))
115 (let* ((sd (gethash s-name ccl::%defstructs%))
116 (slots (if sd (ccl::sd-slots sd))))
117 (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
118 #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
119 (declare (ignore s-name))
120 #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
121 (error "structure-slot-names is not defined on this platform")
124 (defun function-to-string (obj)
125 "Returns the lambda code for a function. Relies on
126 Allegro implementation-dependent features."
127 (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
128 (declare (ignore closurep))
130 (format nil "#'~s" lambda)
132 (format nil "#'~s" name)