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 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17
  18 (in-package #:kmrcl)
  19
  20
  21 (defun generalized-equal (obj1 obj2)
  22   (if (not (equal (type-of obj1) (type-of obj2)))
  23       (progn
  24         (terpri)
  25         (describe obj1)
  26         (describe obj2)
  27         nil)
  28     (typecase obj1
  29       (double-float
  30        (let ((diff (abs (/ (- obj1 obj2) obj1))))
  31          (if (> diff (* 10 double-float-epsilon))
  32              nil
  33            t)))
  34       (complex
  35        (and (generalized-equal (realpart obj1) (realpart obj2))
  36             (generalized-equal (imagpart obj1) (imagpart obj2))))
  37       (structure-object
  38        (generalized-equal-fielded-object obj1 obj2))
  39       (standard-object
  40        (generalized-equal-fielded-object obj1 obj2))
  41       (hash-table
  42        (generalized-equal-hash-table obj1 obj2)
  43        )
  44       (function
  45        (generalized-equal-function obj1 obj2))
  46       (string
  47        (string= obj1 obj2))
  48       (array
  49        (generalized-equal-array obj1 obj2))
  50       (t
  51        (equal obj1 obj2)))))
  52
  53
  54 (defun generalized-equal-function (obj1 obj2)
  55   (string= (function-to-string obj1) (function-to-string obj2)))
  56
  57 (defun generalized-equal-array (obj1 obj2)
  58   (block test
  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)))
  65
  66 (defun generalized-equal-hash-table (obj1 obj2)
  67   (block test
  68     (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
  69       (return-from test nil))
  70     (maphash
  71      #'(lambda (k v)
  72          (multiple-value-bind (value found) (gethash k obj2)
  73            (unless (and found (generalized-equal v value))
  74              (return-from test nil))))
  75      obj1)
  76     (return-from test t)))
  77
  78 (defun generalized-equal-fielded-object (obj1 obj2)
  79   (block test
  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)))
  86
  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")
 101   )
 102
 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
 107                (find-class s-name))
 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
 111                 (kernel:dd-slots
 112                  (kernel:layout-info
 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")
 122   )
 123
 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))
 129     (if lambda
 130           (format nil "#'~s" lambda)
 131       (if name
 132           (format nil "#'~s" name)
 133         (progn
 134           (print obj)
 135           (break))))))
 136