Fix pprint dispatch and circularity-aware pretty printing

[blakemcbride]

Fix pprint dispatch and circularity-aware pretty printing

Summary

Repairs four ANSI pretty-printer failures rooted in two separate
issues: the generic pretty-printer entry points (pprint-fill,
pprint-linear, pprint-tabular) routed non-list atoms through a
path that bypassed print-object, and pprint-logical-block did
not cooperate with *print-circle* when it was entered recursively
from a dispatched pretty printer. Four previously-failing ANSI
conformance tests now pass, and no previously-passing test
regresses.

Test	Area
PPRINT-FILL.2	pprint entry points / atom dispatch
PPRINT-LINEAR.2	pprint entry points / atom dispatch
PPRINT-TABULAR.2	pprint entry points / atom dispatch
PPRINT-LOGICAL-BLOCK.17	nested pprint-logical-block + circle

Root causes

A. Functions printed via %write-to-string on xp streams

When pprint-fill / pprint-linear / pprint-tabular received a
non-list atom, they ultimately called output-ugly-object with an
xp-structure stream. In that function, the xp::xp-structure-p stream branch matched before the functionp object branch, so
functions were serialized via sys::%write-to-string — which goes
through Function.writeToString / Function.princToString and
produces only the inner #<FOO {id}> form. write-to-string of
the same function, used as the oracle by
PPRINT-{FILL,LINEAR,TABULAR}.2, takes the CLOS print-object
path and produces the wrapped #<FUNCTION #<FOO {id}> {id}> form.
The two disagreed on every compiled/closure value in
*mini-universe*.

B. Nested pprint-logical-block ignored circularity

maybe-initiate-xp-printing — the common entry for every xp-level
pretty printing operation, including pprint-logical-block — had a
short-circuit for xp-structure streams that simply called the body
thunk without consulting *circularity-hash-table*. So the nested
pprint-logical-block in test .17:

