Function: cl-print--find-sharing

cl-print--find-sharing is a byte-compiled function defined in cl-print.el.gz.

Signature

(cl-print--find-sharing OBJECT TABLE)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-print.el.gz
(defun cl-print--find-sharing (object table)
  ;; Avoid recursion: not only because it's too easy to bump into
  ;; `max-lisp-eval-depth', but also because function calls are fairly slow.
  ;; At first, I thought using a list for our stack would cause too much
  ;; garbage to generated, but I didn't notice any such problem in practice.
  ;; I experimented with using an array instead, but the result was slightly
  ;; slower and the reduction in GC activity was less than 1% on my test.
  (let ((stack (list object)))
    (while stack
      (let ((object (pop stack)))
        (unless
            ;; Skip objects which don't have identity!
            (or (floatp object) (numberp object)
                (null object) (if (symbolp object) (intern-soft object)))
          (let ((n (gethash object table)))
            (cond
             ((numberp n))                   ;All done.
             (n                              ;Already seen, but only once.
              (let ((n (1+ cl-print--number-index)))
                (setq cl-print--number-index n)
                (puthash object (- n) table)))
             (t
              (puthash object t table)
              (pcase object
                (`(,car . ,cdr)
                 (push cdr stack)
                 (push car stack))
                ((pred stringp)
                 (let* ((len (length object))
                        (start (if (text-properties-at 0 object)
                                   0 (next-property-change 0 object)))
                        (end (and start
                                  (next-property-change start object len))))
                   (while (and start (< start len))
                     (let ((props (text-properties-at start object)))
                       (when props
                         (push props stack))
                       (setq start end
                             end (next-property-change start object len))))))
                ((or (pred arrayp) (pred byte-code-function-p))
                 ;; FIXME: Inefficient for char-tables!
                 (dotimes (i (length object))
                   (push (aref object i) stack))))))))))))