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

  ViewVC Help
Powered by ViewVC 1.1.5