Changeset 13387

Timestamp:

Jan 14, 2010, 8:49:15 AM (11 years ago)

Author:

gb

Message:

Propagate r13368 to 1.4. See ticket:642 .

Location:

release/1.4/source

Files:

• level-1/l1-readloop-lds.lisp (modified) (1 diff)
• level-1/l1-streams.lisp (modified) (4 diffs)
• lib/streams.lisp (modified) (1 diff)

release/1.4/source/level-1/l1-readloop-lds.lisp

@@ -555 +555 @@
         (*print-right-margin* nil)
         (*signal-printing-errors* nil)
-        (s (make-indenting-string-output-stream prefixchar nil)))
+        (s (make-indenting-string-output-stream prefixchar nil))
+        (sub (make-string-output-stream))
+        (indent 0))
     (format s "~A ~A: " prefixchar msg)
-    (setf (indenting-string-output-stream-indent s) (column s))
+    (setf (indenting-string-output-stream-indent s) (setq indent (column s)))
+    (decf (stream-line-length sub) indent)
     ;(format s "~A" condition) ; evil if circle
-    (report-condition condition s)
+    (report-condition condition sub)
+    (format s "~A" (get-output-stream-string sub))
     (if (not (and (typep condition 'simple-program-error)
                   (simple-program-error-context condition)))

release/1.4/source/level-1/l1-streams.lisp

@@ -2474 +2474 @@
       (if (eq b :eof)
         (return (- i start)))
-      (setf (uvref vector i) b)
+      (setf (aref vector i) b)
       (incf i)
       (decf need)
@@ -4236 +4236 @@
 (defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
   (index 0)
-  freelist)
+  freelist
+  (line-length 80))
 
 (defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
@@ -4253 +4254 @@
 (defmethod stream-clear-output ((s string-output-stream))
   nil)
+
+(defmethod stream-line-length ((s string-output-stream))
+  (let* ((ioblock (basic-stream-ioblock s)))
+    (string-output-stream-ioblock-line-length ioblock)))
+
+(defmethod (setf stream-line-length) (newlen (s string-output-stream))
+  (let* ((ioblock (basic-stream-ioblock s)))
+    (setf (string-output-stream-ioblock-line-length ioblock) newlen)))
+
 
 ;;; Should only be used for a stream whose class is exactly
@@ -4290 +4300 @@
                                    (ioblock-device data) -1
                                    (ioblock-charpos data) 0
-                                   (string-output-stream-ioblock-index data) 0))
+                                   (string-output-stream-ioblock-index data) 0
+                                   (string-output-stream-ioblock-line-length data) 80))
                            data)))))
     (or recycled (apply #'make-string-output-stream-ioblock keys))))

release/1.4/source/lib/streams.lisp

@@ -131 +131 @@
 
 (defun line-length (stream)
-  (declare (ignore stream))
-  80)
+  (or (stream-line-length stream) 80))
 
 (defun write-byte (byte stream)