struct-equal for ccl and sbcl

struct-equal.lisp

(defpackage :struct-equal (:use :cl) (:export :struct-equal))
(in-package :struct-equal)


#+sbcl
(in-package :sb-impl)
#+sbcl
(defun struct-equal:struct-equal (x y &optional (subtest #'equalp))
  (flet ((raw-instance-slots-equal (layout x y)
           (loop with i = -1
              for dsd in (dd-slots (layout-info layout))
              for raw-type = (dsd-raw-type dsd)
              for rsd = (when raw-type
                          (find raw-type
                                sb-kernel::*raw-slot-data-list*
                                :key 'raw-slot-data-raw-type))
              for accessor = (when rsd
                               (sb-kernel::raw-slot-data-accessor-name rsd))
              always (or (not accessor)
                         (progn
                           (incf i)
                           (funcall subtest (funcall accessor x i)
                                    (funcall accessor y i)))))))
    (let* ((layout-x (%instance-layout x))
           (raw-len (layout-n-untagged-slots layout-x))
           (total-len (layout-length layout-x))
           (normal-len (- total-len raw-len)))
      (and (%instancep y)
           (eq layout-x (%instance-layout y))
           (structure-classoid-p (layout-classoid layout-x))
           (dotimes (i normal-len t)
             (let ((x-el (%instance-ref x i))
                   (y-el (%instance-ref y i)))
               (unless (or (eq x-el y-el)
                           (funcall subtest x-el y-el))
                 (return nil))))
           (if (zerop raw-len)
               t
               (raw-instance-slots-equal layout-x x y))))))
#+sbcl
(in-package :struct-equal)


#+ccl
(in-package :ccl)
#+ccl
(defun struct-equal:struct-equal (x y &optional (subtest #'equalp))
  (let ((size (uvsize x)))
    (and (eq size (uvsize y))
         (dotimes (i size t)
           (declare (fixnum i))
           (unless (funcall subtest (uvref x i) (uvref y i))
             (return nil))))))
#+ccl
(in-package :struct-equal)

(defmacro show (form)
  `(format t "~%~a~%;; => ~a~%" ',form ,form))

(show (defstruct a (b 0)))

(show (equalp (make-a) (make-a)))
(show (equal (make-a) (make-a)))
(show (struct-equal (make-a) (make-a)))
(show (struct-equal (make-a :b 1) (make-a :b 2)))

(show (defgeneric close-enough (a b)))
(show (defmethod close-enough (a b)
        (equalp a b))) 
(show (defmethod close-enough ((a number) (b number))
        (< (abs (- a b)) 3)))

(show (struct-equal (make-a :b 1) (make-a :b 2) #'close-enough))

#|

bash-3.2$ ccl  -n --load $PWD/struct-equal.lisp --eval '(quit)'

(DEFSTRUCT A (B 0))
;; => A

(EQUALP (MAKE-A) (MAKE-A))
;; => T

(EQUAL (MAKE-A) (MAKE-A))
;; => NIL

(STRUCT-EQUAL (MAKE-A) (MAKE-A))
;; => T

(STRUCT-EQUAL (MAKE-A B 1) (MAKE-A B 2))
;; => NIL

(DEFMETHOD CLOSE-ENOUGH (A B) (EQUALP A B))
;; => #<STANDARD-METHOD CLOSE-ENOUGH (T T)>

(DEFMETHOD CLOSE-ENOUGH ((A NUMBER) (B NUMBER)) (< (ABS (- A B)) 3))
;; => #<STANDARD-METHOD CLOSE-ENOUGH (NUMBER NUMBER)>

(STRUCT-EQUAL (MAKE-A B 1) (MAKE-A B 2) #'CLOSE-ENOUGH)
;; => T


--------------------------------------------------------------------------------
bash-3.2$ sbcl --noinform --no-userinit --load $PWD/struct-equal.lisp --eval "(sb-ext:exit)"

(DEFSTRUCT A (B 0))
;; => A

(EQUALP (MAKE-A) (MAKE-A))
;; => T

(EQUAL (MAKE-A) (MAKE-A))
;; => NIL

(STRUCT-EQUAL (MAKE-A) (MAKE-A))
;; => T

(STRUCT-EQUAL (MAKE-A B 1) (MAKE-A B 2))
;; => NIL

(DEFGENERIC CLOSE-ENOUGH
    (A B))
;; => #<STANDARD-GENERIC-FUNCTION CLOSE-ENOUGH (0)>

(DEFMETHOD CLOSE-ENOUGH (A B) (EQUALP A B))
;; => #<STANDARD-METHOD CLOSE-ENOUGH (T T) {1003D84A63}>

(DEFMETHOD CLOSE-ENOUGH ((A NUMBER) (B NUMBER)) (< (ABS (- A B)) 3))
;; => #<STANDARD-METHOD CLOSE-ENOUGH (NUMBER NUMBER) {1003DF9923}>

(STRUCT-EQUAL (MAKE-A B 1) (MAKE-A B 2) #'CLOSE-ENOUGH)
;; => T


|#