/[cmucl]/src/hemlock/ts-buf.lisp
ViewVC logotype

Contents of /src/hemlock/ts-buf.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Thu May 16 20:11:52 1991 UTC (22 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.6: +2 -2 lines
Fixed set-recentering-for-typescript-windows to work on non-typescript buffers.
1 ram 1.1 ;;; -*- Package: Hemlock; Log: hemlock.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/ts-buf.lisp,v 1.7 1991/05/16 20:11:52 ram Exp $")
11 ram 1.4 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; This file contains code for processing input to and output from slaves
15     ;;; using typescript streams. It maintains the stuff that hacks on the
16     ;;; typescript buffer and maintains its state.
17     ;;;
18     ;;; Written by William Lott.
19     ;;;
20    
21     (in-package "HEMLOCK")
22    
23    
24     (defhvar "Input Wait Alarm"
25     "When non-nil, the user is informed when a typescript buffer goes into
26     an input wait, and it is not visible. Legal values are :message,
27     :loud-message (the default), and nil."
28     :value :loud-message)
29    
30    
31    
32     ;;;; Structures.
33    
34     (defstruct (ts-data
35     (:print-function
36     (lambda (ts s d)
37     (declare (ignore ts d))
38     (write-string "#<TS Data>" s)))
39     (:constructor
40     make-ts-data (buffer
41     &aux
42     (fill-mark (copy-mark (buffer-end-mark buffer)
43     :right-inserting)))))
44     buffer ; The buffer we are in
45     stream ; Stream in the slave.
46     wire ; Wire to slave
47     server ; Server info struct.
48     fill-mark ; Mark where output goes. This is actually the
49     ; "Buffer Input Mark" which is :right-inserting,
50     ; and we make sure it is :left-inserting for
51     ; inserting output.
52     )
53    
54    
55     ;;;; Output routines.
56    
57     ;;; TS-BUFFER-OUTPUT-STRING --- internal interface.
58     ;;;
59     ;;; Called by the slave to output stuff in the typescript. Can also be called
60     ;;; by other random parts of hemlock when they want to output stuff to the
61     ;;; buffer. Since this is called for value from the slave, we have to be
62     ;;; careful about what values we return, so the result can be sent back. It is
63     ;;; called for value only as a synchronization thing.
64     ;;;
65     ;;; Whenever the output is gratuitous, we want it to go behind the prompt.
66     ;;; When it's gratuitous, and we're not at the line-start, then we can output
67     ;;; it normally, but we also make sure we end the output in a newline for
68     ;;; visibility's sake.
69     ;;;
70     (defun ts-buffer-output-string (ts string &optional gratuitous-p)
71     "Outputs STRING to the typescript described with TS. The output is inserted
72     before the fill-mark and the current input."
73     (when (wire:remote-object-p ts)
74     (setf ts (wire:remote-object-value ts)))
75     (system:without-interrupts
76     (let ((mark (ts-data-fill-mark ts)))
77     (cond ((and gratuitous-p (not (start-line-p mark)))
78     (with-mark ((m mark :left-inserting))
79     (line-start m)
80     (insert-string m string)
81     (unless (start-line-p m)
82     (insert-character m #\newline))))
83     (t
84     (setf (mark-kind mark) :left-inserting)
85     (insert-string mark string)
86     (when (and gratuitous-p (not (start-line-p mark)))
87     (insert-character mark #\newline))
88     (setf (mark-kind mark) :right-inserting)))))
89     (values))
90    
91     ;;; TS-BUFFER-FINISH-OUTPUT --- internal interface.
92     ;;;
93     ;;; Redisplays the windows. Used by ts-stream in order to finish-output.
94     ;;;
95     (defun ts-buffer-finish-output (ts)
96     (declare (ignore ts))
97     (redisplay)
98     nil)
99    
100     ;;; TS-BUFFER-CHARPOS --- internal interface.
101     ;;;
102     ;;; Used by ts-stream in order to find the charpos.
103     ;;;
104     (defun ts-buffer-charpos (ts)
105     (mark-charpos (ts-data-fill-mark (if (wire:remote-object-p ts)
106     (wire:remote-object-value ts)
107     ts))))
108    
109     ;;; TS-BUFFER-LINE-LENGTH --- internal interface.
110     ;;;
111     ;;; Used by ts-stream to find out the line length. Returns the width of the
112     ;;; first window, or 80 if there are no windows.
113     ;;;
114     (defun ts-buffer-line-length (ts)
115     (let* ((ts (if (wire:remote-object-p ts)
116     (wire:remote-object-value ts)
117     ts))
118     (window (car (buffer-windows (ts-data-buffer ts)))))
119     (if window
120     (window-width window)
121     80))) ; Seems like a good number to me.
122    
123    
124     ;;;; Input routines
125    
126     (defun ts-buffer-ask-for-input (remote)
127     (let* ((ts (wire:remote-object-value remote))
128     (buffer (ts-data-buffer ts)))
129     (unless (buffer-windows buffer)
130     (let ((input-wait-alarm
131     (if (hemlock-bound-p 'input-wait-alarm
132     :buffer buffer)
133     (variable-value 'input-wait-alarm
134     :buffer buffer)
135     (variable-value 'input-wait-alarm
136     :global))))
137     (when input-wait-alarm
138     (when (eq input-wait-alarm :loud-message)
139     (beep))
140     (message "Waiting for input in buffer ~A."
141     (buffer-name buffer))))))
142     nil)
143    
144     (defun ts-buffer-clear-input (ts)
145     (let* ((ts (if (wire:remote-object-p ts)
146     (wire:remote-object-value ts)
147     ts))
148     (buffer (ts-data-buffer ts))
149     (mark (ts-data-fill-mark ts)))
150     (unless (mark= mark (buffer-end-mark buffer))
151     (with-mark ((start mark))
152     (line-start start)
153     (let ((prompt (region-to-string (region start mark)))
154     (end (buffer-end-mark buffer)))
155     (unless (zerop (mark-charpos end))
156     (insert-character end #\Newline))
157     (insert-string end "[Input Cleared]")
158     (insert-character end #\Newline)
159     (insert-string end prompt)
160     (move-mark mark end)))))
161     nil)
162    
163     (defun ts-buffer-set-stream (ts stream)
164 ram 1.3 (let ((ts (if (wire:remote-object-p ts)
165     (wire:remote-object-value ts)
166     ts)))
167     (setf (ts-data-stream ts) stream)
168     (wire:remote (ts-data-wire ts)
169 ram 1.5 (ts-stream-set-line-length stream (ts-buffer-line-length ts))))
170 ram 1.1 nil)
171    
172    
173     ;;;; Typescript mode.
174    
175     (defun setup-typescript (buffer)
176     (let ((ts (make-ts-data buffer)))
177     (defhvar "Current Package"
178     "The package used for evaluation of Lisp in this buffer."
179     :buffer buffer
180     :value nil)
181    
182     (defhvar "Typescript Data"
183     "The ts-data structure for this buffer"
184     :buffer buffer
185     :value ts)
186    
187     (defhvar "Buffer Input Mark"
188     "Beginning of typescript input in this buffer."
189     :value (ts-data-fill-mark ts)
190     :buffer buffer)
191    
192     (defhvar "Interactive History"
193     "A ring of the regions input to the Hemlock typescript."
194     :buffer buffer
195     :value (make-ring (value interactive-history-length)))
196    
197     (defhvar "Interactive Pointer"
198     "Pointer into the Hemlock typescript input history."
199     :buffer buffer
200     :value 0)
201    
202     (defhvar "Searching Interactive Pointer"
203     "Pointer into \"Interactive History\"."
204     :buffer buffer
205     :value 0)))
206    
207     (defmode "Typescript"
208     :setup-function #'setup-typescript
209     :documentation "The Typescript mode is used to interact with slave lisps.")
210 chiles 1.6
211     ;;; This stuff keeps the end of typescript buffers visible in their windows, so
212     ;;; when they are not current, you can still track output being dumped there.
213     ;;;
214     (defun set-recentering-for-typescript-windows (window buffer)
215     (setf (window-display-recentering window) nil)
216 ram 1.7 (when (hemlock-bound-p 'typescript-data :buffer buffer)
217 chiles 1.6 (setf (window-display-recentering window) t)))
218     ;;;
219     (add-hook window-buffer-hook #'set-recentering-for-typescript-windows)
220    
221 ram 1.1
222     ;;; TYPESCRIPTIFY-BUFFER -- Internal interface.
223     ;;;
224     ;;; Buffer creation code for eval server connections calls this to setup a
225     ;;; typescript buffer, tie things together, and make some local Hemlock
226     ;;; variables.
227     ;;;
228     (defun typescriptify-buffer (buffer server wire)
229     (setf (buffer-minor-mode buffer "Typescript") t)
230     (let ((info (variable-value 'typescript-data :buffer buffer)))
231     (setf (ts-data-server info) server)
232     (setf (ts-data-wire info) wire)
233     (defhvar "Server Info"
234     "Server-info structure for this buffer."
235     :buffer buffer :value server)
236     (defhvar "Current Eval Server"
237     "The Server-Info object for the server currently used for evaluation and
238     compilation."
239     :buffer buffer :value server)
240     info))
241    
242     (defun ts-buffer-wire-died (ts)
243     (setf (ts-data-stream ts) nil)
244     (setf (ts-data-wire ts) nil)
245     (buffer-end (ts-data-fill-mark ts) (ts-data-buffer ts))
246     (ts-buffer-output-string ts (format nil "~%~%Slave died!~%")))
247    
248     (defun unwedge-typescript-buffer ()
249     (typescript-slave-to-top-level-command nil)
250     (buffer-end (current-point) (current-buffer)))
251    
252     (defhvar "Unwedge Interactive Input Fun"
253     "Function to call when input is confirmed, but the point is not past the
254     input mark."
255     :value #'unwedge-typescript-buffer
256     :mode "Typescript")
257    
258     (defhvar "Unwedge Interactive Input String"
259     "String to add to \"Point not past input mark. \" explaining what will
260     happen if the the user chooses to be unwedged."
261     :value "Cause the slave to throw to the top level? "
262     :mode "Typescript")
263    
264 ram 1.2 ;;; TYPESCRIPT-DATA-OR-LOSE -- internal
265     ;;;
266     ;;; Return the typescript-data for the current buffer, or die trying.
267     ;;;
268     (defun typescript-data-or-lose ()
269     (if (hemlock-bound-p 'typescript-data)
270     (let ((ts (value typescript-data)))
271     (if ts
272     ts
273     (editor-error "Can't find the typescript data?")))
274     (editor-error "Not in a typescript buffer.")))
275    
276 ram 1.1 (defcommand "Confirm Typescript Input" (p)
277     "Send the current input to the slave typescript."
278     "Send the current input to the slave typescript."
279     (declare (ignore p))
280 ram 1.2 (let ((ts (typescript-data-or-lose)))
281 ram 1.1 (let ((input (get-interactive-input)))
282     (when input
283     (let ((string (region-to-string input)))
284     (declare (simple-string string))
285     (insert-character (current-point) #\NewLine)
286     (wire:remote (ts-data-wire ts)
287     (ts-stream-accept-input (ts-data-stream ts)
288     (concatenate 'simple-string
289     string
290     (string #\newline))))
291     (wire:wire-force-output (ts-data-wire ts))
292     (buffer-end (ts-data-fill-mark ts)
293     (ts-data-buffer ts)))))))
294    
295     (defcommand "Typescript Slave Break" (p)
296     "Interrupt the slave Lisp process associated with this interactive buffer,
297     causing it to invoke BREAK."
298     "Interrupt the slave Lisp process associated with this interactive buffer,
299     causing it to invoke BREAK."
300     (declare (ignore p))
301     (send-oob-to-slave "B"))
302    
303     (defcommand "Typescript Slave to Top Level" (p)
304     "Interrupt the slave Lisp process associated with this interactive buffer,
305     causing it to throw to the top level REP loop."
306     "Interrupt the slave Lisp process associated with this interactive buffer,
307     causing it to throw to the top level REP loop."
308     (declare (ignore p))
309     (send-oob-to-slave "T"))
310    
311     (defun send-oob-to-slave (string)
312 ram 1.2 (let* ((ts (typescript-data-or-lose))
313 ram 1.1 (wire (ts-data-wire ts))
314     (socket (wire:wire-fd wire)))
315     (unless socket
316     (editor-error "The slave is no longer alive."))
317     (ext:send-character-out-of-band socket (schar string 0))))

  ViewVC Help
Powered by ViewVC 1.1.5