(let ((v1 '(8)))
  (let ((*print-circle* t))
    (with-output-to-string (s)
      (pprint-logical-block (s (list v1 v1) :prefix "(" :suffix ")")
        (pprint-exit-if-list-exhausted)
        (loop (pprint-logical-block (s (pprint-pop))
                (princ (car v1) s))
              (pprint-exit-if-list-exhausted)
              (write-char #\space s))))))

emitted "((8) (8))" instead of the required "(#1=(8) #1#)".
The outer %check-object populated the circularity table
correctly, but the inner pprint-logical-block never asked.

C. Naively adding the circularity check regressed five tests

A straight-forward fix — calling check-for-circularity +
handle-circularity at the top of
maybe-initiate-xp-printing on xp streams — broke five tests that
previously passed:

• PPRINT-FILL.14, PPRINT-LINEAR.14, PPRINT-TABULAR.13
• PPRINT-POP.7, PPRINT-POP.8

They produced "(#1=#1# #1#)" instead of "(#1=(A) #1#)". The
cause: when the dispatched pretty printer for a shared cons is
invoked, the outer output-object has already run
check-for-circularity with assign=t and already emitted
#1=. The hash-table entry is now a positive integer. A second
check-for-circularity call for the same object during pretty-printing
returned the negation (-n), and handle-circularity dutifully
emitted #1# instead of descending into the cons body.

So the fix has to distinguish nested user-initiated
pprint-logical-block (should detect circularity, no outer owner)
from dispatcher-initiated pretty printing (circularity already
handled by the outer %check-object, should skip the check).

Changes

1. print.lisp: route functions through print-object before the xp-stream shortcut

The (functionp object) branch in output-ugly-object was moved
above the (xp::xp-structure-p stream) branch, so functions always
take the CLOS print-object path regardless of stream type:

((java::java-object-p object)
 (print-object object stream))
((functionp object)                         ; ← moved up
 (print-object object stream))
((xp::xp-structure-p stream)
 (let ((s (sys::%write-to-string object)))
   (xp::write-string++ s stream 0 (length s))))

This brings pprint-fill / pprint-linear / pprint-tabular
output for a function value into agreement with write-to-string
(which the tests compare against).

2. print.lisp: introduce *circularity-handled-object*

A new dynamic variable marks the object whose circularity has
just been resolved by %check-object:

(defvar *circularity-handled-object* nil
  "Bound to the current object when %check-object has already
consulted the circularity hash table on its behalf. Downstream
callers of maybe-initiate-xp-printing use this to avoid a redundant
check when pprint-logical-block is entered from a dispatched
pretty-printer.")

%check-object binds it around both %print-object call sites,
so any pretty printer dispatched for object sees it as the
"already handled" sentinel until control returns.

3. pprint.lisp: circularity-aware maybe-initiate-xp-printing

The xp-structure branch now consults the circularity hash table,
but skips the work when the outer %check-object already did it:

(if (xp-structure-p stream)
    (cond ((or (not *print-circle*)
               (null sys::*circularity-hash-table*)
               (sys::uniquely-identified-by-print-p object)
               (eq object sys::*circularity-handled-object*))
           (let ((sys::*circularity-handled-object* nil))
             (apply fn stream args)))
          (t
           (let ((marker (sys::check-for-circularity object t)))
             (cond ((null marker)
                    (apply fn stream args))
                   ((sys::handle-circularity marker stream)
                    (apply fn stream args))))))
    …original non-xp-stream path…)

Key points:

• When circularity detection is off, no hash table yet, or the
  object is uniquely identified by its print form (numbers,
  characters, interned symbols), no check is performed.
• When the object equals *circularity-handled-object*, the
  outer %check-object already emitted #n= or #n# as
  appropriate. Clear the sentinel before recursing so any
  deeper nested call behaves correctly, then call the body.
• Otherwise — this is the user-initiated nested
  pprint-logical-block case — run the full circularity
  protocol.

Files changed

• src/org/armedbear/lisp/print.lisp
• src/org/armedbear/lisp/pprint.lisp

Test plan

• ant abcl builds cleanly.
• All 248 PPRINT-* ANSI tests pass:
  === FAILED TESTS: 0 ===.
• Full ANSI suite (ant test.ansi.compiled): the four target
  tests (PPRINT-FILL.2, PPRINT-LINEAR.2,
  PPRINT-TABULAR.2, PPRINT-LOGICAL-BLOCK.17) no longer
  appear in the unexpected-failure list. Remaining unexpected
  failures match the pre-existing baseline from other
  unmerged branches (numeric FORMAT, pathname printing, CLOS
  corrections, etc.).
• Manual spot checks:
  - (let ((v1 '(8)))
(let ((*print-circle* t))
(with-output-to-string (s)
(pprint-logical-block (s (list v1 v1) :prefix "(" :suffix ")")
(pprint-exit-if-list-exhausted)
(loop (pprint-logical-block (s (pprint-pop))
(princ (car v1) s))
(pprint-exit-if-list-exhausted)
(write-char #\space s))))))
  → "(#1=(8) #1#)"
  - (pprint-fill s #'car) on a fresh stream matches
  (write-to-string #'car) — both produce
  "#<FUNCTION #<CAR {id}> {id}>".
  - (let ((x (list 'a))) (let ((*print-circle* t))
(write-to-string (list x x)))) still produces
  "(#1=(A) #1#)" (regression guard for the five tests that
  a naive fix would have broken).

Compatibility

No public API change.

• Functions printed through pprint-fill / pprint-linear /
  pprint-tabular now match write-to-string (CLOS
  print-object wrapping). Callers that relied on the
  unwrapped #<FOO {id}> form will see the fuller
  #<FUNCTION #<FOO {id}> {id}> form.
• Nested pprint-logical-block now honours *print-circle*.
  Shared substructure that previously printed as duplicated
  literals will now print with #n= / #n# labels, as CLHS
  requires.