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

Diff of /src/hemlock/echo.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ram, Wed May 9 13:03:42 1990 UTC revision 1.2 by ram, Fri Jul 13 15:11:45 1990 UTC
# Line 12  Line 12 
12  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
13  ;;; Modified by Bill Chiles.  ;;; Modified by Bill Chiles.
14  ;;;  ;;;
15  (in-package 'hemlock-internals)  (in-package "HEMLOCK-INTERNALS")
16  (export '(*echo-area-buffer* *echo-area-stream* *echo-area-window*  (export '(*echo-area-buffer* *echo-area-stream* *echo-area-window*
17            *parse-starting-mark* *parse-input-region*            *parse-starting-mark* *parse-input-region*
18            *parse-verification-function* *parse-string-tables*            *parse-verification-function* *parse-string-tables*
# Line 21  Line 21 
21            prompt-for-buffer prompt-for-file prompt-for-integer            prompt-for-buffer prompt-for-file prompt-for-integer
22            prompt-for-keyword prompt-for-expression prompt-for-string            prompt-for-keyword prompt-for-expression prompt-for-string
23            prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n            prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n
24            prompt-for-character prompt-for-key *logical-character-names*            prompt-for-key-event prompt-for-key *logical-key-event-names*
25            logical-char= logical-character-documentation            logical-key-event-p logical-key-event-documentation
26            logical-character-name logical-character-characters            logical-key-event-name logical-key-event-key-events
27            define-logical-character *parse-type* current-variable-tables))            define-logical-key-event *parse-type* current-variable-tables))
28    
29    
30  (defmode "Echo Area" :major-p t)  (defmode "Echo Area" :major-p t)
# Line 463  Line 463 
463    "Prompts for Y or N."    "Prompts for Y or N."
464    (let ((old-window (current-window)))    (let ((old-window (current-window)))
465      (unwind-protect      (unwind-protect
466        (progn          (progn
467         (setf (current-window) *echo-area-window*)            (setf (current-window) *echo-area-window*)
468         (display-prompt-nicely prompt (or default-string            (display-prompt-nicely prompt (or default-string
469                                           (if defaultp (if default "Y" "N"))))                                              (if defaultp (if default "Y" "N"))))
470         (do ((char (read-char *editor-input*) (read-char *editor-input*)))            (loop
471             (())              (let ((key-event (get-key-event *editor-input*)))
472           (cond ((or (char= char #\y) (char= char #\Y))                (cond ((or (eq key-event #k"y")
473                  (return t))                           (eq key-event #k"Y"))
474                 ((or (char= char #\n) (char= char #\N))                       (return t))
475                  (return nil))                      ((or (eq key-event #k"n")
476                 ((logical-char= char :confirm)                           (eq key-event #k"N"))
477                  (if defaultp                       (return nil))
478                      (return default)                      ((logical-key-event-p key-event :confirm)
479                      (beep)))                       (if defaultp
480                 ((logical-char= char :help)                           (return default)
481                  (ed::help-on-parse-command ()))                           (beep)))
482                 (t                      ((logical-key-event-p key-event :help)
483                  (unless must-exist (return char))                       (ed::help-on-parse-command ()))
484                  (beep)))))                      (t
485                         (unless must-exist (return key-event))
486                         (beep))))))
487        (setf (current-window) old-window))))        (setf (current-window) old-window))))
488    
489    
490    
491  ;;;; Character and key prompting.  ;;;; Key-event and key prompting.
492    
493  (defun prompt-for-character (&key (prompt "Character: ") (change-window t))  (defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t))
494    "Prompts for a character."    "Prompts for a key-event."
495    (prompt-for-character* prompt change-window))    (prompt-for-key-event* prompt change-window))
496    
497  (defun prompt-for-character* (prompt change-window)  (defun prompt-for-key-event* (prompt change-window)
498    (let ((old-window (current-window)))    (let ((old-window (current-window)))
499      (unwind-protect      (unwind-protect
500        (progn          (progn
501         (when change-window            (when change-window
502           (setf (current-window) *echo-area-window*))              (setf (current-window) *echo-area-window*))
503         (display-prompt-nicely prompt)            (display-prompt-nicely prompt)
504         (read-char *editor-input* nil))            (get-key-event *editor-input* t))
505        (when change-window (setf (current-window) old-window)))))        (when change-window (setf (current-window) old-window)))))
506    
507  (defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))  (defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
# Line 514  Line 516 
516                            (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))                            (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
517    
518      (unwind-protect      (unwind-protect
519        (progn          (progn
520         (setf (current-window) *echo-area-window*)            (setf (current-window) *echo-area-window*)
521         (display-prompt-nicely prompt string)            (display-prompt-nicely prompt string)
522         (setf (fill-pointer *prompt-key*) 0)            (setf (fill-pointer *prompt-key*) 0)
523         (prog ((key *prompt-key*) char)            (prog ((key *prompt-key*) key-event)
524           (declare (vector key))                  (declare (vector key))
525          TOP                  TOP
526           (setq char (read-char *editor-input*))                  (setf key-event (get-key-event *editor-input*))
527           (cond ((logical-char= char :quote)                  (cond ((logical-key-event-p key-event :quote)
528                  (setq char (read-char *editor-input* nil)))                         (setf key-event (get-key-event *editor-input* t)))
529                 ((logical-char= char :confirm)                        ((logical-key-event-p key-event :confirm)
530                  (cond ((and default (zerop (length key)))                         (cond ((and default (zerop (length key)))
531                         (let ((res (get-command default :current)))                                (let ((res (get-command default :current)))
532                           (unless (commandp res) (go FLAME))                                  (unless (commandp res) (go FLAME))
533                           (return (values default res))))                                  (return (values default res))))
534                        ((and (not must-exist) (plusp (length key)))                               ((and (not must-exist) (plusp (length key)))
535                         (return (copy-seq key)))                                (return (copy-seq key)))
536                        (t                               (t
537                         (go FLAME))))                                (go FLAME))))
538                 ((logical-char= char :help)                        ((logical-key-event-p key-event :help)
539                  (ed::help-on-parse-command ())                         (ed::help-on-parse-command ())
540                           (go TOP)))
541                    (vector-push-extend key-event key)
542                    (when must-exist
543                      (let ((res (get-command key :current)))
544                        (cond ((commandp res)
545                               (ext:print-pretty-key-event key-event
546                                                           *echo-area-stream*
547                                                           t)
548                               (write-char #\space *echo-area-stream*)
549                               (return (values (copy-seq key) res)))
550                              ((not (eq res :prefix))
551                               (vector-pop key)
552                               (go FLAME)))))
553                    (print-pretty-key key-event *echo-area-stream* t)
554                    (write-char #\space *echo-area-stream*)
555                    (go TOP)
556                    FLAME
557                    (beep)
558                  (go TOP)))                  (go TOP)))
          (vector-push-extend char key)  
          (when must-exist  
            (let ((res (get-command key :current)))  
              (cond ((commandp res)  
                     (format *echo-area-stream* "~:C " char)  
                     (return (values (copy-seq key) res)))  
                    ((not (eq res :prefix))  
                     (vector-pop key)  
                     (go FLAME)))))  
          (format *echo-area-stream* "~:C " char)  
          (go TOP)  
         FLAME  
          (beep)  
          (go TOP)))  
559        (force-output *echo-area-stream*)        (force-output *echo-area-stream*)
560        (setf (current-window) old-window))))        (setf (current-window) old-window))))
561    
562    
563    
564  ;;;; Logical character stuff.  ;;;; Logical key-event stuff.
565    
566  (defvar *logical-character-names* (make-string-table)  (defvar *logical-key-event-names* (make-string-table)
567    "This variable holds a string-table from logical-character names to the    "This variable holds a string-table from logical-key-event names to the
568    corresponding keywords.")     corresponding keywords.")
569    
570  (defvar *real-to-logical-characters* (make-hash-table :test #'eql)  (defvar *real-to-logical-key-events* (make-hash-table :test #'eql)
571    "A hashtable from real characters to their corresponding logical    "A hashtable from real key-events to their corresponding logical
572    character keywords.")     key-event keywords.")
573    
574  (defvar *logical-character-descriptors* (make-hash-table :test #'eq)  (defvar *logical-key-event-descriptors* (make-hash-table :test #'eq)
575    "A hashtable from logical-characters to logical-character-descriptors.")    "A hashtable from logical-key-events to logical-key-event-descriptors.")
576    
577  (defstruct (logical-character-descriptor  (defstruct (logical-key-event-descriptor
578              (:constructor make-logical-character-descriptor ()))              (:constructor make-logical-key-event-descriptor ()))
579    name    name
580    characters    key-events
581    documentation)    documentation)
582    
583  ;;; Logical-Char=  --  Public  ;;; LOGICAL-KEY-EVENT-P  --  Public
584  ;;;  ;;;
585  ;;;    Just look up the character in the hashtable.  (defun logical-key-event-p (key-event keyword)
586  ;;;    "Return true if key-event has been defined to have Keyword as its
587  (defun logical-char= (character keyword)     logical key-event.  The relation between logical and real key-events
588    "Return true if Character has been defined to have Keyword as its     is defined by using SETF on LOGICAL-KEY-EVENT-P.  If it is set to
589    logical character.  The relation between logical and real characters     true then calling LOGICAL-KEY-EVENT-P with the same key-event and
590    is defined by using Setf on Logical-Char=.  If it is set to     Keyword, will result in truth.  Setting to false produces the opposite
591    true then calling Logical-Char= with the same Character and     result.  See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE."
592    Keyword, will result in truth.  Setting to false produces the opposite    (not (null (memq keyword (gethash key-event *real-to-logical-key-events*)))))
   result.  See Define-Logical-Character and Command-Case."  
   (not (null (memq keyword (gethash (char-upcase character)  
                                     *real-to-logical-characters*)))))  
593    
594  ;;; Get-Logical-Char-Desc  --  Internal  ;;; GET-LOGICAL-KEY-EVENT-DESC  --  Internal
595  ;;;  ;;;
596  ;;;    Return the descriptor for the logical character Kwd, or signal  ;;;    Return the descriptor for the logical key-event keyword, or signal
597  ;;; an error if it isn't defined.  ;;; an error if it isn't defined.
598  ;;;  ;;;
599  (defun get-logical-char-desc (kwd)  (defun get-logical-key-event-desc (keyword)
600    (let ((res (gethash kwd *logical-character-descriptors*)))    (let ((res (gethash keyword *logical-key-event-descriptors*)))
601      (unless res      (unless res
602        (error "~S is not a defined logical-character keyword." kwd))        (error "~S is not a defined logical-key-event keyword." keyword))
603      res))      res))
604    
605  ;;; %Set-Logical-Char=  --  Internal  ;;; %SET-LOGICAL-KEY-EVENT-P  --  Internal
606  ;;;  ;;;
607  ;;;    Add or remove a logical character link by adding to or deleting from  ;;;    Add or remove a logical key-event link by adding to or deleting from
608  ;;; the list in the from-char hashtable and the descriptor.  ;;; the list in the from-char hashtable and the descriptor.
609  ;;;  ;;;
610  (defun %set-logical-char= (character keyword new-value)  (defun %set-logical-key-event-p (key-event keyword new-value)
611    (let* ((character (char-upcase character))    (let ((entry (get-logical-key-event-desc keyword)))
          (entry (get-logical-char-desc keyword)))  
612      (cond      (cond
613       (new-value       (new-value
614        (pushnew keyword (gethash character *real-to-logical-characters*))        (pushnew keyword (gethash key-event *real-to-logical-key-events*))
615        (pushnew character (logical-character-descriptor-characters entry)))        (pushnew key-event (logical-key-event-descriptor-key-events entry)))
616       (t       (t
617        (setf (gethash character *real-to-logical-characters*)        (setf (gethash key-event *real-to-logical-key-events*)
618              (delete keyword (gethash character *real-to-logical-characters*)))              (delete keyword (gethash key-event *real-to-logical-key-events*)))
619        (setf (logical-character-descriptor-characters entry)        (setf (logical-key-event-descriptor-key-events entry)
620              (delete keyword (logical-character-descriptor-characters entry))))))              (delete keyword (logical-key-event-descriptor-key-events entry))))))
621    new-value)    new-value)
622    
623  ;;; Logical-Character-Documentation, Name, Characters  --  Public  ;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS  --  Public
624  ;;;  ;;;
625  ;;;    Grab the right field out of the descriptor and return it.  ;;;    Grab the right field out of the descriptor and return it.
626  ;;;  ;;;
627  (defun logical-character-documentation (keyword)  (defun logical-key-event-documentation (keyword)
628    "Return the documentation for the logical character Keyword."    "Return the documentation for the logical key-event Keyword."
629    (logical-character-descriptor-documentation (get-logical-char-desc keyword)))    (logical-key-event-descriptor-documentation
630  ;;;     (get-logical-key-event-desc keyword)))
631  (defun logical-character-name (keyword)  ;;;
632    "Return the string name for the logical character Keyword."  (defun logical-key-event-name (keyword)
633    (logical-character-descriptor-name (get-logical-char-desc keyword)))    "Return the string name for the logical key-event Keyword."
634  ;;;    (logical-key-event-descriptor-name (get-logical-key-event-desc keyword)))
635  (defun logical-character-characters (keyword)  ;;;
636    "Return the list of characters for which Keyword is the logical character."  (defun logical-key-event-key-events (keyword)
637    (logical-character-descriptor-characters (get-logical-char-desc keyword)))    "Return the list of key-events for which Keyword is the logical key-event."
638      (logical-key-event-descriptor-key-events
639       (get-logical-key-event-desc keyword)))
640    
641  ;;; Define-Logical-Character  --  Public  ;;; DEFINE-LOGICAL-KEY-EVENT  --  Public
642  ;;;  ;;;
643  ;;;    Make the entries in the two hashtables and the string-table.  ;;;    Make the entries in the two hashtables and the string-table.
644  ;;;  ;;;
645  (defun define-logical-character (name documentation)  (defun define-logical-key-event (name documentation)
646    "Define a logical character having the specified Name and Documentation.    "Define a logical key-event having the specified Name and Documentation.
647    See Logical-Char= and Command-Case."    See LOGICAL-KEY-EVENT-P and COMMAND-CASE."
648    (check-type name string)    (check-type name string)
649    (check-type documentation (or string function))    (check-type documentation (or string function))
650    (let* ((keyword (string-to-keyword name))    (let* ((keyword (string-to-keyword name))
651           (entry (or (gethash keyword *logical-character-descriptors*)           (entry (or (gethash keyword *logical-key-event-descriptors*)
652                      (setf (gethash keyword *logical-character-descriptors*)                      (setf (gethash keyword *logical-key-event-descriptors*)
653                            (make-logical-character-descriptor)))))                            (make-logical-key-event-descriptor)))))
654      (setf (logical-character-descriptor-name entry) name)      (setf (logical-key-event-descriptor-name entry) name)
655      (setf (logical-character-descriptor-documentation entry) documentation)      (setf (logical-key-event-descriptor-documentation entry) documentation)
656      (setf (getstring name *logical-character-names*) keyword)))      (setf (getstring name *logical-key-event-names*) keyword)))
657    
658    
659    
660  ;;;; Some standard logical-characters:  ;;;; Some standard logical-key-events:
661    
662  (define-logical-character "Forward Search"  (define-logical-key-event "Forward Search"
663    "This character is used to indicate that a forward search should be made.")    "This key-event is used to indicate that a forward search should be made.")
664  (define-logical-character "Backward Search"  (define-logical-key-event "Backward Search"
665    "This character is used to indicate that a backward search should be made.")    "This key-event is used to indicate that a backward search should be made.")
666  (define-logical-character "Recursive Edit"  (define-logical-key-event "Recursive Edit"
667    "This character indicates that a recursive edit should be entered.")    "This key-event indicates that a recursive edit should be entered.")
668  (define-logical-character "Cancel"  (define-logical-key-event "Cancel"
669    "This character is used  to cancel a previous character of input.")    "This key-event is used  to cancel a previous key-event of input.")
670  (define-logical-character "Abort"  (define-logical-key-event "Abort"
671    "This character is used to abort the command in progress.")    "This key-event is used to abort the command in progress.")
672  (define-logical-character "Exit"  (define-logical-key-event "Exit"
673    "This character is used to exit normally the command in progress.")    "This key-event is used to exit normally the command in progress.")
674  (define-logical-character "Yes"  (define-logical-key-event "Yes"
675    "This character is used to indicate a positive response.")    "This key-event is used to indicate a positive response.")
676  (define-logical-character "No"  (define-logical-key-event "No"
677    "This character is used to indicate a negative response.")    "This key-event is used to indicate a negative response.")
678  (define-logical-character "Do All"  (define-logical-key-event "Do All"
679    "This character means do it as many times as you can.")    "This key-event means do it as many times as you can.")
680  (define-logical-character "Do Once"  (define-logical-key-event "Do Once"
681    "This character means, do it this time, then exit.")    "This key-event means, do it this time, then exit.")
682  (define-logical-character "Help"  (define-logical-key-event "Help"
683    "This character is used to ask for help.")    "This key-event is used to ask for help.")
684  (define-logical-character "Confirm"  (define-logical-key-event "Confirm"
685    "This character is used to confirm some choice.")    "This key-event is used to confirm some choice.")
686  (define-logical-character "Quote"  (define-logical-key-event "Quote"
687    "This character is used to quote the next character of input.")    "This key-event is used to quote the next key-event of input.")
688  (define-logical-character "Keep"  (define-logical-key-event "Keep"
689    "This character means exit but keep something around.")    "This key-event means exit but keep something around.")
690    
691    
692    
# Line 697  Line 701 
701         (get-output-stream-string s))         (get-output-stream-string s))
702      (let ((char (car chars)))      (let ((char (car chars)))
703        (if (characterp char)        (if (characterp char)
704            (print-pretty-character char s)            (write-char char s)
705            (do ((chars (logical-character-characters char) (cdr chars)))            (do ((key-events
706                ((null chars))                  (logical-key-event-key-events char)
707              (print-pretty-character (car chars) s)                  (cdr key-events)))
708              (unless (null (cdr chars))                ((null key-events))
709                (ext:print-pretty-key (car key-events) s)
710                (unless (null (cdr key-events))
711                (write-string ", " s))))                (write-string ", " s))))
712        (unless (null (cdr chars))        (unless (null (cdr chars))
713          (write-string ", " s)))))          (write-string ", " s)))))
714    
715  ;;; Command-Case-Help  --  Internal  ;;; COMMAND-CASE-HELP  --  Internal
716  ;;;  ;;;
717  ;;;    Print out a help message derived from the options in a  ;;;    Print out a help message derived from the options in a
718  ;;; random-typeout window.  ;;; random-typeout window.
# Line 721  Line 727 
727            ((null o))            ((null o))
728          (let ((string (chars-to-string (caar o))))          (let ((string (chars-to-string (caar o))))
729            (declare (simple-string string))            (declare (simple-string string))
730            (cond ((= (length string) 1)            (if (= (length string) 1)
731                   (write-char (char string 0) s)                (write-char (char string 0) s)
732                   (write-string "  - " s)                (write-line string s))
733                   (write-line (cdar o) s))            (write-string "  - " s)
734                  (t            (write-line (cdar o) s))))))
                  (write-line string s)  
                  (write-string "   - " s)  
                  (write-line (cdar o) s))))))))  

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5