X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=63b3fa382f733ffd992d20450553a39d1b9880fe;hb=c47519c9e63fd32a635943a84ec13d8a60d95f08;hp=fb7c2427d655afe025006d71e6ab02cf8b39c0c5;hpb=954902abeb19dac4f79f0a5b800eac45179b8d7c;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index fb7c242..63b3fa3 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -277,85 +277,6 @@ (stream-unread-char stream character))) nil) - -;;; In the interest of ``once and only once'' this macro contains the -;;; framework necessary to implement a peek-char function, which has -;;; two special-cases (one for gray streams and one for echo streams) -;;; in addition to the normal case. -;;; -;;; All arguments are forms which will be used for a specific purpose -;;; PEEK-TYPE - the current peek-type as defined by ANSI CL -;;; EOF-VALUE - the eof-value argument to peek-char -;;; CHAR-VAR - the variable which will be used to store the current character -;;; READ-FORM - the form which will be used to read a character -;;; UNREAD-FORM - ditto for unread-char -;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character -;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected -;;; (this will default to CHAR-VAR) -(defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form &optional (skipped-char-form nil) (eof-detected-form nil)) - `(let ((,char-var ,read-form)) - (cond ((eql ,char-var ,eof-value) - ,(if eof-detected-form - eof-detected-form - char-var)) - ((characterp ,peek-type) - (do ((,char-var ,char-var ,read-form)) - ((or (eql ,char-var ,eof-value) - (char= ,char-var ,peek-type)) - (cond ((eql ,char-var ,eof-value) - ,(if eof-detected-form - eof-detected-form - char-var)) - (t ,unread-form - ,char-var))) - ,skipped-char-form)) - ((eql ,peek-type t) - (do ((,char-var ,char-var ,read-form)) - ((or (eql ,char-var ,eof-value) - (not (whitespace-char-p ,char-var))) - (cond ((eql ,char-var ,eof-value) - ,(if eof-detected-form - eof-detected-form - char-var)) - (t ,unread-form - ,char-var))) - ,skipped-char-form)) - ((null ,peek-type) - ,unread-form - ,char-var) - (t - (bug "Impossible case reached in PEEK-CHAR"))))) - -(defun peek-char (&optional (peek-type nil) - (stream *standard-input*) - (eof-error-p t) - eof-value - recursive-p) - (declare (ignore recursive-p)) - (let ((stream (in-synonym-of stream))) - (cond ((typep stream 'echo-stream) - (echo-misc stream - :peek-char - peek-type - (list eof-error-p eof-value))) - ((ansi-stream-p stream) - (generalized-peeking-mechanism - peek-type eof-value char - (read-char stream eof-error-p eof-value) - (unread-char char stream))) - (t - ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM - (generalized-peeking-mechanism - peek-type :eof char - (if (null peek-type) - (stream-peek-char stream) - (stream-read-char stream)) - (if (null peek-type) - () - (stream-unread-char stream char)) - () - (eof-or-lose stream eof-error-p eof-value)))))) - (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) @@ -559,6 +480,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 +524,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 +590,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 +642,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 +722,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,82 +915,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)) - -(defun echo-misc (stream operation &optional arg1 arg2) - (let* ((in (two-way-stream-input-stream stream)) - (out (two-way-stream-output-stream stream))) - (case operation - (:listen - (or (not (null (echo-stream-unread-stuff stream))) - (if (ansi-stream-p in) - (or (/= (the fixnum (ansi-stream-in-index in)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc in) in :listen)) - (stream-misc-dispatch in :listen)))) - (:unread (push arg1 (echo-stream-unread-stuff stream))) - (:element-type - (let ((in-type (stream-element-type in)) - (out-type (stream-element-type out))) - (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) - (:close - (set-closed-flame stream)) - (:peek-char - ;; For the special case of peeking into an echo-stream - ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE) - ;; returns peeked-char, eof-value, or errors end-of-file - ;; - ;; Note: This code could be moved into PEEK-CHAR if desired. - ;; I am unsure whether this belongs with echo-streams because it is - ;; echo-stream specific, or PEEK-CHAR because it is peeking code. - ;; -- mrd 2002-11-18 - ;; - ;; UNREAD-CHAR-P indicates whether the current character was one - ;; that was previously unread. In that case, we need to ensure that - ;; the semantics for UNREAD-CHAR are held; the character should - ;; not be echoed again. - (let ((unread-char-p nil)) - (flet ((outfn (c) - (unless unread-char-p - (if (ansi-stream-p out) - (funcall (ansi-stream-out out) out c) - ;; gray-stream - (stream-write-char out c)))) - (infn () - ;; Obtain input from unread buffer or input stream, - ;; and set the flag appropriately. - (cond ((not (null (echo-stream-unread-stuff stream))) - (setf unread-char-p t) - (pop (echo-stream-unread-stuff stream))) - (t - (setf unread-char-p nil) - (read-char in (first arg2) (second arg2)))))) - (generalized-peeking-mechanism - arg1 (second arg2) char - (infn) - (unread-char char in) - (outfn char))))) - (t - (or (if (ansi-stream-p in) - (funcall (ansi-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2)) - (if (ansi-stream-p out) - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))))))) + (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)) ;;;; base STRING-STREAM stuff @@ -1085,7 +945,7 @@ (defstruct (string-input-stream (:include string-stream (in #'string-inch) - (bin #'string-binch) + (bin #'ill-bin) (n-bin #'string-stream-read-n-bytes) (misc #'string-in-misc) (string (missing-arg) :type simple-string)) @@ -1223,7 +1083,9 @@ (defun string-sout (stream string start end) (declare (type simple-string string) (type fixnum start end)) - (let* ((string (coerce string '(simple-array character (*)))) + (let* ((string (if (typep string '(simple-array character (*))) + string + (coerce string '(simple-array character (*))))) (current (string-output-stream-index stream)) (length (- end start)) (dst-end (+ length current)) @@ -1866,7 +1728,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))