Merge branch 'hashtables'
[jscl.git] / src / stream.lisp
1 ;;; stream.lisp ---
2
3 ;; copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
6 ;; JSCL is free software: you can redistribute it and/or
7 ;; modify it under the terms of the GNU General Public License as
8 ;; published by the Free Software Foundation, either version 3 of the
9 ;; License, or (at your option) any later version.
10 ;;
11 ;; JSCL is distributed in the hope that it will be useful, but
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14 ;; General Public License for more details.
15 ;;
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
18
19 ;;; TODO: Use structures to represent streams, but we would need
20 ;;; inheritance.
21
22 (/debug "loading stream.lisp!")
23
24 (defvar *standard-output*
25   (vector 'stream
26           (lambda (ch) (%write-string (string ch)))
27           (lambda (string) (%write-string string))))
28
29 (defun streamp (x)
30   (and (vectorp x) (eq (aref x 0) 'stream)))
31
32 (defun write-char (char &optional (stream *standard-output*))
33   (funcall (aref stream 1) char))
34
35 (defun write-string (string &optional (stream *standard-output*))
36   (funcall (aref stream 2) string))
37
38
39 (defun make-string-output-stream ()
40   (let ((buffer (make-string 0)))
41     (vector 'stream
42             ;; write-char
43             (lambda (ch)
44               (vector-push-extend ch buffer))
45             (lambda (string)
46               (dotimes (i (length string))
47                 (vector-push-extend (aref string i) buffer)))
48             'string-stream
49             buffer)))
50
51 (defun get-output-stream-string (stream)
52   (eq (aref stream 3) 'string-stream)
53   (prog1 (aref stream 4)
54     (aset stream 4 (make-string 0))))
55
56 (defmacro with-output-to-string ((var) &body body)
57   `(let ((,var (make-string-output-stream)))
58      ,@body
59      (get-output-stream-string ,var)))