[armedbear-cvs] r13538 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Thu Aug 25 02:24:01 2011
New Revision: 13538

Log:
(partially) address ticket #165.

sbcl-buildhost gets much further, and the ANSI tests show no
additional failures, but still something is not quite right here.

N.B.  The test still doesn't succeed.

Modified:
   trunk/abcl/src/org/armedbear/lisp/format.lisp
   trunk/abcl/test/lisp/abcl/bugs.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/format.lisp	Wed Aug 24 01:49:56 2011	(r13537)
+++ trunk/abcl/src/org/armedbear/lisp/format.lisp	Thu Aug 25 02:24:01 2011	(r13538)
@@ -1073,7 +1073,9 @@
 	   (after (nthcdr (1+ posn) directives)))
       (values
        (expand-bind-defaults () params
-                             `(let ((stream (sys::make-case-frob-stream stream
+                             `(let ((stream (sys::make-case-frob-stream (if (typep stream 'xp::xp-structure)
+                                                                             (xp::base-stream stream)
+                                                                             stream)
                                                                         ,(if colonp
                                                                              (if atsignp
                                                                                  :upcase
@@ -2578,14 +2580,17 @@
                              (let* ((posn (position close directives))
                                     (before (subseq directives 0 posn))
                                     (after (nthcdr (1+ posn) directives))
-                                    (stream (sys::make-case-frob-stream stream
-                                                                        (if colonp
-                                                                            (if atsignp
-                                                                                :upcase
-                                                                                :capitalize)
-                                                                            (if atsignp
-                                                                                :capitalize-first
-                                                                                :downcase)))))
+                                    (stream (sys::make-case-frob-stream 
+                                             (if (typep stream 'xp::xp-structure)
+                                                 (xp::base-stream stream)
+                                                 stream)
+                                             (if colonp
+                                                 (if atsignp
+                                                     :upcase
+                                                     :capitalize)
+                                                 (if atsignp
+                                                     :capitalize-first
+                                                     :downcase)))))
                                (setf args (interpret-directive-list stream before orig-args args))
                                after))))
 

Modified: trunk/abcl/test/lisp/abcl/bugs.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/bugs.lisp	Wed Aug 24 01:49:56 2011	(r13537)
+++ trunk/abcl/test/lisp/abcl/bugs.lisp	Thu Aug 25 02:24:01 2011	(r13538)
@@ -82,4 +82,13 @@
                        (string (read-from-string "#:UPPER")))
           (readtable-case *readtable*) original-case)
     (values-list result))
-  "LOWER" "upper" "LOWER" "upper")
\ No newline at end of file
+  "LOWER" "upper" "LOWER" "upper")
+
+;;; http://trac.common-lisp.net/armedbear/ticket/165
+(deftest bugs.pprint.1
+    (let ((result (make-array '(0) :element-type 'base-char :fill-pointer t)))
+      (with-output-to-string (s result)
+        (pprint-logical-block (s nil :per-line-prefix "---") 
+          (format s "~(~A~)" '(1 2 3 4))))
+      result)
+  "---(1 2 3 4)")