Failed attempt at tracking output

sbcl-version-also-fails.lisp

(defun tracking-pprint-to-string/sbcl (object)
  (let ((positions nil)
        (original-table *print-pprint-dispatch*)
        (table (copy-pprint-dispatch)))
    (values (with-output-to-string (stream)
              (set-pprint-dispatch 'cons
                                   (lambda (stream cons)
                                     (push (list (+ (sb-pretty::pretty-stream-buffer-fill-pointer stream)
                                                    (sb-pretty::pretty-stream-buffer-offset stream))
                                                 cons)
                                           positions)
                                     (funcall (pprint-dispatch cons original-table) stream cons))
                                   most-positive-fixnum
                                   table)
              (write object
                     :stream stream
                     :pretty t
                     :pprint-dispatch table))
            positions)))

tracking-string-output-stream.lisp

(in-package :swank-macrostep)

(defparameter *dbg* nil)

(defclass tracking-string-output-stream
    (swank/gray:fundamental-character-output-stream)
  ((output :initarg :output :accessor output-of
           :initform (make-array 30
                                 :adjustable t
                                 :fill-pointer 0
                                 :element-type 'character))
   (position :initform 0 :accessor position-of)))

(defmethod swank/gray:stream-write-char ((stream tracking-string-output-stream)
                                         character)
  (vector-push-extend character (output-of stream))
  (push (incf (position-of stream)) *dbg*))
  
(let ((result)
      (position 0)
      (stream (make-instance 'tracking-string-output-stream))
      (table (copy-pprint-dispatch)))
  (set-pprint-dispatch 'cons
                       (lambda (stream cons)
                         (push cons *dbg*)
                         (pprint-fill stream cons))
                       0
                       table)
  (write '(unless t (foo))
         :stream stream
         :pretty t
         :pprint-dispatch table)
  *dbg*)
; =>
((UNLESS T (FOO)) (FOO) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)