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.1 2002/10/12 06:10:17 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)))
90 #+(or allegro lispworks)
91 (defun class-slot-names (class-name)
92 "Given a CLASS-NAME, returns a list of the slots in the class."
93 (mapcar #'clos:slot-definition-name
94 (clos:class-slots (find-class class-name))))
96 #-(or allegro lispworks)
97 (defun class-slot-names (class-name)
98 (warn "class-slot-names not supported on this platform"))
101 (defun function-to-string (obj)
102 "Returns the lambda code for a function. Relies on
103 Allegro implementation-dependent features."
104 (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
105 (declare (ignore closurep))
107 (format nil "#'~s" lambda)
109 (format nil "#'~s" name)