[Openmcl-cvs-notifications] r9886 - in /trunk/source/level-1: l1-io.lisp l1-streams.lisp
gz at clozure.com
gz at clozure.com
Wed Jul 2 17:07:06 EDT 2008
Author: gz
Date: Wed Jul 2 17:07:05 2008
New Revision: 9886
Log:
Propagate 9408 from working-0711 to trunk
Modified:
trunk/source/level-1/l1-io.lisp
trunk/source/level-1/l1-streams.lisp
Modified: trunk/source/level-1/l1-io.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-io.lisp (original)
+++ trunk/source/level-1/l1-io.lisp Wed Jul 2 17:07:05 2008
@@ -29,12 +29,20 @@
;;;; Standard CL IO frobs
=
=
+(declaim (inline %real-print-stream))
+(defun %real-print-stream (&optional (stream nil))
+ (cond ((null stream)
+ *standard-output*)
+ ((eq stream t)
+ *terminal-io*)
+ (t stream)))
+
;;; OK, EOFP isn't CL ...
(defun eofp (&optional (stream *standard-input*))
(stream-eofp stream))
=
(defun force-output (&optional stream)
- (stream-force-output (real-print-stream stream))
+ (stream-force-output (%real-print-stream stream))
nil)
=
(defun listen (&optional (stream *standard-input*))
@@ -44,8 +52,11 @@
(defun fresh-line (&optional (output-stream *standard-output*))
"Output #\Newline only if the OUTPUT-STREAM is not already at the
start of a line. Return T if #\Newline needed."
- (stream-fresh-line (real-print-stream output-stream)))
-
+ (stream-fresh-line (%real-print-stream output-stream)))
+
+(defun column (&optional stream)
+ (let* ((stream (%real-print-stream stream)))
+ (stream-line-column stream)))
=
(defun clear-input (&optional input-stream)
"Clear any available input from INPUT-STREAM."
@@ -54,18 +65,18 @@
=
(defun write-char (char &optional (output-stream nil))
"Output CHAR to OUTPUT-STREAM."
- (let* ((stream (real-print-stream output-stream)))
+ (let* ((stream (%real-print-stream output-stream)))
(if (typep stream 'basic-stream)
(let* ((ioblock (basic-stream-ioblock stream)))
(funcall (ioblock-write-char-function ioblock) ioblock char))
- (stream-write-char (real-print-stream output-stream) char))
+ (stream-write-char stream char))
char))
=
(defun write-string (string &optional output-stream &key (start 0 start-p)
(end nil end-p))
"Write the characters of the subsequence of STRING bounded by START
and END to OUTPUT-STREAM."
- (let* ((stream (real-print-stream output-stream)))
+ (let* ((stream (%real-print-stream output-stream)))
(if (typep stream 'basic-stream)
(let* ((ioblock (basic-stream-ioblock stream)))
(with-ioblock-output-locked (ioblock) =
@@ -94,17 +105,16 @@
&key (start 0) (end (length string)))
"Write the characters of the subsequence of STRING bounded by START
and END to OUTPUT-STREAM then output a #\Newline at end."
- (let ((stream (real-print-stream output-stream)))
- (write-string string stream :start start :end end)
- (terpri stream)
- string))
+ (write-string string output-stream :start start :end end)
+ (terpri output-stream)
+ string)
=
(defun terpri (&optional (stream *standard-output*))
- (let* ((stream (real-print-stream stream)))
+ (let* ((stream (%real-print-stream stream)))
(if (typep stream 'basic-stream)
(let* ((ioblock (basic-stream-ioblock stream)))
(funcall (ioblock-write-char-function ioblock) ioblock #\newline))
- (stream-write-char (real-print-stream stream) #\newline))
+ (stream-write-char stream #\newline))
nil))
=
;;;; ----------------------------------------------------------------------
@@ -688,7 +698,7 @@
(defun print-a-float (float stream &optional exp-p nanning)
(let ((strlen 0) (exponent-char (float-exponent-char float)))
(declare (fixnum strlen))
- (setq stream (real-print-stream stream))
+ (setq stream (%real-print-stream stream))
(if (and (not nanning)(nan-or-infinity-p float))
(print-a-nan float stream) =
(multiple-value-bind (string before-pt #|after-pt|#)
@@ -1673,13 +1683,14 @@
*terminal-io*)
((streamp stream)
stream)
+ ;; This never gets called because streamp is true for xp-structure=
...
((istruct-typep stream 'xp-structure)
(get-xp-stream stream))
(t
(report-bad-arg stream '(or stream (member nil t))))))
=
(defun write-1 (object stream &optional levels-left)
- (setq stream (real-print-stream stream))
+ (setq stream (%real-print-stream stream))
(when (not levels-left)
(setq levels-left
(if *current-level* =
@@ -1820,7 +1831,6 @@
(defun print (object &optional stream)
"Output a newline, the mostly READable printed representation of OBJECT,=
and
space to the specified STREAM."
- (setq stream (real-print-stream stream))
(terpri stream)
(let ((*print-escape* t))
(write-1 object stream))
Modified: trunk/source/level-1/l1-streams.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-streams.lisp (original)
+++ trunk/source/level-1/l1-streams.lisp Wed Jul 2 17:07:05 2008
@@ -101,6 +101,9 @@
(report-bad-arg x 'stream))
=
(defmethod stream-element-type ((x t))
+ (report-bad-arg x 'stream))
+
+(defmethod stream-force-output ((x t))
(report-bad-arg x 'stream))
=
(defmethod stream-position ((s stream) &optional newpos)
@@ -3267,7 +3270,7 @@
&allow-other-keys)
(declare (dynamic-extent initargs))
(let* ((s
- (if (subtypep class (find-class 'basic-stream))
+ (if (subtypep class 'basic-stream)
(apply #'make-basic-stream-instance class :allow-other-keys t =
initargs)
(apply #'make-instance class :allow-other-keys t initargs))))
(apply #'init-stream-ioblock s initargs)
@@ -3306,7 +3309,7 @@
(:pipe (#_fpathconf fd #$_PC_PIPE_BUF))
(:socket
#+linux-target nominal
- #-linux-target =
+ #-linux-target
(int-getsockopt fd #$SOL_SOCKET #$SO_SNDLOWAT))
((:character-special :tty) (#_fpathconf fd #$_PC_MAX_IN=
PUT))
(t nominal))))
@@ -3729,10 +3732,6 @@
=
=
=
-
-
-
-
(defun stream-is-closed (s)
(error "~s is closed" s))
=
@@ -4341,7 +4340,7 @@
(setf (ioblock-charpos ioblock) 0)
(incf (ioblock-charpos ioblock)))
(if (=3D index len)
- (let* ((newlen (+ len len)) ;non-zero !
+ (let* ((newlen (if (zerop len) 20 (+ len len))) ;non-zero !
(new (make-string newlen)))
(%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2)))
(setq string new)
@@ -4806,7 +4805,6 @@
(let* ((ioblock (stream-ioblock stream nil)))
(when ioblock
(%ioblock-close ioblock))))
-
=
(defmethod close :before ((stream buffered-output-stream-mixin) &key abort)
(unless abort
@@ -5591,7 +5589,7 @@
'selection-input-stream
(error "Can't create that type of stream.")))
=
-(defun make-selection-input-stream (fd &key peer-fd encoding)
+(defun make-selection-input-stream (fd &key peer-fd encoding)
(let* ((s (make-fd-stream fd
:class 'selection-input-stream
:sharing :lock
@@ -5760,7 +5758,7 @@
(shared-resource
(if (typep stream 'two-way-stream)
(input-stream-shared-resource
- (two-way-stream-input-stream *terminal-io*)))))
+ (two-way-stream-input-stream stream)))))
(when shared-resource (%yield-shared-resource shared-resource process)=
)))
=
(defun %restore-terminal-input (&optional took-it)
@@ -5850,10 +5848,6 @@
(or last-form-in-selection *verbose-eval-selection*))))))
=
=
-(defun column (&optional stream)
- (let* ((stream (real-print-stream stream)))
- (stream-line-column stream))) =
-
(defun (setf %ioblock-external-format) (ef ioblock)
(let* ((encoding (get-character-encoding (external-format-character-enco=
ding ef)))
(line-termination (external-format-line-termination ef)))
More information about the Openmcl-cvs-notifications
mailing list