Changeset 13538 for trunk/abcl/src/org/armedbear/lisp/format.lisp

Timestamp:

08/25/11 09:24:01 (11 years ago)

Author:

Mark Evenson

Message:

(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.

File:

• trunk/abcl/src/org/armedbear/lisp/format.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/format.lisp

@@ -1074 +1074 @@
       (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
@@ -2579 +2581 @@
                                     (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))))