Add gray-streams:stream-line-length extension

src/org/armedbear/lisp/boot.lisp

@@ -111,6 +111,13 @@
 
 (export 'charpos '#:extensions)
 
+;; Redefined in pprint.lisp and gray-streams.lisp
+(defun line-length (stream)
+  (declare (ignore stream))
+  (max 0 (or *print-right-margin* 80)))
+
+(export 'line-length '#:extensions)
+
 ;; Redefined in precompiler.lisp.
 (defun precompile (name &optional definition)
   (declare (ignore name definition))

src/org/armedbear/lisp/format.lisp

@@ -1552,7 +1552,7 @@
                         ,@(expand-directive-list (pop segments))))
                 ,(expand-bind-defaults
                   ((extra 0)
-                   (line-len '(or #-abcl(sb!impl::line-length stream) 72)))
+                   (line-len '(ext:line-length stream)))
                   (format-directive-params first-semi)
                   `(setf extra-space ,extra line-len ,line-len))))
           ,@(mapcar (lambda (segment)
@@ -2798,7 +2798,7 @@
              (when (and first-semi (format-directive-colonp first-semi))
                (interpret-bind-defaults
                 ((extra 0)
-                 (len (or #-abcl(sb!impl::line-length stream) 72)))
+                 (len (ext:line-length stream)))
                 (format-directive-params first-semi)
                 (setf newline-string
                       (with-output-to-string (stream)

src/org/armedbear/lisp/gray-streams.lisp

@@ -139,6 +139,7 @@
    "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
    "STREAM-WRITE-CHAR"
    "STREAM-LINE-COLUMN"
+   "STREAM-LINE-LENGTH"
    "STREAM-START-LINE-P"
    "STREAM-WRITE-STRING"
    "STREAM-TERPRI"
@@ -308,6 +309,7 @@
 (defgeneric stream-write-char (stream character))
 (defgeneric stream-line-column (stream))
 (defgeneric stream-start-line-p (stream))
+(defgeneric stream-line-length (stream))
 (defgeneric stream-write-string (stream string &optional start end))
 (defgeneric stream-terpri (stream))
 (defmethod stream-terpri (stream)
@@ -413,6 +415,13 @@
   (basic-write-sequence stream sequence start (or end (length sequence))
                         'signed-byte #'stream-write-byte))
 
+(defmethod stream-line-length (stream)
+  (declare (ignore stream))
+  nil)
+
+(defmethod stream-line-length ((stream xp::xp-structure))
+  (xp::line-length stream))
+
 (defun decode-read-arg (arg)
   (cond ((null arg) *standard-input*)
         ((eq arg t) *terminal-io*)
@@ -574,6 +583,13 @@
         nil ;(funcall *ansi-stream-column* stream)
         (stream-line-column stream))))
 
+(defun gray-line-length (stream)
+  (max 0
+       (or *print-right-margin*
+           (stream-line-length stream)
+           xp::*default-right-margin*
+           80)))
+
 (defmethod gray-stream-element-type (stream)
   (funcall *ansi-stream-element-type* stream))
 
@@ -678,6 +694,7 @@
 (setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
 (setf (symbol-function 'common-lisp::file-length) #'gray-file-length)
 (setf (symbol-function 'common-lisp::listen) #'gray-listen)
+(setf (symbol-function 'ext:line-length) #'gray-line-length)
 
 (dolist (e '((common-lisp::read-char gray-read-char)
              (common-lisp::peek-char gray-peek-char)

src/org/armedbear/lisp/pprint.lisp

@@ -64,9 +64,13 @@
 (defvar *print-shared* nil)
 (export '(*print-shared*))
 
-(defvar *default-right-margin* 70.
+(defvar *default-right-margin* 80
   "controls default line length; must be a non-negative integer")
 
+(defun ext:line-length (stream)
+  (declare (ignore stream))
+  (max 0 (or *print-right-margin* *default-right-margin* 80)))
+
 (defvar *current-level* 0
   "current depth in logical blocks.")
 (defvar *abbreviation-happened* nil
@@ -290,9 +294,7 @@
 
 (defun initialize-xp (xp stream)
   (setf (base-stream xp) stream)
-  (setf (line-length xp) (max 0 (cond (*print-right-margin*)
-                                      ((output-width stream))
-                                      (t *default-right-margin*))))
+  (setf (line-length xp) (ext:line-length stream))
   (setf (line-limit xp) *print-lines*)
   (setf (line-no xp) 1)
   (setf (depth-in-blocks xp) 0)