From 0bc2d6ca22c988d65e37108afbb433e29689a528 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 30 Nov 2003 17:11:05 +0000 Subject: [PATCH] 0.8.6.20: Merge simple-streams patch (David Licteblau sbcl-devel 2003-11-09) ... including frobs to core code to unspecial-case Gray streams --- NEWS | 3 + contrib/sb-simple-streams/impl.lisp | 34 ----------- contrib/sb-simple-streams/internal.lisp | 8 ++- contrib/sb-simple-streams/package.lisp | 2 +- src/code/reader.lisp | 20 +++---- src/code/stream.lisp | 97 +++++++++++++++---------------- version.lisp-expr | 2 +- 7 files changed, 69 insertions(+), 97 deletions(-) diff --git a/NEWS b/NEWS index 1f832e6..9003e89 100644 --- a/NEWS +++ b/NEWS @@ -2204,6 +2204,9 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6: Moellmann) * ASDF-INSTALL bug fix: now parses *PROXY* properly. (thanks to Sean Ross) + * SB-SIMPLE-STREAMS enhancement: simple-streams can now be used as + streams for the REPL, for the debugger, and so on. (thanks to + David Licteblau) * fixed some bugs revealed by Paul Dietz' test suite: ** the value of the :REHASH-THRESHOLD argument to MAKE-HASH-TABLE is ignored if it is too small, rather than propagating through diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index 35c316a..2657fb1 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -1305,37 +1305,3 @@ t) (t (sb-impl::fd-stream-pathname stream)))))) - -;;; bugfix - -;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or -;;; remove it. -#+nil -(defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2) - (declare (type fundamental-stream stream) ;; this is a lie - (ignore arg2)) - (case operation - (:listen - (ext:stream-listen stream)) - (:unread - (ext:stream-unread-char stream arg1)) - (:close - (close stream)) - (:clear-input - (ext:stream-clear-input stream)) - (:force-output - (ext:stream-force-output stream)) - (:finish-output - (ext:stream-finish-output stream)) - (:element-type - (stream-element-type stream)) - (:interactive-p - (interactive-stream-p stream)) - (:line-length - (ext:stream-line-length stream)) - (:charpos - (ext:stream-line-column stream)) - (:file-length - (file-length stream)) - (:file-position - (file-position stream arg1)))) diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp index 154abdc..ea5309a 100644 --- a/contrib/sb-simple-streams/internal.lisp +++ b/contrib/sb-simple-streams/internal.lisp @@ -83,7 +83,13 @@ (defun std-dc-newline-in-handler (stream character) (with-stream-class (dual-channel-simple-stream stream) - (setf (sm charpos stream) -1) ;; set to 0 "if reading" ??? + ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect + ;; a result in (or null (and fixnum unsigned-byte)), so they must + ;; never see this temporary value. Note that in + ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS + ;; is incremented to zero before WRITE-CHAR returns. Perhaps the + ;; same should happen for input? + (setf (sm charpos stream) 0) ; was -1 character)) (defvar *std-control-out-table* diff --git a/contrib/sb-simple-streams/package.lisp b/contrib/sb-simple-streams/package.lisp index eac4c53..622fb5c 100644 --- a/contrib/sb-simple-streams/package.lisp +++ b/contrib/sb-simple-streams/package.lisp @@ -9,7 +9,7 @@ (defpackage sb-simple-streams (:use #:common-lisp) - (:import-from #:sb-kernel #:ansi-stream) + (:import-from #:sb-kernel #:ansi-stream #:charpos #:line-length) (:import-from #:sb-gray #:fundamental-stream) (:export ;; Stream classes #:STREAM diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 3ec1059..92d8ee4 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -256,9 +256,9 @@ +char-attr-whitespace+) (done-with-fast-read-char) char))) - ;; fundamental-stream + ;; CLOS stream (do ((attribute-table (character-attribute-table *readtable*)) - (char (stream-read-char stream) (stream-read-char stream))) + (char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (/= (the fixnum (aref attribute-table (char-code char))) +char-attr-whitespace+)) @@ -483,8 +483,8 @@ (fast-read-char nil nil))) ((or (not char) (char= char #\newline)) (done-with-fast-read-char)))) - ;; FUNDAMENTAL-STREAM - (do ((char (stream-read-char stream) (stream-read-char stream))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char #\newline)))))) ;; Don't return anything. (values)) @@ -547,13 +547,13 @@ (done-with-fast-read-char)) (if (escapep char) (setq char (fast-read-char t))) (ouch-read-buffer char))) - ;; FUNDAMENTAL-STREAM - (do ((char (stream-read-char stream) (stream-read-char stream))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char closech)) (if (eq char :eof) (error 'end-of-file :stream stream))) (when (escapep char) - (setq char (stream-read-char stream)) + (setq char (read-char stream nil :eof)) (if (eq char :eof) (error 'end-of-file :stream stream))) (ouch-read-buffer char)))) @@ -927,15 +927,15 @@ (#.+char-attr-package-delimiter+ (done-with-fast-read-char) (go COLON)) (t (go SYMBOL-LOOP))))) - ;; fundamental-stream + ;; CLOS stream (prog () SYMBOL-LOOP (ouch-read-buffer char) - (setq char (stream-read-char stream)) + (setq char (read-char stream nil :eof)) (when (eq char :eof) (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.+char-attr-escape+ (go ESCAPE)) - (#.+char-attr-delimiter+ (stream-unread-char stream char) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 7318035..e5296c8 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -559,6 +559,12 @@ (t ; must be Gray streams FUNDAMENTAL-STREAM (stream-write-string stream string start end))))) +;;; A wrapper function for all those (MACROLET OUT-FUN) definitions, +;;; which cannot deal with keyword arguments. +(declaim (inline write-string-no-key)) +(defun write-string-no-key (string stream start end) + (write-string string stream :start start :end end)) + (defun write-line (string &optional (stream *standard-output*) &key (start 0) end) (declare (type string string)) @@ -597,37 +603,43 @@ (stream-write-byte integer)) integer) + +;;; (These were inline throughout this file, but that's not appropriate +;;; globally. And we must not inline them in the rest of this file if +;;; dispatch to gray or simple streams is to work, since both redefine +;;; these functions later.) +(declaim (maybe-inline read-char unread-char read-byte listen)) + ;;; This is called from ANSI-STREAM routines that encapsulate CLOS ;;; streams to handle the misc routines and dispatch to the -;;; appropriate Gray stream functions. +;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions. (defun stream-misc-dispatch (stream operation &optional arg1 arg2) - (declare (type fundamental-stream stream) - (ignore arg2)) - (case operation + (declare (type stream stream) (ignore arg2)) + (ecase operation (:listen ;; Return T if input available, :EOF for end-of-file, otherwise NIL. - (let ((char (stream-read-char-no-hang stream))) + (let ((char (read-char-no-hang stream nil :eof))) (when (characterp char) - (stream-unread-char stream char)) + (unread-char char stream)) char)) (:unread - (stream-unread-char stream arg1)) + (unread-char arg1 stream)) (:close (close stream)) (:clear-input - (stream-clear-input stream)) + (clear-input stream)) (:force-output - (stream-force-output stream)) + (force-output stream)) (:finish-output - (stream-finish-output stream)) + (finish-output stream)) (:element-type (stream-element-type stream)) (:interactive-p (interactive-stream-p stream)) (:line-length - (stream-line-length stream)) + (line-length stream)) (:charpos - (stream-line-column stream)) + (charpos stream)) (:file-length (file-length stream)) (:file-position @@ -657,16 +669,13 @@ :expected-type '(satisfies output-stream-p)))) (apply #'%make-broadcast-stream streams)) -(macrolet ((out-fun (fun method stream-method &rest args) - `(defun ,fun (stream ,@args) +(macrolet ((out-fun (name fun &rest args) + `(defun ,name (stream ,@args) (dolist (stream (broadcast-stream-streams stream)) - (if (ansi-stream-p stream) - (funcall (,method stream) stream ,@args) - (,stream-method stream ,@args)))))) - (out-fun broadcast-out ansi-stream-out stream-write-char char) - (out-fun broadcast-bout ansi-stream-bout stream-write-byte byte) - (out-fun broadcast-sout ansi-stream-sout stream-write-string - string start end)) + (,fun ,(car args) stream ,@(cdr args)))))) + (out-fun broadcast-out write-char char) + (out-fun broadcast-bout write-byte byte) + (out-fun broadcast-sout write-string-no-key string start end)) (defun broadcast-misc (stream operation &optional arg1 arg2) (let ((streams (broadcast-stream-streams stream))) @@ -712,18 +721,16 @@ (print-unreadable-object (x stream :type t :identity t) (format stream ":SYMBOL ~S" (synonym-stream-symbol x)))) -;;; The output simple output methods just call the corresponding method -;;; in the synonymed stream. -(macrolet ((out-fun (name slot stream-method &rest args) +;;; The output simple output methods just call the corresponding +;;; function on the synonymed stream. +(macrolet ((out-fun (name fun &rest args) `(defun ,name (stream ,@args) (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (if (ansi-stream-p syn) - (funcall (,slot syn) syn ,@args) - (,stream-method syn ,@args)))))) - (out-fun synonym-out ansi-stream-out stream-write-char ch) - (out-fun synonym-bout ansi-stream-bout stream-write-byte n) - (out-fun synonym-sout ansi-stream-sout stream-write-string string start end)) + (,fun ,(car args) syn ,@(cdr args)))))) + (out-fun synonym-out write-char ch) + (out-fun synonym-bout write-byte n) + (out-fun synonym-sout write-string-no-key string start end)) ;;; For the input methods, we just call the corresponding function on the ;;; synonymed stream. These functions deal with getting input out of @@ -794,15 +801,13 @@ :expected-type '(satisfies input-stream-p))) (funcall #'%make-two-way-stream input-stream output-stream)) -(macrolet ((out-fun (name slot stream-method &rest args) +(macrolet ((out-fun (name fun &rest args) `(defun ,name (stream ,@args) (let ((syn (two-way-stream-output-stream stream))) - (if (ansi-stream-p syn) - (funcall (,slot syn) syn ,@args) - (,stream-method syn ,@args)))))) - (out-fun two-way-out ansi-stream-out stream-write-char ch) - (out-fun two-way-bout ansi-stream-bout stream-write-byte n) - (out-fun two-way-sout ansi-stream-sout stream-write-string string start end)) + (,fun ,(car args) syn ,@(cdr args)))))) + (out-fun two-way-out write-char ch) + (out-fun two-way-bout write-byte n) + (out-fun two-way-sout write-string-no-key string start end)) (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) @@ -989,20 +994,16 @@ :expected-type '(satisfies input-stream-p))) (funcall #'%make-echo-stream input-stream output-stream)) -(macrolet ((in-fun (name fun out-slot stream-method &rest args) +(macrolet ((in-fun (name in-fun out-fun &rest args) `(defun ,name (stream ,@args) (or (pop (echo-stream-unread-stuff stream)) (let* ((in (echo-stream-input-stream stream)) (out (echo-stream-output-stream stream)) - (result (,fun in ,@args))) - (if (ansi-stream-p out) - (funcall (,out-slot out) out result) - (,stream-method out result)) + (result (,in-fun in ,@args))) + (,out-fun result out) result))))) - (in-fun echo-in read-char ansi-stream-out stream-write-char - eof-error-p eof-value) - (in-fun echo-bin read-byte ansi-stream-bout stream-write-byte - eof-error-p eof-value)) + (in-fun echo-in read-char write-char eof-error-p eof-value) + (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) (defun echo-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) @@ -1866,7 +1867,3 @@ (funcall write-function (aref seq i) stream))))))) ;;;; etc. - -;;; (These were inline throughout this file, but that's not appropriate -;;; globally.) -(declaim (maybe-inline read-char unread-char read-byte listen)) diff --git a/version.lisp-expr b/version.lisp-expr index 4c8bcc8..f1f2a56 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.6.19" +"0.8.6.20" -- 1.7.10.4