source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/streams.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.9 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;;    This file contains definitions of various types of streams used
13;;; in Hemlock.  They are implementation dependant, but should be
14;;; portable to all implementations based on Spice Lisp with little
15;;; difficulty.
16;;;
17;;; Written by Skef Wholey and Rob MacLachlan.
18;;;
19
20(in-package :hemlock-internals)
21
22(defclass hemlock-output-stream (#-scl fundamental-character-output-stream
23                                 #+scl character-output-stream)
24  ((mark
25    :initform nil
26    :accessor hemlock-output-stream-mark
27    :documentation "The mark we insert at.")
28   (out
29    :accessor old-lisp-stream-out)
30   (sout
31    :accessor old-lisp-stream-sout)
32   ) )
33
34;; this should suffice for now:
35(defmethod stream-write-char ((stream hemlock-output-stream) char)
36  (funcall (old-lisp-stream-out stream) stream char))
37
38(defmethod stream-write-string ((stream hemlock-output-stream) string
39                                &optional
40                                (start 0)
41                                (end (length string)))
42  (funcall (old-lisp-stream-sout stream) stream string start end))
43                               
44
45(defmethod print-object ((object hemlock-output-stream) stream)
46  (write-string "#<Hemlock output stream>" stream))
47
48(defun make-hemlock-output-stream (mark &optional (buffered :line))
49  "Returns an output stream whose output will be inserted at the Mark.
50  Buffered, which indicates to what extent the stream may be buffered
51  is one of the following:
52   :None  -- The screen is brought up to date after each stream operation.
53   :Line  -- The screen is brought up to date when a newline is written.
54   :Full  -- The screen is not updated except explicitly via Force-Output."
55  (modify-hemlock-output-stream (make-instance 'hemlock-output-stream) mark
56                                buffered))
57
58
59(defun modify-hemlock-output-stream (stream mark buffered)
60  (unless (and (markp mark)
61               (member (mark-kind mark) '(:right-inserting :left-inserting)))
62    (error "~S is not a permanent mark." mark))
63  (setf (hemlock-output-stream-mark stream) mark)
64  (case buffered
65    (:none
66     (setf (old-lisp-stream-out stream) #'hemlock-output-unbuffered-out
67           (old-lisp-stream-sout stream) #'hemlock-output-unbuffered-sout))
68    (:line
69     (setf (old-lisp-stream-out stream) #'hemlock-output-line-buffered-out
70           (old-lisp-stream-sout stream) #'hemlock-output-line-buffered-sout))
71    (:full
72     (setf (old-lisp-stream-out stream) #'hemlock-output-buffered-out
73           (old-lisp-stream-sout stream) #'hemlock-output-buffered-sout))
74    (t
75     (error "~S is a losing value for Buffered." buffered)))
76  stream)
77
78(defmacro with-left-inserting-mark ((var form) &body forms)
79  (let ((change (gensym)))
80    `(let* ((,var ,form)
81            (,change (eq (mark-kind ,var) :right-inserting)))
82       (unwind-protect
83           (progn
84             (when ,change
85               (setf (mark-kind ,var) :left-inserting))
86             ,@forms)
87         (when ,change
88           (setf (mark-kind ,var) :right-inserting))))))
89
90(defun hemlock-output-unbuffered-out (stream character)
91  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
92    (insert-character mark character)
93    ))
94
95(defun hemlock-output-unbuffered-sout (stream string start end)
96  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
97    (insert-string mark string start end)
98    ))
99   
100
101(defun hemlock-output-buffered-out (stream character)
102  (hemlock-output-unbuffered-out stream character))
103
104
105(defun hemlock-output-buffered-sout (stream string start end)
106  (hemlock-output-unbuffered-sout stream string start end))
107
108(defun hemlock-output-line-buffered-out (stream character)
109  (hemlock-output-unbuffered-out stream character))
110
111(defun hemlock-output-line-buffered-sout (stream string start end)
112  (hemlock-output-unbuffered-sout stream string start end))
113
114#+NIL
115(defmethod excl:stream-line-length ((stream hemlock-output-stream))
116  (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream)))))
117       (when buffer
118         (do ((w (buffer-windows buffer) (cdr w))
119              (min most-positive-fixnum (min (window-width (car w)) min)))
120             ((null w)
121              (if (/= min most-positive-fixnum) min))))))
122
123(defmethod stream-finish-output ((stream hemlock-output-stream)))
124
125(defmethod stream-force-output ((stream hemlock-output-stream)))
126
127(defmethod close ((stream hemlock-output-stream) &key abort)
128  (declare (ignore abort))
129  (setf (hemlock-output-stream-mark stream) nil))
130
131(defmethod stream-line-column ((stream hemlock-output-stream))
132  (mark-charpos (hemlock-output-stream-mark stream)))
133
134
135
136(defclass hemlock-region-stream (#-scl fundamental-character-input-stream
137                                 #+scl character-input-stream)
138  ;;
139  ;; The region we read from.
140  ((region :initarg :region
141           :accessor hemlock-region-stream-region)
142   ;;
143   ;; The mark pointing to the next character to read.
144   (mark :initarg :mark
145         :accessor hemlock-region-stream-mark)) )
146
147(defmethod print-object ((object hemlock-region-stream) stream)
148  (declare (ignorable object))
149  (write-string "#<Hemlock region stream>" stream))
150
151(defun make-hemlock-region-stream (region)
152  "Returns an input stream that will return successive characters from the
153  given Region when asked for input."
154  (make-instance 'hemlock-region-stream
155                 :region region
156                 :mark (copy-mark (region-start region) :right-inserting)))
157
158(defun modify-hemlock-region-stream (stream region)
159  (setf (hemlock-region-stream-region stream) region)
160  (let* ((mark (hemlock-region-stream-mark stream))
161         (start (region-start region))
162         (start-line (mark-line start)))
163    ;; Make sure it's dead.
164    (delete-mark mark)
165    (setf (mark-line mark) start-line  (mark-charpos mark) (mark-charpos start))
166    (push mark (line-marks start-line)))
167  stream)
168
169(defmethod stream-read-char ((stream hemlock-region-stream))
170  (let ((mark (hemlock-region-stream-mark stream)))
171    (cond ((mark< mark
172                  (region-end (hemlock-region-stream-region stream)))
173           (prog1 (next-character mark) (mark-after mark)))
174          (t :eof))))
175
176(defmethod stream-listen ((stream hemlock-region-stream))
177  (mark< (hemlock-region-stream-mark stream)
178         (region-end (hemlock-region-stream-region stream))))
179
180(defmethod stream-unread-char ((stream hemlock-region-stream) char)
181  (let ((mark (hemlock-region-stream-mark stream)))
182    (unless (mark> mark
183                   (region-start (hemlock-region-stream-region stream)))
184      (error "Nothing to unread."))
185    (unless (char= char (previous-character mark))
186      (error "Unreading something not read: ~S" char))
187    (mark-before mark)))
188
189(defmethod stream-clear-input ((stream hemlock-region-stream))
190  (move-mark
191   (hemlock-region-stream-mark stream)
192   (region-end (hemlock-region-stream-region stream)))
193  nil)
194
195(defmethod close ((stream hemlock-region-stream) &key abort)
196  (declare (ignorable abort))
197  (delete-mark (hemlock-region-stream-mark stream))
198  (setf (hemlock-region-stream-region stream) nil))
199
200#+excl
201(defmethod excl:stream-read-char-no-hang ((stream hemlock-region-stream))
202  (stream-read-char stream))
203
204#|| 
205(defmethod excl::stream-file-position ((stream hemlock-output-stream) &optional pos)
206  (assert (null pos))
207  (mark-charpos (hemlock-output-stream-mark stream)))
208
209(defun region-misc (stream operation &optional arg1 arg2)
210  (declare (ignore arg2))
211  (case operation
212
213    (:file-position
214     (let ((start (region-start (hemlock-region-stream-region stream)))
215           (mark (hemlock-region-stream-mark stream)))
216       (cond (arg1
217              (move-mark mark start)
218              (character-offset mark arg1))
219             (t
220              (count-characters (region start mark)))))) ))
221||#
222
223
224;;;; Stuff to support keyboard macros.
225
226#+later
227(progn
228 
229(defstruct (kbdmac-stream
230            (:include editor-input
231                      (get #'kbdmac-get)
232                      (unget #'kbdmac-unget)
233                      (listen #'kbdmac-listen))
234            (:constructor make-kbdmac-stream ()))
235  buffer    ; The simple-vector that holds the characters.
236  index)    ; Index of the next character.
237
238(defun kbdmac-get (stream ignore-abort-attempts-p)
239  (declare (ignore ignore-abort-attempts-p))
240  (let ((index (kbdmac-stream-index stream)))
241    (setf (kbdmac-stream-index stream) (1+ index))
242    (setq *last-key-event-typed*
243          (svref (kbdmac-stream-buffer stream) index))))
244
245(defun kbdmac-unget (ignore stream)
246  (declare (ignore ignore))
247  (if (plusp (kbdmac-stream-index stream))
248      (decf (kbdmac-stream-index stream))
249      (error "Nothing to unread.")))
250
251(defun kbdmac-listen (stream)
252  (declare (ignore stream))
253  t)
254
255;;; MODIFY-KBDMAC-STREAM  --  Internal
256;;;
257;;;    Bash the kbdmac-stream Stream so that it will return the Input.
258;;;
259(defun modify-kbdmac-stream (stream input)
260  (setf (kbdmac-stream-index stream) 0)
261  (setf (kbdmac-stream-buffer stream) input)
262  stream)
263)
Note: See TracBrowser for help on using the repository browser.