From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 18 May 2012 19:42:17 +0000 (+0300)
Subject: COMPILED-PROGRAM-ERROR source form needs *PRINT-ESCAPE*
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bb9b382751d808c76592ce2484c33f8447db6568;p=sbcl.git

COMPILED-PROGRAM-ERROR source form needs *PRINT-ESCAPE*

  PRINC-TO-STRING is not what we want here.
---

diff --git a/NEWS b/NEWS
index 0acdd06..9513f4f 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@ changes relative to sbcl-1.0.57:
     updates of CAS-able places (similar to Clojure's swap!).
   * bug fix: potential for infinite recursion during compilation of CLOS slot
     typechecks when dependency graph had loops. (lp#1001799)
+  * bug fix: error forms reported with some program-errors were not escaped
+    properly.
 
 changes in sbcl-1.0.57 relative to sbcl-1.0.56:
   * RANDOM enhancements and bug fixes:
diff --git a/src/compiler/compiler-error.lisp b/src/compiler/compiler-error.lisp
index f3b5426..4316041 100644
--- a/src/compiler/compiler-error.lisp
+++ b/src/compiler/compiler-error.lisp
@@ -108,10 +108,15 @@
   (apply #'style-warn datum arguments)
   (values))
 
+(defun source-to-string (source)
+  (write-to-string source
+                   :escape t :readably nil :pretty t
+                   :circle t :array nil))
+
 (defun make-compiler-error-form (condition source)
   `(error 'compiled-program-error
           :message ,(princ-to-string condition)
-          :source ,(princ-to-string source)))
+          :source ,(source-to-string source)))
 
 ;;; Fatal compiler errors. We export FATAL-COMPILER-ERROR as an
 ;;; interface for errors that kill the compiler dead
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 780b3d2..cd14e50 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4274,3 +4274,11 @@
 
 (with-test (:name :malformed-type-declaraions)
   (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
+
+(with-test (:name :compiled-program-error-escaped-source)
+  (assert
+   (handler-case
+       (funcall (compile nil `(lambda () (lambda ("foo")))))
+     (sb-int:compiled-program-error (e)
+       (let ((source (read-from-string (sb-kernel::program-error-source e))))
+         (equal source '#'(lambda ("foo"))))))))