Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; This file contains definitions of various types of streams used
;;; in Hemlock. They are implementation dependant, but should be
;;; portable to all implementations based on Spice Lisp with little
;;; difficulty.
;;;
;;; Written by Skef Wholey and Rob MacLachlan.
;;;
(in-package "HEMLOCK-INTERNALS")
(export '(make-hemlock-output-stream
hemlock-region-stream hemlock-region-stream-p
hemlock-output-stream make-hemlock-region-stream
hemlock-output-stream-p make-kbdmac-stream
modify-kbdmac-stream))
(defstruct (hemlock-output-stream
(:include stream
(:misc #'hemlock-output-misc))
(:print-function %print-hemlock-output-stream)
(:constructor internal-make-hemlock-output-stream ()))
;;
;; The mark we insert at.
mark)
(defun %print-hemlock-output-stream (s stream d)
(declare (ignore d s))
(write-string "#<Hemlock output stream>" stream))
(defun make-hemlock-output-stream (mark &optional (buffered :line))
"Returns an output stream whose output will be inserted at the Mark.
Buffered, which indicates to what extent the stream may be buffered
is one of the following:
:None -- The screen is brought up to date after each stream operation.
:Line -- The screen is brought up to date when a newline is written.
:Full -- The screen is not updated except explicitly via Force-Output."
(modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark
buffered))
(defun modify-hemlock-output-stream (stream mark buffered)
(unless (and (markp mark)
(memq (mark-kind mark) '(:right-inserting :left-inserting)))
(error "~S is not a permanent mark." mark))
(setf (hemlock-output-stream-mark stream) mark)
(case buffered
(:none
(setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out
(lisp::stream-sout stream) #'hemlock-output-unbuffered-sout))
(:line
(setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out
(lisp::stream-sout stream) #'hemlock-output-line-buffered-sout))
(:full
(setf (lisp::stream-out stream) #'hemlock-output-buffered-out
(lisp::stream-sout stream) #'hemlock-output-buffered-sout))
(t
(error "~S is a losing value for Buffered." buffered)))
stream)
(defmacro with-left-inserting-mark ((var form) &body forms)
(let ((change (gensym)))
`(let* ((,var ,form)
(,change (eq (mark-kind ,var) :right-inserting)))
(unwind-protect
(progn
(when ,change
(setf (mark-kind ,var) :left-inserting))
,@forms)
(when ,change
(setf (mark-kind ,var) :right-inserting))))))
(defun hemlock-output-unbuffered-out (stream character)
(with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
(insert-character mark character)
(redisplay-windows-from-mark mark)))
(defun hemlock-output-unbuffered-sout (stream string start end)
(with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
(insert-string mark string start end)
(redisplay-windows-from-mark mark)))
(defun hemlock-output-buffered-out (stream character)
(with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
(insert-character mark character)))
(defun hemlock-output-buffered-sout (stream string start end)
(with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
(insert-string mark string start end)))
(defun hemlock-output-line-buffered-out (stream character)
(with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
(insert-character mark character)
(when (char= character #\newline)
(redisplay-windows-from-mark mark))))
(defun hemlock-output-line-buffered-sout (stream string start end)
(declare (simple-string string))
(with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
(insert-string mark string start end)
(when (find #\newline string :start start :end end)
(redisplay-windows-from-mark mark))))
(defun hemlock-output-misc (stream operation &optional arg1 arg2)
(declare (ignore arg1 arg2))
(case operation
(:charpos (mark-charpos (hemlock-output-stream-mark stream)))
(:line-length
(let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream)))))
(when buffer
(do ((w (buffer-windows buffer) (cdr w))
(min most-positive-fixnum (min (window-width (car w)) min)))
((null w)
(if (/= min most-positive-fixnum) min))))))
((:finish-output :force-output)
(redisplay-windows-from-mark (hemlock-output-stream-mark stream)))
(:close (setf (hemlock-output-stream-mark stream) nil))
(:element-type 'string-char)))
(defstruct (hemlock-region-stream
(:include stream
(:in #'region-in)
(:misc #'region-misc)
(:in-buffer (make-string lisp::in-buffer-length)))
(:print-function %print-region-stream)
(:constructor internal-make-hemlock-region-stream (region mark)))
;;
;; The region we read from.
region
;;
;; The mark pointing to the next character to read.
mark)
(defun %print-region-stream (s stream d)
(declare (ignore s d))
(write-string "#<Hemlock region stream>" stream))
(defun make-hemlock-region-stream (region)
"Returns an input stream that will return successive characters from the
given Region when asked for input."
(internal-make-hemlock-region-stream
region (copy-mark (region-start region) :right-inserting)))
(defun modify-hemlock-region-stream (stream region)
(setf (hemlock-region-stream-region stream) region
(lisp::stream-in-index stream) lisp::in-buffer-length)
(let* ((mark (hemlock-region-stream-mark stream))
(start (region-start region))
(start-line (mark-line start)))
;; Make sure it's dead.
(delete-mark mark)
(setf (mark-line mark) start-line (mark-charpos mark) (mark-charpos start))
(push mark (line-marks start-line)))
stream)
(defun region-readline (stream eof-errorp eof-value)
(close-line)
(let ((mark (hemlock-region-stream-mark stream))
(end (region-end (hemlock-region-stream-region stream))))
(cond ((mark>= mark end)
(if eof-errorp
(error "~A hit end of file." stream)
(values eof-value nil)))
((eq (mark-line mark) (mark-line end))
(let* ((limit (mark-charpos end))
(charpos (mark-charpos mark))
(dst-end (- limit charpos))
(result (make-string dst-end)))
(declare (simple-string result))
(%sp-byte-blt (line-chars (mark-line mark)) charpos
result 0 dst-end)
(setf (mark-charpos mark) limit)
(values result t)))
((= (mark-charpos mark) 0)
(let* ((line (mark-line mark))
(next (line-next line)))
(always-change-line mark next)
(values (line-chars line) nil)))
(t
(let* ((line (mark-line mark))
(chars (line-chars line))
(next (line-next line))
(charpos (mark-charpos mark))
(dst-end (- (length chars) charpos))
(result (make-string dst-end)))
(declare (simple-string chars result))
(%sp-byte-blt chars charpos result 0 dst-end)
(setf (mark-charpos mark) 0)
(always-change-line mark next)
(values result nil))))))
(defun region-in (stream eof-errorp eof-value)
(close-line)
(let* ((mark (hemlock-region-stream-mark stream))
(charpos (mark-charpos mark))
(line (mark-line mark))
(chars (line-chars line))
(length (length chars))
(last (region-end (hemlock-region-stream-region stream)))
(last-line (mark-line last))
(buffer (lisp::stream-in-buffer stream))
(start 0)
(len 0))
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
(declare (fixnum length charpos last-charpos start len)
(simple-string chars))
(cond
((eq line last-line)
(let ((last-charpos (mark-charpos last)))
(setq len (- last-charpos charpos))
(cond
((>= charpos last-charpos)
(if eof-errorp
(error "~A hit end of file." stream)
(return-from region-in eof-value)))
((> len lisp::in-buffer-length)
(%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
(setq start 0 len lisp::in-buffer-length))
(t
(setq start (- lisp::in-buffer-length len))
(%sp-byte-blt chars charpos buffer start lisp::in-buffer-length)))))
((line> line last-line)
(if eof-errorp
(error "~a hit end of file." stream)
(return-from region-in eof-value)))
(t
(setq len (- length charpos))
(cond
((< len lisp::in-buffer-length)
(let ((end (1- lisp::in-buffer-length)))
(setq start (- lisp::in-buffer-length len 1))
(%sp-byte-blt chars charpos buffer start end)
(setf (schar buffer end) #\newline))
(incf len))
(t
(%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
(setq start 0 len lisp::in-buffer-length)))))
(setf (lisp::stream-in-index stream) (1+ start))
(character-offset mark len)
(schar buffer start)))
(defun region-misc (stream operation &optional arg1 arg2)
(case operation
(:listen (mark< (hemlock-region-stream-mark stream)
(region-end (hemlock-region-stream-region stream))))
(:read-line (region-readline stream arg1 arg2))
(:clear-input (move-mark
(hemlock-region-stream-mark stream)
(region-end (hemlock-region-stream-region stream))))
(:close
(delete-mark (hemlock-region-stream-mark stream))
(setf (hemlock-region-stream-region stream) nil))
(:element-type 'string-char)))
;;;; Stuff to support keyboard macros.
;;; Note that the buffers in these streams must be general vectors, because
;;; the characters may have bits.
(defstruct (kbdmac-stream
(:include stream
(:in #'kbdmac-in)
(:listen #'kbdmac-listen)
(:misc #'kbdmac-misc))
(:constructor make-kbdmac-stream ()))
;;
;; The simple-vector that holds the characters.
buffer
;;
;; Index of the next character.
index)
;;; Kbdmac-In -- Internal
;;;
;;; This is the input method for a kbdmac stream. It just grabs a character
;;; and returns it, bumping the index.
;;;
(defun kbdmac-in (stream eof-errorp eof-value)
(declare (ignore eof-errorp eof-value))
(let ((index (kbdmac-stream-index stream)))
(prog1 (setq *last-character-typed*
(svref (kbdmac-stream-buffer stream) index))
(setf (kbdmac-stream-index stream) (1+ index)))))
;;; Kbdmac-Misc -- Internal
;;;
;;; This is the misc method for kbdmac streams. Since any character
;;; that might have been read is included in the simulated input, listen
;;; will always return T.
;;;
(defun kbdmac-misc (stream operation &optional arg1 arg2)
(declare (ignore arg1 arg2))
(case operation
(:unread
(if (plusp (kbdmac-stream-index stream))
(decf (kbdmac-stream-index stream))
(error "Nothing to unread.")))
(:listen t)
(:element-type 'string-char))
t)
;;; Modify-Kbdmac-Stream -- Internal
;;;
;;; Bash the kbdmac-stream Stream so that it will return the Input.
;;;
(defun modify-kbdmac-stream (stream input)
(setf (kbdmac-stream-index stream) 0)
(setf (kbdmac-stream-buffer stream) input)
stream)