;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EQV-USING-CLASS

(defgeneric eqv-using-class (x y compare-fn fail-fn))

(defmethod eqv-using-class ((x number) (y number) compare-fn fail-fn)
  (unless (= x y) (funcall fail-fn)))

(defmethod eqv-using-class ((x symbol) (y symbol) compare-fn fail-fn)
  (unless (eq x y) (funcall fail-fn)))

(defmethod eqv-using-class ((x cons) (y cons) compare-fn fail-fn)
  (flet ((continuation () (funcall compare-fn (cdr x) (cdr y))))
    (funcall compare-fn (car x) (car y) #'continuation)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Holy shit I have no idea what this is

(defun eqv (x y &key detect-cycles-p)
  (declare (optimize speed))
  (with-macroexpand-time-branching (detect-cycles-p)
    (let ((continuation nil)
          (state (macroexpand-time-when detect-cycles-p
                   (make-hash-table :test #'eq))))
      ;; STATE is never accessed if DETECT-CYCLES-P is false.
      (declare (ignorable state))
      (labels ((fail () (return-from eqv nil))
               (compare (x y &optional thunk)
                 (declare (type (or null function) thunk))
                 (flet ((stack-frame ()
                          (macroexpand-time-when detect-cycles-p
                            ;; Have we already visited this pair of objects?
                            (when (member y (gethash x state) :test #'eq)
                              ;; We have - call the thunk, then bail out.
                              (when thunk (funcall thunk))
                              (return-from stack-frame))
                            ;; We haven't - store the objects in the hashtable.
                            (pushnew y (gethash x state) :test #'eq))
                          ;; Defer the actual comparison to EQV-USING-CLASS
                          ;; and call the thunk.
                          (eqv-using-class x y #'compare #'fail)
                          (when thunk (funcall thunk))))
                   (when continuation
                     (error "COMPARE-FN called second time in a row. ~
                             (Pass a thunk as an optional third argument ~
                             instead.)"))
                   (setf continuation #'stack-frame))))
        ;; Handle the starting elements.
        (compare x y)
        ;; Loop until there is no continuation.
        (loop until (null continuation)
              do (funcall (the function (prog1 continuation
                                          (setf continuation nil)))))
        ;; If there was no non-local exit, the match is complete.
        t))))



CL-USER> (let ((list-1 (alexandria:make-circular-list 1000))
               (list-2 (alexandria:make-circular-list 99)))
           (time (eqv list-1 list-2 :detect-cycles-p t)))

Evaluation took:
  0.227 seconds of real time
  0.228886 seconds of total run time (0.228885 user, 0.000001 system)
  100.88% CPU
  800,858,847 processor cycles
  19,113,808 bytes consed
  
T