Newer
Older
;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/streams.lisp,v 1.1.1.6 1992/02/15 01:02:09 wlott Exp $")
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
;;; **********************************************************************
;;;
;;; 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))
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
210
211
212
(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))
(declare (fixnum length charpos start len)
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
(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))
;;;; Stuff to support keyboard macros.
(defstruct (kbdmac-stream
(:include editor-input
(:get #'kbdmac-get)
(:unget #'kbdmac-unget)
(:listen #'kbdmac-listen))
buffer ; The simple-vector that holds the characters.
index) ; Index of the next character.
(defun kbdmac-get (stream ignore-abort-attempts-p)
(declare (ignore ignore-abort-attempts-p))
(setf (kbdmac-stream-index stream) (1+ index))
(setq *last-key-event-typed*
(svref (kbdmac-stream-buffer stream) index))))
(defun kbdmac-unget (ignore stream)
(declare (ignore ignore))
(if (plusp (kbdmac-stream-index stream))
(decf (kbdmac-stream-index stream))
(error "Nothing to unread.")))
(defun kbdmac-listen (stream)
(declare (ignore stream))