3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
8 ;;; Sbcl port by Rudi Schlatte.
10 (in-package "SB-SIMPLE-STREAMS")
13 ;;; **********************************************************************
15 ;;; String-Simple-Stream and relatives
17 (def-stream-class string-input-simple-stream
(string-simple-stream)
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
)))
25 (def-stream-class composing-stream
(string-simple-stream)
28 (def-stream-class fill-pointer-output-simple-stream
29 (string-output-simple-stream)
32 (def-stream-class xp-simple-stream
(string-output-simple-stream)
35 (def-stream-class annotation-output-simple-stream
(string-output-simple-stream)
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
)))
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
)))
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
)))
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
))
75 (defmethod device-file-position ((stream string-simple-stream
))
76 (with-stream-class (simple-stream stream
)
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
))))
85 (setf (sm buffpos stream
) value
)
88 (setf (sm buffpos stream
) (+ (sm buffer-ptr stream
) value
1))
91 (defmethod device-file-length ((stream string-simple-stream
))
92 (with-stream-class (simple-stream stream
)
93 (sm buffer-ptr stream
)))
95 (defmethod device-open ((stream fill-pointer-output-simple-stream
) options
)
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
))))
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
))))
111 (setf (fill-pointer buffer
) value
))
113 (setf (fill-pointer buffer
)
114 (+ (array-total-size buffer
) value
1)))))))
116 (defmethod device-open ((stream xp-simple-stream
) options
)