/[cmucl]/src/hemlock/echo.lisp
ViewVC logotype

Contents of /src/hemlock/echo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Wed Oct 23 11:09:19 1991 UTC (22 years, 5 months ago) by chiles
Branch: MAIN
Changes since 1.4: +6 -3 lines
No mod.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
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 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/echo.lisp,v 1.5 1991/10/23 11:09:19 chiles Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Hemlock Echo Area stuff.
15 ;;; Written by Skef Wholey and Rob MacLachlan.
16 ;;; Modified by Bill Chiles.
17 ;;;
18 (in-package "HEMLOCK-INTERNALS")
19 (export '(*echo-area-buffer* *echo-area-stream* *echo-area-window*
20 *parse-starting-mark* *parse-input-region*
21 *parse-verification-function* *parse-string-tables*
22 *parse-value-must-exist* *parse-default* *parse-default-string*
23 *parse-prompt* *parse-help* clear-echo-area message loud-message
24 prompt-for-buffer prompt-for-file prompt-for-integer
25 prompt-for-keyword prompt-for-expression prompt-for-string
26 prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n
27 prompt-for-key-event prompt-for-key *logical-key-event-names*
28 logical-key-event-p logical-key-event-documentation
29 logical-key-event-name logical-key-event-key-events
30 define-logical-key-event *parse-type* current-variable-tables))
31
32
33 (defmode "Echo Area" :major-p t)
34 (defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area"))
35 "Buffer used to hack text for the echo area.")
36 (defvar *echo-area-region* (buffer-region *echo-area-buffer*)
37 "Internal thing that's the *echo-area-buffer*'s region.")
38 (defvar *echo-area-stream*
39 (make-hemlock-output-stream (region-end *echo-area-region*) :full)
40 "Buffered stream that prints into the echo area.")
41 (defvar *echo-area-window* ()
42 "Window used to display stuff in the echo area.")
43 (defvar *parse-starting-mark*
44 (copy-mark (buffer-point *echo-area-buffer*) :right-inserting)
45 "Mark that points to the beginning of the text that'll be parsed.")
46 (defvar *parse-input-region*
47 (region *parse-starting-mark* (region-end *echo-area-region*))
48 "Region that contains the text typed in.")
49
50
51
52 ;;;; Variables that control parsing:
53
54 (defvar *parse-verification-function* '%not-inside-a-parse
55 "Function that verifies what's being parsed.")
56
57 ;;; %Not-Inside-A-Parse -- Internal
58 ;;;
59 ;;; This function is called if someone does stuff in the echo area when
60 ;;; we aren't inside a parse. It tries to put them back in a reasonable place.
61 ;;;
62 (defun %not-inside-a-parse (quaz)
63 "Thing that's called when somehow we get called to confirm a parse that's
64 not in progress."
65 (declare (ignore quaz))
66 (let* ((bufs (remove *echo-area-buffer* *buffer-list*))
67 (buf (or (find-if #'buffer-windows bufs)
68 (car bufs)
69 (make-buffer "Main"))))
70 (setf (current-buffer) buf)
71 (dolist (w *window-list*)
72 (when (and (eq (window-buffer w) *echo-area-buffer*)
73 (not (eq w *echo-area-window*)))
74 (setf (window-buffer w) buf)))
75 (setf (current-window)
76 (or (car (buffer-windows buf))
77 (make-window (buffer-start-mark buf)))))
78 (editor-error "Wham! We tried to confirm a parse that wasn't in progress?"))
79
80 (defvar *parse-string-tables* ()
81 "String tables being used in the current parse.")
82
83 (defvar *parse-value-must-exist* ()
84 "You know.")
85
86 (defvar *parse-default* ()
87 "When the user attempts to default a parse, we call the verification function
88 on this string. This is not the :Default argument to the prompting function,
89 but rather a string representation of it.")
90
91 (defvar *parse-default-string* ()
92 "String that we show the user to inform him of the default. If this
93 is NIL then we just use *Parse-Default*.")
94
95 (defvar *parse-prompt* ()
96 "Prompt for the current parse.")
97
98 (defvar *parse-help* ()
99 "Help string for the current parse.")
100
101 (defvar *parse-type* :string "A hack. :String, :File or :Keyword.")
102
103
104
105 ;;;; MESSAGE and CLEAR-ECHO-AREA:
106
107 (defhvar "Message Pause" "The number of seconds to pause after a Message."
108 :value 0.5s0)
109
110 (defvar *last-message-time* 0
111 "Internal-Real-Time the last time we displayed a message.")
112
113 (defun maybe-wait ()
114 (let* ((now (get-internal-real-time))
115 (delta (/ (float (- now *last-message-time*))
116 (float internal-time-units-per-second)))
117 (pause (value ed::message-pause)))
118 (when (< delta pause)
119 (sleep (- pause delta)))))
120
121 (defun clear-echo-area ()
122 "You guessed it."
123 (maybe-wait)
124 (delete-region *echo-area-region*)
125 (setf (buffer-modified *echo-area-buffer*) nil))
126
127 ;;; Message -- Public
128 ;;;
129 ;;; Display the stuff on *echo-area-stream* and then wait. Editor-Sleep
130 ;;; will do a redisplay if appropriate.
131 ;;;
132 (defun message (string &rest args)
133 "Nicely display a message in the echo-area.
134 Put the message on a fresh line and wait for \"Message Pause\" seconds
135 to give the luser a chance to see it. String and Args are a format
136 control string and format arguments, respectively."
137 (maybe-wait)
138 (cond ((eq *current-window* *echo-area-window*)
139 (let ((point (buffer-point *echo-area-buffer*)))
140 (with-mark ((m point :left-inserting))
141 (line-start m)
142 (with-output-to-mark (s m :full)
143 (apply #'format s string args)
144 (fresh-line s)))))
145 (t
146 (let ((mark (region-end *echo-area-region*)))
147 (cond ((buffer-modified *echo-area-buffer*)
148 (clear-echo-area))
149 ((not (zerop (mark-charpos mark)))
150 (insert-character mark #\newline)
151 (unless (displayed-p mark *echo-area-window*)
152 (clear-echo-area))))
153 (apply #'format *echo-area-stream* string args)
154 (setf (buffer-modified *echo-area-buffer*) nil))))
155 (force-output *echo-area-stream*)
156 (setq *last-message-time* (get-internal-real-time))
157 nil)
158
159
160 ;;; LOUD-MESSAGE -- Public.
161 ;;;
162 ;;; Like message, only more provocative.
163 ;;;
164 (defun loud-message (&rest args)
165 "This is the same as MESSAGE, but it beeps and clears the echo area before
166 doing anything else."
167 (beep)
168 (clear-echo-area)
169 (apply #'message args))
170
171
172 (defhvar "Raise Echo Area When Modified"
173 "When set, Hemlock raises the echo area window when output appears there."
174 :value nil)
175
176 ;;; RAISE-ECHO-AREA-WHEN-MODIFIED -- Internal.
177 ;;;
178 ;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when
179 ;;; initializing the bitmap screen manager.
180 ;;;
181 (defun raise-echo-area-when-modified (buffer modified)
182 (when (and (value ed::raise-echo-area-when-modified)
183 (eq buffer *echo-area-buffer*)
184 modified)
185 (let* ((hunk (window-hunk *echo-area-window*))
186 (win (window-group-xparent (bitmap-hunk-window-group hunk))))
187 (xlib:map-window win)
188 (setf (xlib:window-priority win) :above)
189 (xlib:display-force-output
190 (bitmap-device-display (device-hunk-device hunk))))))
191
192
193
194 ;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
195
196 (defun display-prompt-nicely (&optional (prompt *parse-prompt*)
197 (default (or *parse-default-string*
198 *parse-default*)))
199 (clear-echo-area)
200 (let ((point (buffer-point *echo-area-buffer*)))
201 (if (listp prompt)
202 (apply #'format *echo-area-stream* prompt)
203 (insert-string point prompt))
204 (when default
205 (insert-character point #\[)
206 (insert-string point default)
207 (insert-string point "] "))))
208
209 (defun parse-for-something ()
210 (display-prompt-nicely)
211 (let ((start-window (current-window)))
212 (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
213 (setf (current-window) *echo-area-window*)
214 (unwind-protect
215 (use-buffer *echo-area-buffer*
216 (recursive-edit nil))
217 (setf (current-window) start-window))))
218
219
220
221 ;;;; Buffer prompting.
222
223 (defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t)
224 default
225 ((:default-string *parse-default-string*))
226 ((:prompt *parse-prompt*) "Buffer: ")
227 ((:help *parse-help*) "Type a buffer name."))
228 "Prompts for a buffer name and returns the corresponding buffer. If
229 :must-exist is nil, then return the input string. This refuses to accept
230 the empty string as input when no default is supplied. :default-string
231 may be used to supply a default buffer name even when :default is nil, but
232 when :must-exist is non-nil, :default-string must be the name of an existing
233 buffer."
234 (let ((*parse-string-tables* (list *buffer-names*))
235 (*parse-type* :keyword)
236 (*parse-default* (cond
237 (default (buffer-name default))
238 (*parse-default-string*
239 (when (and *parse-value-must-exist*
240 (not (getstring *parse-default-string*
241 *buffer-names*)))
242 (error "Default-string must name an existing ~
243 buffer when must-exist is non-nil -- ~S."
244 *parse-default-string*))
245 *parse-default-string*)
246 (t nil)))
247 (*parse-verification-function* #'buffer-verification-function))
248 (parse-for-something)))
249
250 (defun buffer-verification-function (string)
251 (declare (simple-string string))
252 (cond ((string= string "") nil)
253 (*parse-value-must-exist*
254 (multiple-value-bind
255 (prefix key value field ambig)
256 (complete-string string *parse-string-tables*)
257 (declare (ignore field))
258 (ecase key
259 (:none nil)
260 ((:unique :complete)
261 (list value))
262 (:ambiguous
263 (delete-region *parse-input-region*)
264 (insert-string (region-start *parse-input-region*) prefix)
265 (let ((point (current-point)))
266 (move-mark point (region-start *parse-input-region*))
267 (unless (character-offset point ambig)
268 (buffer-end point)))
269 nil))))
270 (t
271 (list (or (getstring string *buffer-names*) string)))))
272
273
274
275 ;;;; File Prompting.
276
277 (defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
278 default
279 ((:default-string *parse-default-string*))
280 ((:prompt *parse-prompt*) "Filename: ")
281 ((:help *parse-help*) "Type a file name."))
282 "Prompts for a filename."
283 (let ((*parse-verification-function* #'file-verification-function)
284 (*parse-default* (if default (namestring default)))
285 (*parse-type* :file))
286 (parse-for-something)))
287
288 (defun file-verification-function (string)
289 (let ((pn (pathname-or-lose string)))
290 (if pn
291 (let ((merge
292 (cond ((not *parse-default*) nil)
293 ((directoryp pn)
294 (merge-pathnames pn *parse-default*))
295 (t
296 (merge-pathnames
297 (prompting-merge-pathnames (directory-namestring pn)
298 (directory-namestring
299 *parse-default*))
300 (file-namestring pn))))))
301 (cond ((probe-file pn) (list pn))
302 ((and merge (probe-file merge)) (list merge))
303 ((not *parse-value-must-exist*) (list (or merge pn)))
304 (t nil))))))
305
306 (defun prompting-merge-pathnames (pathname default-directory)
307 "Merges pathname with default-directory. If pathname is not absolute, it
308 is assumed to be relative to default-directory. The result is always a
309 directory. This works even when pathname is a logical name."
310 (if (and pathname (string/= (namestring pathname) ""))
311 (let ((pathname (pathname pathname))
312 (device (pathname-device pathname)))
313 (if (and device
314 (not (eq device :absolute))
315 (not (string= device "Default")))
316 pathname
317 (merge-relative-pathnames pathname default-directory)))
318 default-directory))
319
320 ;;; PATHNAME-OR-LOSE tries to convert string to a pathname using
321 ;;; PARSE-NAMESTRING. If it succeeds, this returns the pathname. Otherwise,
322 ;;; this deletes the offending characters from *parse-input-region* and signals
323 ;;; an editor-error.
324 ;;;
325 (defun pathname-or-lose (string)
326 (declare (simple-string string))
327 (multiple-value-bind (pn idx)
328 (parse-namestring string nil *default-pathname-defaults*
329 :junk-allowed t)
330 (cond (pn)
331 (t (delete-characters (region-end *echo-area-region*)
332 (- idx (length string)))
333 nil))))
334
335
336
337 ;;;; Keyword and variable prompting.
338
339 (defun prompt-for-keyword (*parse-string-tables*
340 &key
341 ((:must-exist *parse-value-must-exist*) t)
342 ((:default *parse-default*))
343 ((:default-string *parse-default-string*))
344 ((:prompt *parse-prompt*) "Keyword: ")
345 ((:help *parse-help*) "Type a keyword."))
346 "Prompts for a keyword using the String Tables."
347 (let ((*parse-verification-function* #'keyword-verification-function)
348 (*parse-type* :keyword))
349 (parse-for-something)))
350
351 (defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t)
352 ((:default *parse-default*))
353 ((:default-string *parse-default-string*))
354 ((:prompt *parse-prompt*) "Variable: ")
355 ((:help *parse-help*)
356 "Type the name of a variable."))
357 "Prompts for a variable defined in the current scheme of things."
358 (let ((*parse-string-tables* (current-variable-tables))
359 (*parse-verification-function* #'keyword-verification-function)
360 (*parse-type* :keyword))
361 (parse-for-something)))
362
363 (defun current-variable-tables ()
364 "Returns a list of all the variable tables currently established globally,
365 by the current buffer, and by any modes for the current buffer."
366 (do ((tables (list (buffer-variables *current-buffer*)
367 *global-variable-names*)
368 (cons (mode-object-variables (car mode)) tables))
369 (mode (buffer-mode-objects *current-buffer*) (cdr mode)))
370 ((null mode) tables)))
371
372 (defun keyword-verification-function (string)
373 (declare (simple-string string))
374 (multiple-value-bind
375 (prefix key value field ambig)
376 (complete-string string *parse-string-tables*)
377 (declare (ignore field))
378 (cond (*parse-value-must-exist*
379 (ecase key
380 (:none nil)
381 ((:unique :complete)
382 (list prefix value))
383 (:ambiguous
384 (delete-region *parse-input-region*)
385 (insert-string (region-start *parse-input-region*) prefix)
386 (let ((point (current-point)))
387 (move-mark point (region-start *parse-input-region*))
388 (unless (character-offset point ambig)
389 (buffer-end point)))
390 nil)))
391 (t
392 ;; HACK: If it doesn't have to exist, and the completion does not
393 ;; add anything, then return the completion's capitalization,
394 ;; instead of the user's input.
395 (list (if (= (length string) (length prefix)) prefix string))))))
396
397
398
399 ;;;; Integer, expression, and string prompting.
400
401 (defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t)
402 default
403 ((:default-string *parse-default-string*))
404 ((:prompt *parse-prompt*) "Integer: ")
405 ((:help *parse-help*) "Type an integer."))
406 "Prompt for an integer. If :must-exist is Nil, then we return as a string
407 whatever was input if it is not a valid integer."
408 (let ((*parse-verification-function*
409 #'(lambda (string)
410 (let ((number (parse-integer string :junk-allowed t)))
411 (if *parse-value-must-exist*
412 (if number (list number))
413 (list (or number string))))))
414 (*parse-default* (if default (write-to-string default :base 10))))
415 (parse-for-something)))
416
417
418 (defvar hemlock-eof '(())
419 "An object that won't be EQ to anything read.")
420
421 (defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t)
422 (default nil defaultp)
423 ((:default-string *parse-default-string*))
424 ((:prompt *parse-prompt*) "Expression: ")
425 ((:help *parse-help*)
426 "Type a Lisp expression."))
427 "Prompts for a Lisp expression."
428 (let ((*parse-verification-function*
429 #'(lambda (string)
430 (let ((expr (with-input-from-region (stream *parse-input-region*)
431 (handler-case (read stream nil hemlock-eof)
432 (error () hemlock-eof)))))
433 (if *parse-value-must-exist*
434 (if (not (eq expr hemlock-eof)) (values (list expr) t))
435 (if (eq expr hemlock-eof)
436 (list string) (values (list expr) t))))))
437 (*parse-default* (if defaultp (prin1-to-string default))))
438 (parse-for-something)))
439
440
441 (defun prompt-for-string (&key ((:default *parse-default*))
442 ((:default-string *parse-default-string*))
443 (trim ())
444 ((:prompt *parse-prompt*) "String: ")
445 ((:help *parse-help*) "Type a string."))
446 "Prompts for a string. If :trim is t, then leading and trailing whitespace
447 is removed from input, otherwise it is interpreted as a Char-Bag argument
448 to String-Trim."
449 (let ((*parse-verification-function*
450 #'(lambda (string)
451 (list (string-trim (if (eq trim t) '(#\space #\tab) trim)
452 string)))))
453 (parse-for-something)))
454
455
456
457 ;;;; Yes-or-no and y-or-n prompting.
458
459 (defvar *yes-or-no-string-table*
460 (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
461
462 (defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t)
463 (default nil defaultp)
464 ((:default-string *parse-default-string*))
465 ((:prompt *parse-prompt*) "Yes or No? ")
466 ((:help *parse-help*) "Type Yes or No."))
467 "Prompts for Yes or No."
468 (let* ((*parse-string-tables* (list *yes-or-no-string-table*))
469 (*parse-default* (if defaultp (if default "Yes" "No")))
470 (*parse-verification-function*
471 #'(lambda (string)
472 (multiple-value-bind
473 (prefix key value field ambig)
474 (complete-string string *parse-string-tables*)
475 (declare (ignore prefix field ambig))
476 (let ((won (or (eq key :complete) (eq key :unique))))
477 (if *parse-value-must-exist*
478 (if won (values (list value) t))
479 (list (if won (values value t) string)))))))
480 (*parse-type* :keyword))
481 (parse-for-something)))
482
483 (defun prompt-for-y-or-n (&key ((:must-exist must-exist) t)
484 (default nil defaultp)
485 default-string
486 ((:prompt prompt) "Y or N? ")
487 ((:help *parse-help*) "Type Y or N."))
488 "Prompts for Y or N."
489 (let ((old-window (current-window)))
490 (unwind-protect
491 (progn
492 (setf (current-window) *echo-area-window*)
493 (display-prompt-nicely prompt (or default-string
494 (if defaultp (if default "Y" "N"))))
495 (loop
496 (let ((key-event (get-key-event *editor-input*)))
497 (cond ((or (eq key-event #k"y")
498 (eq key-event #k"Y"))
499 (return t))
500 ((or (eq key-event #k"n")
501 (eq key-event #k"N"))
502 (return nil))
503 ((logical-key-event-p key-event :confirm)
504 (if defaultp
505 (return default)
506 (beep)))
507 ((logical-key-event-p key-event :help)
508 (ed::help-on-parse-command ()))
509 (t
510 (unless must-exist (return key-event))
511 (beep))))))
512 (setf (current-window) old-window))))
513
514
515
516 ;;;; Key-event and key prompting.
517
518 (defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t))
519 "Prompts for a key-event."
520 (prompt-for-key-event* prompt change-window))
521
522 (defun prompt-for-key-event* (prompt change-window)
523 (let ((old-window (current-window)))
524 (unwind-protect
525 (progn
526 (when change-window
527 (setf (current-window) *echo-area-window*))
528 (display-prompt-nicely prompt)
529 (get-key-event *editor-input* t))
530 (when change-window (setf (current-window) old-window)))))
531
532 (defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
533 (defun prompt-for-key (&key ((:must-exist must-exist) t)
534 default default-string
535 (prompt "Key: ")
536 ((:help *parse-help*) "Type a key."))
537 (let ((old-window (current-window))
538 (string (if default
539 (or default-string
540 (let ((l (coerce default 'list)))
541 (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
542
543 (unwind-protect
544 (progn
545 (setf (current-window) *echo-area-window*)
546 (display-prompt-nicely prompt string)
547 (setf (fill-pointer *prompt-key*) 0)
548 (prog ((key *prompt-key*) key-event)
549 (declare (vector key))
550 TOP
551 (setf key-event (get-key-event *editor-input*))
552 (cond ((logical-key-event-p key-event :quote)
553 (setf key-event (get-key-event *editor-input* t)))
554 ((logical-key-event-p key-event :confirm)
555 (cond ((and default (zerop (length key)))
556 (let ((res (get-command default :current)))
557 (unless (commandp res) (go FLAME))
558 (return (values default res))))
559 ((and (not must-exist) (plusp (length key)))
560 (return (copy-seq key)))
561 (t
562 (go FLAME))))
563 ((logical-key-event-p key-event :help)
564 (ed::help-on-parse-command ())
565 (go TOP)))
566 (vector-push-extend key-event key)
567 (when must-exist
568 (let ((res (get-command key :current)))
569 (cond ((commandp res)
570 (ext:print-pretty-key-event key-event
571 *echo-area-stream*
572 t)
573 (write-char #\space *echo-area-stream*)
574 (return (values (copy-seq key) res)))
575 ((not (eq res :prefix))
576 (vector-pop key)
577 (go FLAME)))))
578 (print-pretty-key key-event *echo-area-stream* t)
579 (write-char #\space *echo-area-stream*)
580 (go TOP)
581 FLAME
582 (beep)
583 (go TOP)))
584 (force-output *echo-area-stream*)
585 (setf (current-window) old-window))))
586
587
588
589 ;;;; Logical key-event stuff.
590
591 (defvar *logical-key-event-names* (make-string-table)
592 "This variable holds a string-table from logical-key-event names to the
593 corresponding keywords.")
594
595 (defvar *real-to-logical-key-events* (make-hash-table :test #'eql)
596 "A hashtable from real key-events to their corresponding logical
597 key-event keywords.")
598
599 (defvar *logical-key-event-descriptors* (make-hash-table :test #'eq)
600 "A hashtable from logical-key-events to logical-key-event-descriptors.")
601
602 (defstruct (logical-key-event-descriptor
603 (:constructor make-logical-key-event-descriptor ()))
604 name
605 key-events
606 documentation)
607
608 ;;; LOGICAL-KEY-EVENT-P -- Public
609 ;;;
610 (defun logical-key-event-p (key-event keyword)
611 "Return true if key-event has been defined to have Keyword as its
612 logical key-event. The relation between logical and real key-events
613 is defined by using SETF on LOGICAL-KEY-EVENT-P. If it is set to
614 true then calling LOGICAL-KEY-EVENT-P with the same key-event and
615 Keyword, will result in truth. Setting to false produces the opposite
616 result. See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE."
617 (not (null (memq keyword (gethash key-event *real-to-logical-key-events*)))))
618
619 ;;; GET-LOGICAL-KEY-EVENT-DESC -- Internal
620 ;;;
621 ;;; Return the descriptor for the logical key-event keyword, or signal
622 ;;; an error if it isn't defined.
623 ;;;
624 (defun get-logical-key-event-desc (keyword)
625 (let ((res (gethash keyword *logical-key-event-descriptors*)))
626 (unless res
627 (error "~S is not a defined logical-key-event keyword." keyword))
628 res))
629
630 ;;; %SET-LOGICAL-KEY-EVENT-P -- Internal
631 ;;;
632 ;;; Add or remove a logical key-event link by adding to or deleting from
633 ;;; the list in the from-char hashtable and the descriptor.
634 ;;;
635 (defun %set-logical-key-event-p (key-event keyword new-value)
636 (let ((entry (get-logical-key-event-desc keyword)))
637 (cond
638 (new-value
639 (pushnew keyword (gethash key-event *real-to-logical-key-events*))
640 (pushnew key-event (logical-key-event-descriptor-key-events entry)))
641 (t
642 (setf (gethash key-event *real-to-logical-key-events*)
643 (delete keyword (gethash key-event *real-to-logical-key-events*)))
644 (setf (logical-key-event-descriptor-key-events entry)
645 (delete keyword (logical-key-event-descriptor-key-events entry))))))
646 new-value)
647
648 ;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS -- Public
649 ;;;
650 ;;; Grab the right field out of the descriptor and return it.
651 ;;;
652 (defun logical-key-event-documentation (keyword)
653 "Return the documentation for the logical key-event Keyword."
654 (logical-key-event-descriptor-documentation
655 (get-logical-key-event-desc keyword)))
656 ;;;
657 (defun logical-key-event-name (keyword)
658 "Return the string name for the logical key-event Keyword."
659 (logical-key-event-descriptor-name (get-logical-key-event-desc keyword)))
660 ;;;
661 (defun logical-key-event-key-events (keyword)
662 "Return the list of key-events for which Keyword is the logical key-event."
663 (logical-key-event-descriptor-key-events
664 (get-logical-key-event-desc keyword)))
665
666 ;;; DEFINE-LOGICAL-KEY-EVENT -- Public
667 ;;;
668 ;;; Make the entries in the two hashtables and the string-table.
669 ;;;
670 (defun define-logical-key-event (name documentation)
671 "Define a logical key-event having the specified Name and Documentation.
672 See LOGICAL-KEY-EVENT-P and COMMAND-CASE."
673 (check-type name string)
674 (check-type documentation (or string function))
675 (let* ((keyword (string-to-keyword name))
676 (entry (or (gethash keyword *logical-key-event-descriptors*)
677 (setf (gethash keyword *logical-key-event-descriptors*)
678 (make-logical-key-event-descriptor)))))
679 (setf (logical-key-event-descriptor-name entry) name)
680 (setf (logical-key-event-descriptor-documentation entry) documentation)
681 (setf (getstring name *logical-key-event-names*) keyword)))
682
683
684
685 ;;;; Some standard logical-key-events:
686
687 (define-logical-key-event "Forward Search"
688 "This key-event is used to indicate that a forward search should be made.")
689 (define-logical-key-event "Backward Search"
690 "This key-event is used to indicate that a backward search should be made.")
691 (define-logical-key-event "Recursive Edit"
692 "This key-event indicates that a recursive edit should be entered.")
693 (define-logical-key-event "Cancel"
694 "This key-event is used to cancel a previous key-event of input.")
695 (define-logical-key-event "Abort"
696 "This key-event is used to abort the command in progress.")
697 (define-logical-key-event "Exit"
698 "This key-event is used to exit normally the command in progress.")
699 (define-logical-key-event "Yes"
700 "This key-event is used to indicate a positive response.")
701 (define-logical-key-event "No"
702 "This key-event is used to indicate a negative response.")
703 (define-logical-key-event "Do All"
704 "This key-event means do it as many times as you can.")
705 (define-logical-key-event "Do Once"
706 "This key-event means, do it this time, then exit.")
707 (define-logical-key-event "Help"
708 "This key-event is used to ask for help.")
709 (define-logical-key-event "Confirm"
710 "This key-event is used to confirm some choice.")
711 (define-logical-key-event "Quote"
712 "This key-event is used to quote the next key-event of input.")
713 (define-logical-key-event "Keep"
714 "This key-event means exit but keep something around.")
715
716
717
718 ;;;; COMMAND-CASE help message printing.
719
720 (defvar *my-string-output-stream* (make-string-output-stream))
721
722 (defun chars-to-string (chars)
723 (do ((s *my-string-output-stream*)
724 (chars chars (cdr chars)))
725 ((null chars)
726 (get-output-stream-string s))
727 (let ((char (car chars)))
728 (if (characterp char)
729 (write-char char s)
730 (do ((key-events
731 (logical-key-event-key-events char)
732 (cdr key-events)))
733 ((null key-events))
734 (ext:print-pretty-key (car key-events) s)
735 (unless (null (cdr key-events))
736 (write-string ", " s))))
737 (unless (null (cdr chars))
738 (write-string ", " s)))))
739
740 ;;; COMMAND-CASE-HELP -- Internal
741 ;;;
742 ;;; Print out a help message derived from the options in a
743 ;;; random-typeout window.
744 ;;;
745 (defun command-case-help (help options)
746 (let ((help (if (listp help)
747 (apply #'format nil help) help)))
748 (with-pop-up-display (s)
749 (write-string help s)
750 (fresh-line s)
751 (do ((o options (cdr o)))
752 ((null o))
753 (let ((string (chars-to-string (caar o))))
754 (declare (simple-string string))
755 (if (= (length string) 1)
756 (write-char (char string 0) s)
757 (write-line string s))
758 (write-string " - " s)
759 (write-line (cdar o) s))))))

  ViewVC Help
Powered by ViewVC 1.1.5