From 55f1c569f20280bde039242793b0126ae30809bf Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Thu, 1 Feb 2018 16:43:09 +0300
Subject: [PATCH] debug-dump, compact-vector: special case strings.

Treat them as singleton objects.
---
 src/code/debug-int.lisp      | 12 ++++++++----
 src/compiler/debug-dump.lisp |  3 ++-
 2 files changed, 10 insertions(+), 5 deletions(-)

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 370d7aa7b..6023fa047 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -1515,6 +1515,9 @@ register."
   (typecase vector
     (simple-vector
      (svref vector index))
+    (string
+     (aver (zerop index))
+     vector)
     (vector
      (aref vector index))
     (t
@@ -1523,6 +1526,8 @@ register."
 
 (defun compact-vector-length (vector)
   (typecase vector
+    (string
+     1)
     (vector
      (length vector))
     (t
@@ -1960,10 +1965,9 @@ register."
                 (compiled-code-location-context code-location))))
             (t context)))))
 
-(defun error-context ()
-  (let ((frame sb!debug:*stack-top-hint*))
-    (when frame
-      (code-location-context (frame-code-location frame)))))
+(defun error-context (&optional (frame sb!debug:*stack-top-hint*))
+  (when frame
+    (code-location-context (frame-code-location frame))))
 
 (defun decode-arithmetic-error-operands (context)
   (let* ((alien-context (sb!alien:sap-alien context (* os-context-t)))
diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index e4bfe5804..d467e902d 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -335,7 +335,8 @@
 
 (defun compact-vector (sequence)
   (cond ((and (= (length sequence) 1)
-              (not (vectorp (elt sequence 0))))
+              (not (typep (elt sequence 0) '(and vector
+                                             (not string)))))
          (elt sequence 0))
         (t
          (coerce-to-smallest-eltype sequence))))
-- 
2.11.4.GIT