]> birchwood-abbey.net Git - mit-scheme.git/commitdiff
Fix pretty-printer highlights.
authorTaylor R Campbell <campbell+mit-scheme@mumble.net>
Tue, 7 Jul 2020 15:17:39 +0000 (15:17 +0000)
committerTaylor R Campbell <campbell+mit-scheme@mumble.net>
Tue, 7 Jul 2020 15:32:08 +0000 (15:32 +0000)
Apparently I broke these back in 2018 when teaching pp to handle
custom print methods, oops.

(cherry picked from commit aa9a60a6203f951050e3ef0050035c41a6da33fd)

src/runtime/pp.scm

index 1bf05cd62347836af60d2fd18c5fde19f988cdfa..575d91449c69f74c160e72c6255879257b823c25 100644 (file)
@@ -748,7 +748,17 @@ USA.
 
 (define (numerical-walk object list-depth)
   (define (numerical-walk-no-auto-highlight object list-depth)
-    (cond ((get-print-method object)
+    (cond ((pretty-printer-highlight? object)
+          ;; (1) see note below.
+          (let ((rest (walk-highlighted-object
+                       object list-depth
+                       numerical-walk-no-auto-highlight)))
+            (make-highlighted-node (+ (pph/start-string-length object)
+                                      (pph/end-string-length object)
+                                      (node-size rest))
+                                   object
+                                   rest)))
+         ((get-print-method object)
           (walk-custom object list-depth))
          ((and (pair? object)
                (not (named-list? object)))
@@ -763,16 +773,6 @@ USA.
                   (interned-symbol? object))
               object
               (walk-custom object list-depth)))
-         ((pretty-printer-highlight? object)
-          ;; (1) see note below.
-          (let ((rest (walk-highlighted-object
-                       object list-depth
-                       numerical-walk-no-auto-highlight)))
-            (make-highlighted-node (+ (pph/start-string-length object)
-                                      (pph/end-string-length object)
-                                      (node-size rest))
-                                   object
-                                   rest)))
          ((and (vector? object)
                (not (named-vector? object)))
           (if (zero? (vector-length object))