1
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
3
;; This file is part of GNU Common Lisp, herein referred to as GCL
5
;; GCL is free software; you can redistribute it and/or modify it under
6
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7
;; the Free Software Foundation; either version 2, or (at your option)
10
;; GCL is distributed in the hope that it will be useful, but WITHOUT
11
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
13
;; License for more details.
15
;; You should have received a copy of the GNU Library General Public License
16
;; along with GCL; see the file COPYING. If not, write to the Free Software
17
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
28
(export '(with-open-stream with-input-from-string with-output-to-string))
29
(export '(read-from-string))
30
(export '(write-to-string prin1-to-string princ-to-string))
31
(export 'with-open-file)
32
(export '(y-or-n-p yes-or-no-p))
39
(proclaim '(optimize (safety 2) (space 3)))
42
(defmacro with-open-stream ((var stream) . body)
43
(multiple-value-bind (ds b)
44
(find-declarations body)
45
`(let ((,var ,stream))
52
(defmacro with-input-from-string ((var string &key index start end) . body)
54
(multiple-value-bind (ds b)
55
(find-declarations body)
56
`(let ((,var (make-string-input-stream ,string ,start ,end)))
60
(setf ,index (si:get-string-input-stream-index ,var)))))
61
`(let ((,var (make-string-input-stream ,string ,start ,end)))
65
(defmacro with-output-to-string ((var &optional string) . body)
67
`(let ((,var (make-string-output-stream-from-string ,string)))
69
`(let ((,var (make-string-output-stream)))
71
(get-output-stream-string ,var))))
74
(defun read-from-string (string
75
&optional (eof-error-p t) eof-value
76
&key (start 0) (end (length string))
78
(let ((stream (make-string-input-stream string start end)))
79
(if preserve-whitespace
80
(values (read-preserving-whitespace stream eof-error-p eof-value)
81
(si:get-string-input-stream-index stream))
82
(values (read stream eof-error-p eof-value)
83
(si:get-string-input-stream-index stream)))))
86
(defun write-to-string (object &rest rest
87
&key escape radix base
88
circle pretty level length
90
&aux (stream (make-string-output-stream)))
91
(declare (ignore escape radix base
92
circle pretty level length
94
(apply #'write object :stream stream rest)
95
(get-output-stream-string stream))
98
(defun prin1-to-string (object
99
&aux (stream (make-string-output-stream)))
100
(prin1 object stream)
101
(get-output-stream-string stream))
104
(defun princ-to-string (object
105
&aux (stream (make-string-output-stream)))
106
(princ object stream)
107
(get-output-stream-string stream))
110
(defmacro with-open-file ((stream . filespec) . body)
111
(multiple-value-bind (ds b)
112
(find-declarations body)
113
`(let ((,stream (open ,@filespec)))
117
(if ,stream (close ,stream))))))
120
(defun y-or-n-p (&optional string &rest args)
123
(when string (format *query-io* "~&~? (Y or N) " string args))
124
(setq reply (read *query-io*))
125
(cond ((string-equal (symbol-name reply) "Y")
126
(return-from y-or-n-p t))
127
((string-equal (symbol-name reply) "N")
128
(return-from y-or-n-p nil)))))
131
(defun yes-or-no-p (&optional string &rest args)
134
(when string (format *query-io* "~&~? (Yes or No) " string args))
135
(setq reply (read *query-io*))
136
(cond ((string-equal (symbol-name reply) "YES")
137
(return-from yes-or-no-p t))
138
((string-equal (symbol-name reply) "NO")
139
(return-from yes-or-no-p nil)))))
142
(defun sharp-a-reader (stream subchar arg)
143
(declare (ignore subchar))
144
(let ((initial-contents (read stream nil nil t)))
148
(d nil (cons (length ic) d))
149
(ic initial-contents (if (zerop (length ic)) ic (elt ic 0))))
151
(make-array (nreverse d)
152
:initial-contents initial-contents))))))
154
(set-dispatch-macro-character #\# #\a 'sharp-a-reader)
155
(set-dispatch-macro-character #\# #\A 'sharp-a-reader)
157
;; defined in defstruct.lsp
158
(set-dispatch-macro-character #\# #\s 'sharp-s-reader)
159
(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
161
(defvar *dribble-stream* nil)
162
(defvar *dribble-io* nil)
163
(defvar *dribble-namestring* nil)
164
(defvar *dribble-saved-terminal-io* nil)
166
(defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede))
168
(when (null *dribble-stream*) (error "Not in dribble."))
169
(if (eq *dribble-io* *terminal-io*)
170
(setq *terminal-io* *dribble-saved-terminal-io*)
171
(warn "*TERMINAL-IO* was rebound while DRIBBLE is on.~%~
172
You may miss some dribble output."))
173
(close *dribble-stream*)
174
(setq *dribble-stream* nil)
175
(format t "~&Finished dribbling to ~A." *dribble-namestring*))
177
(error "Already in dribble (to ~A)." *dribble-namestring*))
179
(let* ((namestring (namestring pathname))
180
(stream (open pathname :direction :output
182
:if-does-not-exist :create)))
183
(setq *dribble-namestring* namestring
184
*dribble-stream* stream
185
*dribble-saved-terminal-io* *terminal-io*
186
*dribble-io* (make-two-way-stream
187
(make-echo-stream *terminal-io* stream)
188
(make-broadcast-stream *terminal-io* stream))
189
*terminal-io* *dribble-io*)
190
(multiple-value-bind (sec min hour day month year)
192
(format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)."
193
namestring year month day hour min sec))))))
added
removed
lsp/iolib.lsp
