[armedbear-cvs] r12809 - trunk/abcl/src/org/armedbear/lisp

[Mark Evenson]

Author: mevenson
Date: Sat Jul 17 06:26:26 2010
New Revision: 12809

Log:
Honor *PRINT-READABLY* by throwing PRINT-NOT-READABLE for "#<".

Previously, if *PRINT-READABLY* was non-NIL, a string containing "#<"
would be output without signalling a PRINT-NOT-READABLE condition as
required by ANSI.



Modified:
   trunk/abcl/src/org/armedbear/lisp/Primitives.java
   trunk/abcl/src/org/armedbear/lisp/print.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Sat Jul 17 06:26:26 2010
@@ -890,7 +890,16 @@
                 out = Symbol.STANDARD_OUTPUT.symbolValue();
             else
                 out = second;
-            checkStream(out)._writeString(first.writeToString());
+            String output = first.writeToString();
+            if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL
+                && output.contains("#<")) {
+                LispObject args = NIL;
+                args = args.push(first);
+                args = args.push(Keyword.OBJECT);
+                args = args.nreverse();
+                return error(new PrintNotReadable(args));
+            }
+            checkStream(out)._writeString(output);
             return first;
         }
     };

Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/print.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/print.lisp	Sat Jul 17 06:26:26 2010
@@ -280,6 +280,10 @@
 	   (symbol-package x))))
 
 (defun %print-object (object stream)
+  (when (and *print-readably* 
+             (typep object 'string)
+             (search "#<" object))
+    (error 'print-not-readable :object object))
   (if *print-pretty*
       (xp::output-pretty-object object stream)
       (output-ugly-object object stream)))