Suppress warnings about possible slot name conflicts with slots from SB-PCL.
[sbcl.git] / contrib / sb-simple-streams / string.lisp
1 ;;; -*- lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
5 ;;; domain.
6 ;;;
7
8 ;;; Sbcl port by Rudi Schlatte.
9
10 (in-package "SB-SIMPLE-STREAMS")
11
12 ;;;
13 ;;; **********************************************************************
14 ;;;
15 ;;; String-Simple-Stream and relatives
16
17 (def-stream-class string-input-simple-stream (string-simple-stream)
18   ())
19
20 (def-stream-class string-output-simple-stream (string-simple-stream)
21   ((out-buffer :initform nil :type (or simple-stream-buffer null))
22    (outpos :initform 0 :type fixnum)
23    (max-out-pos :initform 0 :type fixnum)))
24
25 (def-stream-class composing-stream (string-simple-stream)
26   ())
27
28 (def-stream-class fill-pointer-output-simple-stream
29     (string-output-simple-stream)
30   ())
31
32 (def-stream-class xp-simple-stream (string-output-simple-stream)
33   ())
34
35 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
36   ())
37
38 (defmethod device-open :before ((stream string-input-simple-stream) options)
39   ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
40   (with-stream-class (string-input-simple-stream stream)
41     (let ((string (getf options :string)))
42       (when (and string (null (sm buffer stream)))
43         (let ((start (getf options :start))
44               (end (or (getf options :end) (length string))))
45           (setf (sm buffer stream) string
46                 (sm buffpos stream) start
47                 (sm buffer-ptr stream) end))))
48     (install-string-input-character-strategy stream)
49     (add-stream-instance-flags stream :string :input :simple)))
50
51 (defmethod device-open :before ((stream string-output-simple-stream) options)
52   ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
53   (with-stream-class (string-output-simple-stream stream)
54     (unless (sm out-buffer stream)
55       (let ((string (getf options :string)))
56         (if string
57             (setf (sm out-buffer stream) string
58                   (sm max-out-pos stream) (length string))
59             (let ((buflen (max (device-buffer-length stream) 16)))
60               (setf (sm out-buffer stream) (make-string buflen)
61                     (sm max-out-pos stream) buflen)))))
62     (unless (sm control-out stream)
63       (setf (sm control-out stream) *std-control-out-table*))
64     (install-string-output-character-strategy stream)
65     (add-stream-instance-flags stream :string :output :simple)))
66
67 (defmethod device-open ((stream string-simple-stream) options)
68   (declare (ignore options))
69   (with-stream-class (string-simple-stream stream)
70     (if (and (any-stream-instance-flags stream :simple)
71              (any-stream-instance-flags stream :input :output))
72         t
73         nil)))
74
75 (defmethod device-file-position ((stream string-simple-stream))
76   (with-stream-class (simple-stream stream)
77     (sm buffpos stream)))
78
79 (defmethod (setf device-file-position) (value (stream string-simple-stream))
80   (with-stream-class (simple-stream stream)
81     (cond ((or (> value (sm buffer-ptr stream))
82                (< value (- -1 (sm buffer-ptr stream))))
83            nil)
84           ((>= value 0)
85            (setf (sm buffpos stream) value)
86            t)
87           (t
88            (setf (sm buffpos stream) (+ (sm buffer-ptr stream) value 1))
89            t))))
90
91 (defmethod device-file-length ((stream string-simple-stream))
92   (with-stream-class (simple-stream stream)
93     (sm buffer-ptr stream)))
94
95 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
96   #| do something |#
97   stream)
98
99 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
100   (with-stream-class (fill-pointer-output-simple-stream stream)
101     (fill-pointer (sm out-buffer stream))))
102
103 (defmethod (setf device-file-position)
104     (value (stream fill-pointer-output-simple-stream))
105   (with-stream-class (fill-pointer-output-simple-stream stream)
106     (let ((buffer (sm out-buffer stream)))
107       (cond ((or (> value (array-total-size buffer))
108                  (< value (- -1 (array-total-size buffer))))
109              nil)
110             ((>= value 0)
111              (setf (fill-pointer buffer) value))
112             (t
113              (setf (fill-pointer buffer)
114                    (+ (array-total-size buffer) value 1)))))))
115
116 (defmethod device-open ((stream xp-simple-stream) options)
117   #| do something |#
118   stream)