source: release/1.2/source/cocoa-ide/hemlock/unused/archive/ts-stream.lisp

Last change on this file was 6567, checked in by Gary Byers, 18 years ago

Move lots of (currently unused, often unlikely to ever be used) stuff to an
archive directory.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.2 KB
Line 
1;;; -*- Package: Hemlock; Log: hemlock.log -*-
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(hemlock-ext:file-comment
8 "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; This file implements typescript streams.
13;;;
14;;; A typescript stream is a bidirectional stream which uses remote
15;;; function calls to interact with a Hemlock typescript buffer. That
16;;; is: the code in this file is executed on the slave side.
17;;;
18;;; Written by William Lott.
19;;;
20
21(in-package :hemlock)
22
23
24
25;;;; Ts-streams.
26
27(defconstant ts-stream-output-buffer-size 512)
28
29(defclass ts-stream (hi::fundamental-character-output-stream
30 hi::fundamental-character-input-stream)
31 ((wire
32 :initarg :wire
33 :initform nil
34 :accessor ts-stream-wire)
35
36 (typescript
37 :initarg :typescript
38 :initform nil
39 :accessor ts-stream-typescript)
40
41 (output-buffer
42 :initarg :output-buffer
43 :initform (make-string ts-stream-output-buffer-size)
44 :accessor ts-stream-output-buffer
45 :type simple-string)
46
47 (output-buffer-index
48 :initarg :output-buffer-index
49 :initform 0
50 :accessor ts-stream-output-buffer-index
51 :type fixnum)
52
53 (char-pos
54 :initarg :char-pos
55 :initform 0
56 :accessor ts-stream-char-pos
57 :type fixnum
58 :documentation "The current output character position on the line, returned by the :CHARPOS method.")
59
60 (line-length
61 :initarg :line-length
62 :initform 80
63 :accessor ts-stream-line-length
64 :documentation "The current length of a line of output. Returned by STREAM-LINE-LENGTH method.")
65
66 (current-input
67 :initarg :current-input
68 :initform nil
69 :accessor ts-stream-current-input
70 :type list
71 :documentation "This is a list of strings and stream-commands whose order manifests the
72 input provided by remote procedure calls into the slave of
73 TS-STREAM-ACCEPT-INPUT.")
74
75 (input-read-index
76 :initarg :input-read-index
77 :initform 0
78 :accessor ts-stream-input-read-index
79 :type fixnum)))
80
81(defun make-ts-stream (wire typescript)
82 (make-instance 'ts-stream :wire wire :typescript typescript))
83
84
85
86;;;; Conditions.
87
88(define-condition unexpected-stream-command (error)
89 ;; Context is a string to be plugged into the report text.
90 ((context :reader unexpected-stream-command-context :initarg :context))
91 (:report (lambda (condition stream)
92 (format stream "~&Unexpected stream-command while ~A."
93 (unexpected-stream-command-context condition)))))
94
95
96
97
98;;;; Editor remote calls into slave.
99
100;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface.
101;;;
102;;; The editor calls this remotely in the slave to indicate that the user has
103;;; provided input. Input is a string, symbol, or list. If it is a list, the
104;;; the CAR names the command, and the CDR is the arguments.
105;;;
106(defun ts-stream-accept-input (remote input)
107 (let ((stream (hemlock.wire:remote-object-value remote)))
108 (hemlock-ext:without-interrupts
109 (hemlock-ext:without-gcing
110 (setf (ts-stream-current-input stream)
111 (nconc (ts-stream-current-input stream)
112 (list (etypecase input
113 (string
114 (let ((newline
115 (position #\newline input :from-end t)))
116 (setf (ts-stream-char-pos stream)
117 (if newline
118 (- (length input) newline 1)
119 (length input)))
120 input))
121 #+NILGB
122 (cons
123 (ext:make-stream-command (car input)
124 (cdr input)))
125 #+NILGB
126 (symbol
127 (ext:make-stream-command input)))))))))
128 nil)
129
130;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface.
131;;;
132;;; This function is called by the editor to indicate that the line-length for
133;;; a TS stream should now be Length.
134;;;
135(defun ts-stream-set-line-length (remote length)
136 (let ((stream (hemlock.wire:remote-object-value remote)))
137 (setf (ts-stream-line-length stream) length)))
138
139
140
141
142;;;; Stream methods.
143
144;;; %TS-STREAM-LISTEN -- Internal.
145;;;
146;;; Determine if there is any input available. If we don't think so, process
147;;; all pending events, and look again.
148;;;
149(defmethod hi::stream-listen ((stream ts-stream))
150 (flet ((check ()
151 (hemlock-ext:without-interrupts
152 (hemlock-ext:without-gcing
153 (loop
154 (let* ((current (ts-stream-current-input stream))
155 (first (first current)))
156 (cond ((null current)
157 (return nil))
158 #+NILGB
159 ((ext:stream-command-p first)
160 (return t))
161 ((>= (ts-stream-input-read-index stream)
162 (length (the simple-string first)))
163 (pop (ts-stream-current-input stream))
164 (setf (ts-stream-input-read-index stream) 0))
165 (t
166 (return t)))))))))
167 (or (check)
168 (progn
169 #+NILGB (system:serve-all-events 0)
170 (check)))))
171
172;;; %TS-STREAM-IN -- Internal.
173;;;
174;;; The READ-CHAR stream method.
175;;;
176(defmethod hi::stream-read-char ((stream ts-stream))
177 (hi::stream-force-output stream)
178 (wait-for-typescript-input stream)
179 (hemlock-ext:without-interrupts
180 (hemlock-ext:without-gcing
181 (let ((first (first (ts-stream-current-input stream))))
182 (etypecase first
183 (string
184 (prog1 (schar first (ts-stream-input-read-index stream))
185 (incf (ts-stream-input-read-index stream))))
186 #+NILGB
187 (ext:stream-command
188 (error 'unexpected-stream-command
189 :context "in the READ-CHAR method")))))))
190
191;;; %TS-STREAM-READ-LINE -- Internal.
192;;;
193;;; The READ-LINE stream method. Note: here we take advantage of the fact that
194;;; newlines will only appear at the end of strings.
195;;;
196
197(defmethod stream-read-line (stream)
198 (macrolet
199 ((next-str ()
200 '(progn
201 (wait-for-typescript-input stream)
202 (hemlock-ext:without-interrupts
203 (hemlock-ext:without-gcing
204 (let ((first (first (ts-stream-current-input stream))))
205 (etypecase first
206 (string
207 (prog1 (if (zerop (ts-stream-input-read-index stream))
208 (pop (ts-stream-current-input stream))
209 (subseq (pop (ts-stream-current-input stream))
210 (ts-stream-input-read-index stream)))
211 (setf (ts-stream-input-read-index stream) 0)))
212 #+NILGB
213 (ext:stream-command
214 (error 'unexpected-stream-command
215 :context "in the READ-CHAR method")))))))))
216 (do ((result (next-str) (concatenate 'simple-string result (next-str))))
217 ((char= (schar result (1- (length result))) #\newline)
218 (values (subseq result 0 (1- (length result)))
219 nil))
220 (declare (simple-string result)))))
221
222;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal.
223;;;
224;;; Keep calling server until some input shows up.
225;;;
226(defun wait-for-typescript-input (stream)
227 (unless (hi::stream-listen stream) ;for some reasons in CLISP CL:LISTEN calls STREAM-READ-CHAR :-/
228 (let ((wire (ts-stream-wire stream))
229 (ts (ts-stream-typescript stream)))
230 (hemlock-ext:without-interrupts
231 (hemlock-ext:without-gcing
232 (hemlock.wire:remote wire (ts-buffer-ask-for-input ts))
233 (hemlock.wire:wire-force-output wire)))
234 (loop
235 #+:hemlock.serve-event (hemlock.wire::serve-all-events)
236 #-:hemlock.serve-event (hemlock.wire:wire-get-object wire)
237 #+NILGB (sleep .1) ;###
238 (when (hi::stream-listen stream)
239 (return))))))
240
241;;; %TS-STREAM-FLSBUF --- internal.
242;;;
243;;; Flush the output buffer associated with stream. This should only be used
244;;; inside a without-interrupts and without-gcing.
245;;;
246(defun %ts-stream-flsbuf (stream)
247 (when (and (ts-stream-wire stream)
248 (ts-stream-output-buffer stream)
249 (not (zerop (ts-stream-output-buffer-index stream))))
250 (hemlock.wire:remote (ts-stream-wire stream)
251 (ts-buffer-output-string
252 (ts-stream-typescript stream)
253 (subseq (the simple-string (ts-stream-output-buffer stream))
254 0
255 (ts-stream-output-buffer-index stream))))
256 (setf (ts-stream-output-buffer-index stream) 0)))
257
258;;; %TS-STREAM-OUT --- internal.
259;;;
260;;; Output a single character to stream.
261;;;
262(defmethod hi::stream-write-char ((stream ts-stream) char)
263 (declare (base-char char))
264 (hemlock-ext:without-interrupts
265 (hemlock-ext:without-gcing
266 (when (= (ts-stream-output-buffer-index stream)
267 ts-stream-output-buffer-size)
268 (%ts-stream-flsbuf stream))
269 (setf (schar (ts-stream-output-buffer stream)
270 (ts-stream-output-buffer-index stream))
271 char)
272 (incf (ts-stream-output-buffer-index stream))
273 (incf (ts-stream-char-pos stream))
274 (when (= (char-code char)
275 (char-code #\Newline))
276 (%ts-stream-flsbuf stream)
277 (setf (ts-stream-char-pos stream) 0)
278 (hemlock.wire:wire-force-output (ts-stream-wire stream)))
279 char)))
280
281;;; %TS-STREAM-SOUT --- internal.
282;;;
283;;; Output a string to stream.
284;;;
285(defmethod hi::stream-write-string ((stream ts-stream) string &optional (start 0) (end (length string)))
286 ;; This can't be true generally: --GB
287 #+NIL (declare (simple-string string))
288 (declare (fixnum start end))
289 (let ((wire (ts-stream-wire stream))
290 (newline (position #\Newline string :start start :end end :from-end t))
291 (length (- end start)))
292 (when wire
293 (hemlock-ext:without-interrupts
294 (hemlock-ext:without-gcing
295 (let ((index (ts-stream-output-buffer-index stream)))
296 (cond ((> (+ index length)
297 ts-stream-output-buffer-size)
298 (%ts-stream-flsbuf stream)
299 (hemlock.wire:remote wire
300 (ts-buffer-output-string (ts-stream-typescript stream)
301 (subseq string start end)))
302 (when newline
303 (hemlock.wire:wire-force-output wire)))
304 (t
305 (replace (the simple-string (ts-stream-output-buffer stream))
306 string
307 :start1 index
308 :end1 (+ index length)
309 :start2 start
310 :end2 end)
311 (incf (ts-stream-output-buffer-index stream)
312 length)
313 (when newline
314 (%ts-stream-flsbuf stream)
315 (hemlock.wire:wire-force-output wire)))))
316 (setf (ts-stream-char-pos stream)
317 (if newline
318 (- end newline 1)
319 (+ (ts-stream-char-pos stream)
320 length))))))))
321
322;;; %TS-STREAM-UNREAD -- Internal.
323;;;
324;;; Unread a single character.
325;;;
326(defmethod hi::stream-unread-char ((stream ts-stream) char)
327 (hemlock-ext:without-interrupts
328 (hemlock-ext:without-gcing
329 (let ((first (first (ts-stream-current-input stream))))
330 (cond ((and (stringp first)
331 (> (ts-stream-input-read-index stream) 0))
332 (setf (schar first (decf (ts-stream-input-read-index stream)))
333 char))
334 (t
335 (push (string char) (ts-stream-current-input stream))
336 (setf (ts-stream-input-read-index stream) 0)))))))
337
338;;; %TS-STREAM-CLOSE --- internal.
339;;;
340;;; Can't do much, 'cause the wire is shared.
341;;;
342(defmethod close ((stream ts-stream) &key abort)
343 (unless abort
344 (force-output stream))
345 #+NILGB (lisp::set-closed-flame stream) ;Hugh!? what is that? --GB
346 )
347
348;;; %TS-STREAM-CLEAR-INPUT -- Internal.
349;;;
350;;; Pass the request to the editor and clear any buffered input.
351;;;
352(defmethod hi::stream-clear-input ((stream ts-stream))
353 (hemlock-ext:without-interrupts
354 (hemlock-ext:without-gcing
355 (when (ts-stream-wire stream)
356 (hemlock.wire:remote-value (ts-stream-wire stream)
357 (ts-buffer-clear-input (ts-stream-typescript stream))))
358 (setf (ts-stream-current-input stream) nil
359 (ts-stream-input-read-index stream) 0))))
360
361(defmethod hi::stream-finish-output ((stream ts-stream))
362 (when (ts-stream-wire stream)
363 (hemlock-ext:without-interrupts
364 (hemlock-ext:without-gcing
365 (%ts-stream-flsbuf stream)
366 ;; Note: for the return value to come back,
367 ;; all pending RPCs must have completed.
368 ;; Therefore, we know it has synced.
369 (hemlock.wire:remote-value (ts-stream-wire stream)
370 (ts-buffer-finish-output (ts-stream-typescript stream))))))
371 t)
372
373(defmethod hi::stream-force-output ((stream ts-stream))
374 (when (ts-stream-wire stream)
375 (hemlock-ext:without-interrupts
376 (hemlock-ext:without-gcing
377 (%ts-stream-flsbuf stream)
378 (hemlock.wire:wire-force-output (ts-stream-wire stream)))))
379 t)
380
381(defmethod hi::stream-line-column ((stream ts-stream))
382 (ts-stream-char-pos stream))
383
384(defmethod hi::stream-line-length ((stream ts-stream))
385 (ts-stream-line-length stream))
386
387#+NILGB ;; -- hmm.
388(defmethod interactive-stream-p ((stream ts-stream))
389 t)
390
391(defmethod hi::stream-clear-output ((stream ts-stream))
392 (setf (ts-stream-output-buffer-index stream) 0))
393
394;;; %TS-STREAM-MISC -- Internal.
395;;;
396;;; The misc stream method.
397;;;
398#+NILGB
399(defun %ts-stream-misc (stream operation &optional arg1 arg2)
400 (case operation
401 (:get-command
402 (wait-for-typescript-input stream)
403 (hemlock-ext:without-interrupts
404 (hemlock-ext:without-gcing
405 (etypecase (first (ts-stream-current-input stream))
406 (stream-command
407 (setf (ts-stream-input-read-index stream) 0)
408 (pop (ts-stream-current-input stream)))
409 (string nil)))))
410 ))
411
412;; $Log$
413;; Revision 1.1 2003/10/19 08:57:16 gb
414;; Initial revision
415;;
416;; Revision 1.1.2.1 2003/08/10 19:11:40 gb
417;; New files, imported from upstream CVS as of 03/08/09.
418;;
419;; Revision 1.3 2003/08/05 19:51:13 gilbert
420;; initial slave lisp support, still not ready for prime time.
421;;
422;;
Note: See TracBrowser for help on using the repository browser.