equal.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          equal.lisp
   6 ;;;; Purpose:       Generalized equal function for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: equal.lisp,v 1.12 2003/03/25 13:41:54 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19
  20 (in-package :kmrcl)
  21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  22
  23
  24 (defun generalized-equal (obj1 obj2)
  25   (if (not (equal (type-of obj1) (type-of obj2)))
  26       (progn
  27         (terpri)
  28         (describe obj1)
  29         (describe obj2)
  30         nil)
  31     (typecase obj1
  32       (double-float
  33        (let ((diff (abs (/ (- obj1 obj2) obj1))))
  34          (if (> diff (* 10 double-float-epsilon))
  35              nil
  36            t)))
  37       (complex
  38        (and (generalized-equal (realpart obj1) (realpart obj2))
  39             (generalized-equal (imagpart obj1) (imagpart obj2))))
  40       (standard-xstructure
  41        (generalized-equal-fielded-object obj1 obj2))
  42       (standard-object
  43        (generalized-equal-fielded-object obj1 obj2))
  44       (hash-table
  45        (generalized-equal-hash-table obj1 obj2)
  46        )
  47       (function
  48        (generalized-equal-function obj1 obj2))
  49       (string
  50        (string= obj1 obj2))
  51       (array
  52        (generalized-equal-array obj1 obj2))
  53       (t
  54        (equal obj1 obj2)))))
  55
  56
  57 (defun generalized-equal-function (obj1 obj2)
  58   (string= (function-to-string obj1) (function-to-string obj2)))
  59
  60 (defun generalized-equal-array (obj1 obj2)
  61   (block test
  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)))
  68
  69 (defun generalized-equal-hash-table (obj1 obj2)
  70   (block test
  71     (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
  72       (return-from test nil))
  73     (maphash
  74      #'(lambda (k v)
  75          (multiple-value-bind (value found) (gethash k obj2)
  76            (unless (and found (generalized-equal v value))
  77              (return-from test nil))))
  78      obj1)
  79     (return-from test t)))
  80
  81 (defun generalized-equal-fielded-object (obj1 obj2)
  82   (block test
  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)))
  89
  90 #+sbcl
  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*)))
  95
  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)))
 107   #+mcl
 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")
 114   )
 115
 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
 120                (find-class s-name))
 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
 128                 (kernel:dd-slots
 129                  (kernel:layout-info
 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")
 136   )
 137
 138 #+sbcl
 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*))))
 143
 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))
 149     (if lambda
 150           (format nil "#'~s" lambda)
 151       (if name
 152           (format nil "#'~s" name)
 153         (progn
 154           (print obj)
 155           (break))))))
 156