/[gcl]/gcl/lsp/gcl_iolib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_iolib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:05 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
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)
8    ;; any later version.
9    ;;
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.
14    ;;
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.
18    
19    
20    ;;;;   iolib.lsp
21    ;;;;
22    ;;;;        The IO library.
23    
24    
25    (in-package 'lisp)
26    
27    
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))
33    (export 'dribble)
34    
35    
36    (in-package 'system)
37    
38    
39    (proclaim '(optimize (safety 2) (space 3)))
40    
41    
42    (defmacro with-open-stream ((var stream) . body)
43      (multiple-value-bind (ds b)
44          (find-declarations body)
45        `(let ((,var ,stream))
46           ,@ds
47           (unwind-protect
48             (progn ,@b)
49             (close ,var)))))
50    
51    
52    (defmacro with-input-from-string ((var string &key index start end) . body)
53      (if index
54          (multiple-value-bind (ds b)
55              (find-declarations body)
56            `(let ((,var (make-string-input-stream ,string ,start ,end)))
57               ,@ds
58               (unwind-protect
59                 (progn ,@b)
60                 (setf ,index (si:get-string-input-stream-index ,var)))))
61          `(let ((,var (make-string-input-stream ,string ,start ,end)))
62             ,@body)))
63    
64    
65    (defmacro with-output-to-string ((var &optional string) . body)
66      (if string
67          `(let ((,var (make-string-output-stream-from-string ,string)))
68             ,@body)
69          `(let ((,var (make-string-output-stream)))
70             ,@body
71             (get-output-stream-string ,var))))
72            
73    
74    (defun read-from-string (string
75                             &optional (eof-error-p t) eof-value
76                             &key (start 0) (end (length string))
77                                  preserve-whitespace)
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)))))
84    
85    
86    (defun write-to-string (object &rest rest
87                            &key escape radix base
88                                 circle pretty level length
89                                 case gensym array
90                            &aux (stream (make-string-output-stream)))
91      (declare (ignore escape radix base
92                       circle pretty level length
93                       case gensym array))
94      (apply #'write object :stream stream rest)
95      (get-output-stream-string stream))
96    
97    
98    (defun prin1-to-string (object
99                            &aux (stream (make-string-output-stream)))
100       (prin1 object stream)
101       (get-output-stream-string stream))
102    
103    
104    (defun princ-to-string (object
105                            &aux (stream (make-string-output-stream)))
106      (princ object stream)
107      (get-output-stream-string stream))
108    
109    
110    (defmacro with-open-file ((stream . filespec) . body)
111      (multiple-value-bind (ds b)
112          (find-declarations body)
113        `(let ((,stream (open ,@filespec)))
114           ,@ds
115           (unwind-protect
116             (progn ,@b)
117             (if ,stream (close ,stream))))))
118    
119    
120    (defun y-or-n-p (&optional string &rest args)
121      (do ((reply))
122          (nil)
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)))))
129    
130    
131    (defun yes-or-no-p (&optional string &rest args)
132      (do ((reply))
133          (nil)
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)))))
140    
141    
142    (defun sharp-a-reader (stream subchar arg)
143      (declare (ignore subchar))
144      (let ((initial-contents (read stream nil nil t)))
145        (if *read-suppress*
146            nil
147            (do ((i 0 (1+ i))
148                 (d nil (cons (length ic) d))
149                 (ic initial-contents (if (zerop (length ic)) ic (elt ic 0))))
150                ((>= i arg)
151                 (make-array (nreverse d)
152                             :initial-contents initial-contents))))))
153    
154    (set-dispatch-macro-character #\# #\a 'sharp-a-reader)
155    (set-dispatch-macro-character #\# #\A 'sharp-a-reader)
156    
157    ;; defined in defstruct.lsp
158    (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
159    (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
160    
161    (defvar *dribble-stream* nil)
162    (defvar *dribble-io* nil)
163    (defvar *dribble-namestring* nil)
164    (defvar *dribble-saved-terminal-io* nil)
165    
166    (defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede))
167      (cond ((not psp)
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*))
176            (*dribble-stream*
177             (error "Already in dribble (to ~A)." *dribble-namestring*))
178            (t
179             (let* ((namestring (namestring pathname))
180                    (stream (open pathname :direction :output
181                                           :if-exists f
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)
191                   (get-decoded-time)
192                 (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)."
193                         namestring year month day hour min sec))))))
194    
195    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26