r2976: *** empty log message ***

[kmrcl.git] / equal.lisp

diff --git a/equal.lisp b/equal.lisp
new file mode 100644 (file)
index 0000000..b773db0
--- /dev/null
+++ b/equal.lisp
@@ -0,0 +1,113 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          equal.lisp
+;;;; Purpose:       Generalized equal function for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: equal.lisp,v 1.1 2002/10/12 06:10:17 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package :kmrcl)
+(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+
+  
+(defun generalized-equal (obj1 obj2)
+  (if (not (equal (type-of obj1) (type-of obj2)))
+      (progn
+       (terpri)
+       (describe obj1)
+       (describe obj2)
+       nil)
+    (typecase obj1
+      (double-float
+       (let ((diff (abs (/ (- obj1 obj2) obj1))))
+        (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-fielded-object obj1 obj2))
+      (standard-object
+       (generalized-equal-fielded-object obj1 obj2))
+      (hash-table
+       (generalized-equal-hash-table obj1 obj2)
+       )
+      (function
+       (generalized-equal-function obj1 obj2))
+      (string
+       (string= obj1 obj2))
+      (array
+       (generalized-equal-array obj1 obj2))
+      (t
+       (equal obj1 obj2)))))
+
+
+(defun generalized-equal-function (obj1 obj2)
+  (string= (function-to-string obj1) (function-to-string obj2)))
+
+(defun generalized-equal-array (obj1 obj2)
+  (block test
+    (when (not (= (array-total-size obj1) (array-total-size obj2)))
+      (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 t)))
+
+(defun generalized-equal-hash-table (obj1 obj2)
+  (block test
+    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
+      (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))))
+     obj1)
+    (return-from test t)))
+
+(defun generalized-equal-fielded-object (obj1 obj2)
+  (block test
+    (when (not (equal (class-of obj1) (class-of obj2)))
+      (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 t)))
+
+#+(or allegro lispworks)
+(defun class-slot-names (class-name)
+  "Given a CLASS-NAME, returns a list of the slots in the class."
+  (mapcar #'clos:slot-definition-name
+         (clos:class-slots (find-class class-name))))
+
+#-(or allegro lispworks)
+(defun class-slot-names (class-name)
+  (warn "class-slot-names not supported on this platform"))
+
+
+(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)
+      (if name
+         (format nil "#'~s" name)
+       (progn
+         (print obj)
+         (break))))))
+