source: branches/qres/ccl/lib/streams.lisp @ 14172

Last change on this file since 14172 was 14049, checked in by gz, 9 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18; streams.lisp
19;;;General io-functions
20
21(in-package "CCL")
22
23(eval-when (:execute :compile-toplevel)
24  (require :level-2)
25  (require :streams)
26  (require :backquote)
27
28  )
29
30
31
32
33
34
35(defun read-line (&optional input-stream (eof-error-p t) eof-value recursive-p)
36 
37  (declare (ignore recursive-p)
38           (optimize (speed 3)))
39  (let* ((input-stream (designated-input-stream input-stream)))
40    (multiple-value-bind (string eof)
41        (if (typep input-stream 'basic-stream)
42          (let* ((ioblock (basic-stream-ioblock input-stream)))
43            (with-ioblock-input-locked (ioblock)
44               (funcall (ioblock-read-line-function ioblock) ioblock)))
45          (stream-read-line input-stream))
46      (if eof
47        (if (= (length string) 0)
48          (if eof-error-p
49            (signal-eof-error input-stream)
50            (values eof-value t))
51          (values string t))
52        (values string nil)))))
53
54(eval-when (:compile-toplevel)
55  (declaim (inline read-char-internal)))
56
57(defun read-char-internal (input-stream eof-error-p eof-value)
58  (declare (optimize (speed 3) (space 0)))
59  (check-eof
60   (if (or (typep input-stream 'basic-stream)
61           (typep (setq input-stream (designated-input-stream input-stream))
62                  'basic-stream))
63     (let* ((ioblock (basic-stream-ioblock input-stream)))
64       (funcall (ioblock-read-char-function ioblock) ioblock))
65     (stream-read-char input-stream))
66   input-stream eof-error-p eof-value))
67
68(defun read-char (&optional input-stream (eof-error-p t) eof-value recursive-p)
69  (declare (ignore recursive-p))
70  (read-char-internal input-stream eof-error-p eof-value))
71
72(defun unread-char (char &optional input-stream)
73  (let* ((input-stream (designated-input-stream input-stream)))
74    (if (typep input-stream 'basic-stream)
75      (let* ((ioblock (basic-stream-ioblock input-stream)))
76        (funcall (ioblock-unread-char-function ioblock) ioblock char))
77      (stream-unread-char input-stream char))
78    nil))
79
80(defun peek-char (&optional peek-type input-stream
81                            (eof-error-p t) eof-value recursive-p)
82  (declare (ignore recursive-p))
83  (let* ((input-stream (designated-input-stream input-stream)))
84    (cond ((null peek-type)
85           (check-eof (stream-peek-char input-stream) input-stream eof-error-p eof-value))
86          (t
87           (do* ((value (stream-peek-char input-stream) (stream-peek-char input-stream)))
88                ((eq value :eof)
89                 (return (check-eof value input-stream eof-error-p eof-value)))
90             (if (eq peek-type t)
91               (unless (whitespacep value)
92                 (return value))
93               (if (characterp peek-type)
94                 (if (eql peek-type value)
95                   (return value))
96                 (report-bad-arg peek-type '(or character (member nil t)))))
97             (stream-read-char input-stream))))))
98
99(defun read-char-no-hang (&optional input-stream (eof-error-p t) eof-value recursive-p)
100  (declare (ignore recursive-p))
101  (setq input-stream (designated-input-stream input-stream))
102  (check-eof (stream-read-char-no-hang input-stream) input-stream eof-error-p eof-value))
103
104(defun read-byte (stream &optional (eof-error-p t) eof-value)
105  (declare (optimize (speed 3) (space 0)))
106  (if (typep stream 'basic-stream)
107    (let* ((ioblock (basic-stream-ioblock stream)))
108      (check-eof (funcall (ioblock-read-byte-function ioblock) ioblock)
109                 stream
110                 eof-error-p
111                 eof-value))
112    (check-eof
113     (stream-read-byte stream)
114     stream
115     eof-error-p
116     eof-value)))
117
118;;;;;;;;;;;; OUTPUT STREAMS
119
120(defun clear-output (&optional stream)
121  (let* ((stream (real-print-stream stream)))
122    (stream-clear-output stream)
123    nil))
124
125(defun finish-output (&optional stream)
126  (let* ((stream (real-print-stream stream)))
127    (stream-finish-output stream)
128    nil))
129
130
131
132(defun line-length (stream)
133  (or (stream-line-length stream) *default-right-margin*))
134
135(defun write-byte (byte stream)
136  (declare (optimize (speed 3) (space 0)))
137  "Write one byte, BYTE, to STREAM."
138  (if (typep stream 'basic-stream)
139    (let* ((ioblock (basic-stream-ioblock stream)))
140      (funcall (ioblock-write-byte-function ioblock) ioblock byte))
141    (stream-write-byte stream byte))
142  byte)
143
144
145;;;General stream functions
146
147
148
149(defmacro with-open-stream ((var stream) &body body &aux (svar (gensym)))
150  "Perform a series of operations on stream, return a value, and then
151close the stream.  VAR is bound to the value of STREAM, and then BODY is
152executed as an implicit progn. STREAM is automatically closed on exit
153from with-open-stream, no matter whether the exit is normal or abnormal.
154The stream has dynamic extent; its extent ends when the form is exited."
155  `(let (,svar)
156     (unwind-protect
157       (let ((,var (setq ,svar ,stream)))
158         ,@body)
159       (when ,svar (close ,svar)))))
160
161
162
163
164;;
165
166;;; from i/o chapter of steele
167;;; Ever notice that -much- of this code is from the i/o chapter
168;;; of steele ?  Strange but true ...
169
170(defun read-from-string (string &optional (eof-error-p t) eof-value
171                                &key (start 0) end preserve-whitespace
172                                &aux idx)
173  "The characters of string are successively given to the lisp reader
174   and the lisp object built by the reader is returned. Macro chars
175   will take effect."
176  (values
177   (with-input-from-string (stream string :index idx :start start :end end)
178     (if preserve-whitespace
179       (read-preserving-whitespace stream eof-error-p eof-value)
180       (read stream eof-error-p eof-value)))
181   idx))
182
183
184;;;File Stuff here
185
186(defun dribble (&optional filename)
187  "With a file name as an argument, dribble opens the file and sends a
188     record of further I/O to that file. Without an argument, it closes
189     the dribble file, and quits logging."
190  (process-dribble *current-process* filename))
191
Note: See TracBrowser for help on using the repository browser.