with bucky bits.
A key is either a CHAR or a SPECIAL-KEY. SPECIAL-KEYs can be compared
using EQ?.
Support all the keys named in /usr/include/X11/keysym.h, using the
names X gives them (with few exceptions).
Rename most procedures for dealing with keys from "-char" to "-key" to
prevent confusion.
Requires microcode 11.91 or later because of changes to the X keyboard
event structure.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.30 1991/05/02 01:11:56 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.31 1991/08/06 15:39:54 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
"P"
(lambda (argument)
(set-command-argument! (list (* (if (pair? argument) (car argument) 1) 4)))
- (set-command-message! 'AUTO-ARGUMENT (char-name (last-command-char)))))
+ (set-command-message! 'AUTO-ARGUMENT (key-name (last-command-key)))))
(define-command digit-argument
"Part of the numeric argument for the next command."
"P"
(lambda (argument)
- (let ((digit (char->digit (char-base (last-command-char)))))
- (if digit
- (begin
- (set-command-argument!
- (cond ((eq? '- argument) (- digit))
- ((not (number? argument)) digit)
- ((negative? argument) (- (* 10 argument) digit))
- (else (+ (* 10 argument) digit))))
- (set-command-message! 'AUTO-ARGUMENT (auto-argument-mode?)))))))
+ (let ((key (last-command-key)))
+ (if (char? key)
+ (let ((digit (char->digit (char-base key))))
+ (if digit
+ (begin
+ (set-command-argument!
+ (cond ((eq? '- argument) (- digit))
+ ((not (number? argument)) digit)
+ ((negative? argument) (- (* 10 argument) digit))
+ (else (+ (* 10 argument) digit))))
+ (set-command-message! 'AUTO-ARGUMENT
+ (auto-argument-mode?)))))))))
(define-command negative-argument
"Begin a negative numeric argument for the next command."
Digits following this command become part of the argument."
"P"
(lambda (argument)
- (if (char=? #\- (char-base (last-command-char)))
+ (if (let ((key (last-command-key)))
+ (and (char? key)
+ (char=? #\- (char-base key))))
(if (not (number? argument))
((ref-command negative-argument) argument))
((ref-command digit-argument) argument))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.113 1991/05/17 00:27:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.114 1991/08/06 15:38:20 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
With an argument, insert the character that many times."
"P"
(lambda (argument)
- (insert-chars (last-command-char)
+ (insert-chars (last-command-key)
(command-argument-numeric-value argument))))
(define-command quoted-insert
"Reads a character and inserts it."
"p"
(lambda (argument)
- (let ((read-char
+ (let ((read-ascii-char
(lambda ()
- (let ((char (with-editor-interrupts-disabled keyboard-read-char)))
+ (let ((key (with-editor-interrupts-disabled keyboard-read)))
+ (or (and (char? key)
+ (char-ascii? key))
+ (editor-error "Not an ASCII character" (key-name key)))
(set-command-prompt!
- (string-append (command-prompt) (char-name char)))
- char))))
+ (string-append (command-prompt) (key-name key)))
+ key))))
(let ((read-digit
(lambda ()
- (or (char->digit (read-char) 8)
+ (or (char->digit (read-ascii-char) 8)
(editor-error "Not an octal digit")))))
(set-command-prompt! "Quote Character: ")
- (insert-chars (let ((char (read-char)))
+ (insert-chars (let ((char (read-ascii-char)))
(let ((digit (char->digit char 4)))
(if digit
(ascii->char
This command followed by an = is equivalent to a Control-=."
()
(lambda ()
- (read-extension-char char-controlify)))
+ (read-extension-key char-controlify)))
(define-command meta-prefix
"Sets Meta-bit of following character.
into Control-Meta-A. Otherwise, it turns ^A into plain Meta-A."
()
(lambda ()
- (read-extension-char
- (if (let ((char (current-command-char)))
+ (read-extension-key
+ (if (let ((char (current-command-key)))
(and (char? char)
(char=? #\altmode char)))
char-metafy
Turns a following A (or C-A) into a Control-Meta-A."
()
(lambda ()
- (read-extension-char char-control-metafy)))
+ (read-extension-key char-control-metafy)))
-(define execute-extended-chars?
+(define execute-extended-keys?
true)
(define extension-commands
(name->command 'meta-prefix)
(name->command 'control-meta-prefix)))
-(define (read-extension-char modifier)
- (if execute-extended-chars?
+(define (read-extension-key modifier)
+ (if execute-extended-keys?
(set-command-prompt-prefix!))
- (let ((char (modifier (with-editor-interrupts-disabled keyboard-read-char))))
- (if execute-extended-chars?
- (dispatch-on-char (current-comtabs) char)
- char)))
+ (let ((key (modifier (with-editor-interrupts-disabled keyboard-read))))
+ (if execute-extended-keys?
+ (dispatch-on-key (current-comtabs) key)
+ key)))
-(define-command prefix-char
+(define-command prefix-key
"This is a prefix for more commands.
It reads another character (a subcommand) and dispatches on it."
()
(lambda ()
(set-command-prompt-prefix!)
- (let ((prefix-char (current-command-char)))
- (dispatch-on-char
+ (let ((prefix-key (current-command-key)))
+ (dispatch-on-key
(current-comtabs)
- ((if (pair? prefix-char) append cons)
- prefix-char
- (list (with-editor-interrupts-disabled keyboard-read-char)))))))
+ ((if (pair? prefix-key) append cons)
+ prefix-key
+ (list (with-editor-interrupts-disabled keyboard-read)))))))
(define (set-command-prompt-prefix!)
(set-command-prompt!
(string-append-separated
(command-argument-prompt)
- (string-append (xchar->name (current-command-char)) " -"))))
+ (string-append (xkey->name (current-command-key)) " -"))))
(define-command execute-extended-command
"Read an extended command from the terminal with completion.
(dispatch-on-command
(prompt-for-command
;; Prompt with the name of the command char.
- (list (string-append (xchar->name (current-command-char)) " ")))
+ (list (string-append (xkey->name (current-command-key)) " ")))
true)))
\f
;;;; Errors
"This command is used to capture undefined keys."
()
(lambda ()
- (editor-error "Undefined command: " (xchar->name (current-command-char)))))
+ (editor-error "Undefined command: " (xkey->name (current-command-key)))))
(define (barf-if-read-only)
(editor-error "Trying to modify read only text."))
(buffer-truename buffer)
(buffer-modification-time buffer)
(not (verify-visited-file-modification-time? buffer)))
- (ask-user-about-supercession-threat buffer))))
+ (ask-user-about-supersession-threat buffer))))
-(define (ask-user-about-supercession-threat buffer)
+(define (ask-user-about-supersession-threat buffer)
(if (not
(with-selected-buffer buffer
(lambda ()
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.46 1991/04/12 23:17:56 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.47 1991/08/06 15:39:50 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(insert-newline)
((ref-command c-indent-line) false))))
((ref-command self-insert-command) false))
- (if (eqv? #\} (current-command-char))
+ (if (eqv? #\} (current-command-key))
(mark-flash (backward-one-sexp (current-point)) 'RIGHT)))))
(define-command electric-c-semi
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.9 1991/05/17 00:26:01 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.10 1991/08/06 15:38:59 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; of that license should have been included along with this file.
;;;
-;;;; Alias Characters
+;;;; Alias Keys
(declare (usual-integrations))
\f
-(define alias-characters '())
+(define alias-keys '())
-(define (define-alias-char char alias)
- (let ((entry (assq char alias-characters)))
+(define (define-alias-key key alias)
+ (let ((entry (assq key alias-keys)))
(if entry
(set-cdr! entry alias)
- (set! alias-characters (cons (cons char alias) alias-characters))))
+ (set! alias-keys (cons (cons key alias) alias-keys))))
unspecific)
-(define (undefine-alias-char char)
- (set! alias-characters (del-assq! char alias-characters))
+(define (undefine-alias-key key)
+ (set! alias-keys (del-assq! key alias-keys))
unspecific)
-(define (remap-alias-char char)
- (let ((entry (assq char alias-characters)))
+(define (remap-alias-key key)
+ (let ((entry (assq key alias-keys)))
(cond (entry
- (remap-alias-char (cdr entry)))
- ((odd? (quotient (char-bits char) 2)) ;Control bit is set
- (let ((code (char-code char))
+ (remap-alias-key (cdr entry)))
+ ((and (char? key)
+ (odd? (quotient (char-bits key) 2))) ;Control bit is set
+ (let ((code (char-code key))
(remap
(lambda (code)
- (make-char code (- (char-bits char) 2)))))
+ (make-char code (- (char-bits key) 2)))))
(cond ((<= #x40 code #x5F) (remap (- code #x40)))
((<= #x61 code #x7A) (remap (- code #x60)))
- (else char))))
- (else char))))
+ (else key))))
+ (else key))))
-(define (unmap-alias-char char)
- (if (and (ascii-controlified? char)
- (let ((code (char-code char)))
+(define (unmap-alias-key key)
+ (if (and (char? key)
+ (ascii-controlified? key)
+ (let ((code (char-code key)))
(not (or (= code #x09) ;tab
(= code #x0A) ;linefeed
(= code #x0C) ;page
(= code #x0D) ;return
(= code #x1B) ;altmode
)))
- (even? (quotient (char-bits char) 2)))
- (unmap-alias-char
- (make-char (let ((code (char-code char)))
+ (even? (quotient (char-bits key) 2)))
+ (unmap-alias-key
+ (make-char (let ((code (char-code key)))
(+ code (if (<= #x01 code #x1A) #x60 #x40)))
- (+ (char-bits char) 2)))
+ (+ (char-bits key) 2)))
(let ((entry
- (list-search-positive alias-characters
+ (list-search-positive alias-keys
(lambda (entry)
- (eqv? (cdr entry) char)))))
+ (eqv? (cdr entry) key)))))
(if entry
- (unmap-alias-char (car entry))
- char))))
+ (unmap-alias-key (car entry))
+ key))))
(define-integrable (ascii-controlified? char)
(< (char-code char) #x20))
true
boolean?)
-(define (char-name char)
- (if (ref-variable enable-emacs-key-names)
- (emacs-char-name char true)
- (char->name (unmap-alias-char char))))
+(define (key-name key)
+ (cond ((ref-variable enable-emacs-key-names)
+ (emacs-key-name key true))
+ ((special-key? key)
+ (special-key/name key))
+ (else
+ (char->name (unmap-alias-key key)))))
-(define (xchar->name xchar)
- (let ((chars (xchar->list xchar)))
+(define (xkey->name xkey)
+ (let ((keys (xkey->list xkey)))
(string-append-separated
- (char-name (car chars))
- (let ((char-name
+ (key-name (car keys))
+ (let ((key-name
(if (ref-variable enable-emacs-key-names)
- (lambda (char)
- (emacs-char-name char false))
- (lambda (char)
- (char->name (unmap-alias-char char))))))
- (let loop ((chars (cdr chars)))
- (if (null? chars)
+ (lambda (key)
+ (emacs-key-name key false))
+ (lambda (key)
+ (key->name (unmap-alias-key key))))))
+ (let loop ((keys (cdr keys)))
+ (if (null? keys)
""
(string-append-separated
- (char-name (car chars))
- (loop (cdr chars)))))))))
+ (key-name (car keys))
+ (loop (cdr keys)))))))))
+
+(define (emacs-key-name key handle-prefixes?)
+ (if (special-key? key)
+ (special-key/name key)
+ (let ((code (char-code key))
+ (bits (char-bits key)))
+ (let ((prefix
+ (lambda (bits suffix)
+ (if (zero? bits)
+ suffix
+ (string-append "M-" suffix)))))
+ (let ((process-code
+ (lambda (bits)
+ (cond ((< #x20 code #x7F)
+ (prefix bits (string (ascii->char code))))
+ ((= code #x09) (prefix bits "TAB"))
+ ((= code #x0A) (prefix bits "LFD"))
+ ((= code #x0D) (prefix bits "RET"))
+ ((= code #x1B) (prefix bits "ESC"))
+ ((= code #x20) (prefix bits "SPC"))
+ ((= code #x7F) (prefix bits "DEL"))
+ (else
+ (string-append
+ (if (zero? bits) "C-" "C-M-")
+ (string
+ (ascii->char
+ (+ code (if (<= #x01 code #x1A) #x60 #x40))))))))))
+ (cond ((< bits 2)
+ (process-code bits))
+ ((and handle-prefixes? (< bits 4))
+ (string-append (if (= 2 bits) "C-^ " "C-z ") (process-code 0)))
+ (else
+ (char->name (unmap-alias-key key)))))))))
+
+(define (key? object)
+ (or (char? object)
+ (special-key? object)))
+
+(define (key<? key1 key2)
+ (cond ((char? key2)
+ (char>? key2
+ (if (char? key1)
+ key1
+ (string-ref (special-key/name key1) 0))))
+ ((char? key1)
+ (not (or (key=? key1 key2)
+ (key<? key2 key1))))
+ (else (let ((name1 (special-key/name key1))
+ (name2 (special-key/name key2)))
+ (if (string=? name1 name2)
+ (< (special-key/bucky-bits key1)
+ (special-key/bucky-bits key2))
+ (string<? name1 name2))))))
-(define (emacs-char-name char handle-prefixes?)
- (let ((code (char-code char))
- (bits (char-bits char)))
- (let ((prefix
- (lambda (bits suffix)
- (if (zero? bits)
- suffix
- (string-append "M-" suffix)))))
- (let ((process-code
- (lambda (bits)
- (cond ((< #x20 code #x7F)
- (prefix bits (string (ascii->char code))))
- ((= code #x09) (prefix bits "TAB"))
- ((= code #x0A) (prefix bits "LFD"))
- ((= code #x0D) (prefix bits "RET"))
- ((= code #x1B) (prefix bits "ESC"))
- ((= code #x20) (prefix bits "SPC"))
- ((= code #x7F) (prefix bits "DEL"))
- (else
- (string-append
- (if (zero? bits) "C-" "C-M-")
- (string
- (ascii->char
- (+ code (if (<= #x01 code #x1A) #x60 #x40))))))))))
- (cond ((< bits 2)
- (process-code bits))
- ((and handle-prefixes? (< bits 4))
- (string-append (if (= 2 bits) "C-^ " "C-z ") (process-code 0)))
- (else
- (char->name (unmap-alias-char char))))))))
+(define (key=? key1 key2)
+ (if (and (char? key1)
+ (char? key2))
+ (char=? key1 key2)
+ (and (special-key? key1)
+ (special-key? key2)
+ (string=? (special-key/name key1)
+ (special-key/name key2))
+ (= (special-key/bucky-bits key1)
+ (special-key/bucky-bits key2)))))
-(define (xchar<? x y)
- (let loop ((x (xchar->list x)) (y (xchar->list y)))
- (or (char<? (car x) (car y))
- (and (char=? (car x) (car y))
+(define (xkey<? x y)
+ (let loop ((x (xkey->list x)) (y (xkey->list y)))
+ (or (key<? (car x) (car y))
+ (and (key=? (car x) (car y))
(not (null? (cdr y)))
(or (null? (cdr x))
(loop (cdr x) (cdr y)))))))
-(define (xchar->list xchar)
- (cond ((char? xchar)
- (list xchar))
- ((and (not (null? xchar))
- (list-of-type? xchar char?))
- xchar)
- ((and (string? xchar)
- (not (string-null? xchar)))
- (string->list xchar))
+(define (xkey->list xkey)
+ (cond ((key? xkey)
+ (list xkey))
+ ((and (not (null? xkey))
+ (list-of-type? xkey
+ (lambda (element)
+ (or (char? element)
+ (special-key? element)))))
+ xkey)
+ ((and (string? xkey)
+ (not (string-null? xkey)))
+ (string->list xkey))
(else
- (error "Not a character or list of characters" xchar))))
\ No newline at end of file
+ (error "Not a key or list of keys" xkey))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.86 1991/05/02 01:12:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.87 1991/08/06 15:40:25 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
(define *command-continuation*) ;Continuation of current command
-(define *command-char*) ;Character read to find current command
+(define *command-key*) ;Key read to find current command
(define *command*) ;The current command
(define *command-argument*) ;Argument from last command
(define *next-argument*) ;Argument to next command
(define *command-message*) ;Message from last command
(define *next-message*) ;Message to next command
(define *non-undo-count*) ;# of self-inserts since last undo boundary
-(define keyboard-chars-read) ;# of chars read from keyboard
+(define keyboard-keys-read) ;# of keys read from keyboard
(define command-history)
(define command-history-limit 30)
(define command-reader-reset-thunk)
(define command-reader-reset-continuation)
(define (initialize-command-reader!)
- (set! keyboard-chars-read 0)
+ (set! keyboard-keys-read 0)
(set! command-history (make-circular-list command-history-limit false))
(set! command-reader-reset-thunk false)
unspecific)
(call-with-current-continuation
(lambda (continuation)
(fluid-let ((*command-continuation* continuation)
- (*command-char* false)
+ (*command-key* false)
(*command*)
(*next-argument* false)
(*next-message* false))
(define (start-next-command)
(reset-command-state!)
- (let ((char (with-editor-interrupts-disabled keyboard-read-char)))
- (set! *command-char* char)
+ (let ((key (with-editor-interrupts-disabled keyboard-read)))
+ (set! *command-key* key)
(clear-message)
(set-command-prompt!
(if (not *command-argument*)
- (char-name char)
+ (key-name key)
(string-append-separated (command-argument-prompt)
- (char-name char))))
+ (key-name key))))
(let ((window (current-window)))
(%dispatch-on-command window
(comtab-entry (buffer-comtabs
(window-buffer window))
- char)
+ key)
false)))
(start-next-command))
(if *command-argument*
(set-command-prompt! (command-argument-prompt))
(reset-command-prompt!))
- (if *defining-keyboard-macro?* (keyboard-macro-finalize-chars)))
+ (if *defining-keyboard-macro?* (keyboard-macro-finalize-keys)))
\f
;;; The procedures for executing commands come in two flavors. The
;;; difference is that the EXECUTE-foo procedures reset the command
;;; latter should only be used by "prefix" commands such as C-X or
;;; C-4, since they want arguments, messages, etc. to be passed on.
-(define-integrable (execute-char comtab char)
+(define-integrable (execute-key comtab key)
(reset-command-state!)
- (dispatch-on-char comtab char))
+ (dispatch-on-key comtab key))
(define-integrable (execute-command command)
(reset-command-state!)
(%dispatch-on-command (current-window) command false))
-(define (read-and-dispatch-on-char)
- (dispatch-on-char (current-comtabs)
- (with-editor-interrupts-disabled keyboard-read-char)))
+(define (read-and-dispatch-on-key)
+ (dispatch-on-key (current-comtabs)
+ (with-editor-interrupts-disabled keyboard-read)))
-(define (dispatch-on-char comtab char)
- (set! *command-char* char)
+(define (dispatch-on-key comtab key)
+ (set! *command-key* key)
(set-command-prompt!
- (string-append-separated (command-argument-prompt) (xchar->name char)))
- (%dispatch-on-command (current-window) (comtab-entry comtab char) false))
+ (string-append-separated (command-argument-prompt) (xkey->name key)))
+ (%dispatch-on-command (current-window) (comtab-entry comtab key) false))
(define (dispatch-on-command command #!optional record?)
(%dispatch-on-command (current-window)
(keyboard-macro-disable)
(*command-continuation* (if (default-object? value) 'ABORT value)))
-(define-integrable (current-command-char)
- *command-char*)
+(define-integrable (current-command-key)
+ *command-key*)
-(define (last-command-char)
- (if (char? *command-char*)
- *command-char*
- (car (last-pair *command-char*))))
+(define (last-command-key)
+ (if (key? *command-key*)
+ *command-key*
+ (car (last-pair *command-key*))))
(define-integrable (current-command)
*command*)
(< point-x (-1+ (window-x-size window))))
(window-direct-output-backward-char! window)
(normal)))
- ((or (eq? command (ref-command-object self-insert-command))
- (and (eq? command (ref-command-object auto-fill-space))
- (not (auto-fill-break? point)))
- (command-argument-self-insert? command))
- (let ((char *command-char*))
+ ((and (not (special-key? *command-key*))
+ (or (eq? command (ref-command-object self-insert-command))
+ (and (eq? command (ref-command-object auto-fill-space))
+ (not (auto-fill-break? point)))
+ (command-argument-self-insert? command)))
+ (let ((key *command-key*))
(if (let ((buffer (window-buffer window)))
(and (buffer-auto-save-modified? buffer)
(null? (cdr (buffer-windows buffer)))
(line-end? point)
- (char-graphic? char)
+ (char-graphic? key)
(< point-x (-1+ (window-x-size window)))))
(begin
(if (or (zero? *non-undo-count*)
(set! *non-undo-count* 0)
(undo-boundary! point)))
(set! *non-undo-count* (1+ *non-undo-count*))
- (window-direct-output-insert-char! window char))
- (region-insert-char! point char))))
+ (window-direct-output-insert-char! window key))
+ (region-insert-char! point key))))
(else
(normal))))))
\f
(lambda (arguments expressions any-from-tty?)
(if (or record?
(and any-from-tty?
- (not (prefix-char-list? (current-comtabs)
- (current-command-char)))))
+ (not (prefix-key-list? (current-comtabs)
+ (current-command-key)))))
(record-command-arguments expressions))
arguments)))
((null? specification)
(if record? (record-command-arguments '()))
'())
(else
- (let ((old-chars-read keyboard-chars-read))
+ (let ((old-keys-read keyboard-keys-read))
(let ((arguments (specification)))
- (if (or record? (not (= keyboard-chars-read old-chars-read)))
+ (if (or record? (not (= keyboard-keys-read old-keys-read)))
(record-command-arguments (map quotify-sexp arguments)))
arguments))))))
(eval-with-history expression environment)))
(cdr entry))))
\f
-(define (interactive-argument char prompt)
+(define (interactive-argument key prompt)
(let ((prompting
(lambda (value)
(values value (quotify-sexp value) true)))
(varies
(lambda (value expression)
(values value expression false))))
- (case char
+ (case key
((#\b)
(prompting
(buffer-name (prompt-for-existing-buffer prompt (current-buffer)))))
(prompting (prompt-for-expression-value prompt)))
(else
(editor-error "Invalid control letter "
- char
+ key
" in interactive calling string")))))
(define (quotify-sexp sexp)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.59 1991/05/06 01:02:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.60 1991/08/06 15:39:30 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(dispatch-alists (cons '() '()) read-only true)
(button-alist '()))
-(define (set-comtab-entry! alists char command)
- (let ((entry (assq char (cdr alists))))
+(define (set-comtab-entry! alists key command)
+ (let ((entry (assq key (cdr alists))))
(if entry
(set-cdr! entry command)
- (set-cdr! alists (cons (cons char command) (cdr alists))))))
+ (set-cdr! alists (cons (cons key command) (cdr alists))))))
-(define (make-prefix-char! alists char alists*)
- (let ((entry (assq char (car alists))))
+(define (make-prefix-key! alists key alists*)
+ (let ((entry (assq key (car alists))))
(if entry
(set-cdr! entry alists*)
(set-car! alists
- (cons (cons char alists*)
+ (cons (cons key alists*)
(car alists))))))
(define (comtab-lookup-prefix comtabs key if-undefined if-defined)
(let ((alists (comtab-dispatch-alists (car comtabs))))
- (cond ((char? key)
- (if-defined alists (remap-alias-char key)))
+ (cond ((key? key)
+ (if-defined alists (remap-alias-key key)))
((pair? key)
- (let ((chars (map remap-alias-char key)))
- (let loop ((alists alists) (chars chars))
- (let ((char (car chars))
- (chars (cdr chars)))
- (cond ((null? chars)
- (if-defined alists char))
- ((assq char (car alists))
- => (lambda (entry) (loop (cdr entry) chars)))
- ((assq char (cdr alists))
+ (let ((keys (map remap-alias-key key)))
+ (let loop ((alists alists) (keys keys))
+ (let ((key (car keys))
+ (keys (cdr keys)))
+ (cond ((null? keys)
+ (if-defined alists key))
+ ((assq key (car alists))
+ => (lambda (entry) (loop (cdr entry) keys)))
+ ((assq key (cdr alists))
(error "Illegal prefix key:" key))
((not if-undefined)
(set-comtab-entry! alists
- char
- (ref-command-object prefix-char))
+ key
+ (ref-command-object prefix-key))
(let ((alists* (cons '() '())))
- (make-prefix-char! alists char alists*)
- (loop alists* chars)))
+ (make-prefix-key! alists key alists*)
+ (loop alists* keys)))
(else
(if-undefined)))))))
(else
(if entry
(cdr entry)
(continue))))))
- (cond ((or (char? key) (pair? key))
+ (cond ((or (key? key) (pair? key))
(comtab-lookup-prefix comtabs key continue
- (lambda (alists char)
- (try char (cdr alists)))))
+ (lambda (alists key)
+ (try key (cdr alists)))))
((button? key)
(try key (comtab-button-alist (car comtabs))))
(else
(error "Illegal comtab key" key))))))
\f
-(define (prefix-char-list? comtabs chars)
+(define (prefix-key-list? comtabs keys)
(let loop
- ((char->alist (car (comtab-dispatch-alists (car comtabs))))
- (chars (if (list? chars) chars (list chars))))
- (or (null? chars)
- (let ((entry (assq (remap-alias-char (car chars)) char->alist)))
+ ((key->alist (car (comtab-dispatch-alists (car comtabs))))
+ (keys (if (list? keys) keys (list keys))))
+ (or (null? keys)
+ (let ((entry (assq (remap-alias-key (car keys)) key->alist)))
(if entry
- (loop (cadr entry) (cdr chars))
+ (loop (cadr entry) (cdr keys))
(and (not (null? (cdr comtabs)))
(comtab? (cadr comtabs))
- (prefix-char-list? (cdr comtabs) chars)))))))
+ (prefix-key-list? (cdr comtabs) keys)))))))
(define (define-key mode key command)
(let ((comtabs (mode-comtabs (->mode mode)))
(let ((normal-key
(lambda (key)
(comtab-lookup-prefix comtabs key false
- (lambda (alists char)
- (set-comtab-entry! alists char command))))))
- (cond ((or (char? key) (pair? key))
+ (lambda (alists key)
+ (set-comtab-entry! alists key command))))))
+ (cond ((or (key? key) (pair? key))
(normal-key key))
((char-set? key)
(for-each normal-key (char-set-members key)))
(define (define-prefix-key mode key command)
(let ((comtabs (mode-comtabs (->mode mode)))
(command (->command command)))
- (if (not (or (char? key) (pair? key)))
+ (if (not (or (key? key) (pair? key)))
(error "Illegal comtab key" key))
(comtab-lookup-prefix comtabs key false
- (lambda (alists char)
- (set-comtab-entry! alists char command)
- (make-prefix-char! alists char (cons '() '())))))
+ (lambda (alists key)
+ (set-comtab-entry! alists key command)
+ (make-prefix-key! alists key (cons '() '())))))
key)
(define (define-default-key mode command)
(define (search-comtab prefix dispatch-alists)
(define (search-prefix-map alist)
(if (null? alist)
- (map (lambda (char) (append prefix (list char)))
+ (map (lambda (key) (append prefix (list key)))
(search-command-map (cdr dispatch-alists)))
(append! (search-comtab (append prefix (list (caar alist)))
(cdar alist))
;; Filter out shadowed bindings.
(list-transform-positive (search-comtabs comtabs)
- (lambda (xchar)
- (eq? command (comtab-entry comtabs xchar)))))
+ (lambda (xkey)
+ (eq? command (comtab-entry comtabs xkey)))))
(define (comtab->alist comtab)
(let loop ((prefix '()) (da (comtab-dispatch-alists comtab)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.21 1991/05/08 22:50:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.22 1991/08/06 15:38:12 arthur Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
"winout"
"winren"
"xform"
+ "key"
"xterm"))
(for-each sf-edwin
'("argred"
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.111 1991/05/18 03:01:49 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.112 1991/08/06 15:38:01 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define-key 'dired #\h 'describe-mode)
(define-key 'dired #\space 'dired-next-line)
(define-key 'dired #\c-n 'dired-next-line)
+(define-key 'dired down 'dired-next-line)
(define-key 'dired #\c-p 'dired-previous-line)
+(define-key 'dired up 'dired-previous-line)
(define-key 'dired #\n 'dired-next-line)
(define-key 'dired #\p 'dired-previous-line)
(define-key 'dired #\g 'dired-revert)
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
(standard-scheme-find-file-initialization
'#(("argred" (edwin command-argument)
edwin-syntax-table)
edwin-syntax-table)
("iserch" (edwin incremental-search)
edwin-syntax-table)
+ ("key" (edwin keys)
+ edwin-syntax-table)
("keymap" (edwin command-summary)
edwin-syntax-table)
("kilcom" (edwin)
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.16 1991/05/08 22:50:55 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.17 1991/08/06 15:40:55 arthur Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(let ((env (->environment '(EDWIN X-SCREEN))))
(load "xterm" env)
((access initialize-package! env)))
+ (let ((env (->environment '(EDWIN KEYS))))
+ (load "key" env)
+ ((access initialize-package! env)))
(let ((env (->environment '(EDWIN CONSOLE-SCREEN))))
(load "termcap" env)
(load "tterm" env)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.46 1991/08/01 17:51:07 bal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.47 1991/08/06 15:40:49 arthur Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
define-key
define-prefix-key
make-comtab
- prefix-char-list?))
+ prefix-key-list?))
(define-package (edwin undo)
(files "undo")
(export (edwin x-screen)
update-xterm-screen-names!))
+(define-package (edwin keys)
+ (files "key")
+ (parent (edwin))
+ (export (edwin x-screen)
+ x-make-special-key)
+ (export (edwin)
+ make-special-key
+ special-key?
+ special-key/name
+ special-key/bucky-bits
+ stop
+ f1
+ f2
+ f3
+ f4
+ menu
+ system
+ user
+ f5
+ f6
+ f7
+ f8
+ f9
+ f10
+ f11
+ f12
+ insertline
+ deleteline
+ insertchar
+ deletechar
+ home
+ prior
+ next
+ up
+ down
+ left
+ right
+ select
+ print)
+ (initialization (initialize-package!)))
+
(define-package (edwin console-screen)
(files "termcap" "tterm")
(parent (edwin))
command-reader
command-reader/reset-and-execute
current-command
- current-command-char
- dispatch-on-char
+ current-command-key
+ dispatch-on-key
dispatch-on-command
- execute-char
+ execute-key
execute-command
execute-command-history-entry
initialize-command-reader!
- keyboard-chars-read
- last-command-char
- read-and-dispatch-on-char
+ keyboard-keys-read
+ last-command-key
+ read-and-dispatch-on-key
set-command-argument!
set-command-message!
top-level-command-reader))
clear-message
command-prompt
initialize-typeout!
- keyboard-peek-char
+ keyboard-read
+ keyboard-peek
keyboard-read-char
message
message-args->string
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.99 1991/05/10 05:08:13 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.100 1991/08/06 15:39:10 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
It reads another character (a subcommand) and dispatches on it."
"cA B C F I K L M T V W or C-h for more help"
(lambda (char)
- (dispatch-on-char
+ (dispatch-on-key
(current-comtabs)
(list #\Backspace
(if (or (char=? char #\Backspace)
"A B C F I K L M T V W or space to scroll")))
(let ((test-for
(lambda (char*)
- (char=? char (remap-alias-char char*)))))
+ (char=? char (remap-alias-key char*)))))
(cond ((or (test-for #\C-h)
(test-for #\?))
(loop))
(if (null? bindings)
(message (command-name-string command) " is not on any keys")
(message (command-name-string command) " is on "
- (xchar->name (car bindings))))))))
+ (xkey->name (car bindings))))))))
(define-command describe-key-briefly
"Prompts for a key, and describes the command it is bound to.
(let ((command (comtab-entry (current-comtabs) key)))
(if (eq? command (ref-command-object undefined))
(help-describe-unbound-key key)
- (message (xchar->name key)
+ (message (xkey->name key)
" runs the command "
(command-name-string command))))))
(help-describe-command command)))))
(define (help-describe-unbound-key key)
- (message (xchar->name key) " is undefined"))
+ (message (xkey->name key) " is undefined"))
\f
;;;; Variables
(lambda ()
(with-output-to-help-display
(lambda ()
- (for-each (lambda (char)
- (write-string (string-append (char-name char) " ")))
+ (for-each (lambda (key)
+ (write-string (string-append (key-name key) " ")))
(reverse (ring-list (current-char-history))))))))
(define-command describe-mode
(let ((bindings (comtab-key-bindings (current-comtabs) command)))
(if (not (null? bindings))
(begin (write-string " which is bound to: ")
- (write-string (char-list-string bindings))
+ (write-string (key-list-string bindings))
(newline)))))
-(define (char-list-string xchars)
- (let loop ((xchars (sort xchars xchar<?)))
- (if (null? (cdr xchars))
- (xchar->name (car xchars))
- (string-append (xchar->name (car xchars))
+(define (key-list-string xkeys)
+ (let loop ((xkeys (sort xkeys xkey<?)))
+ (if (null? (cdr xkeys))
+ (xkey->name (car xkeys))
+ (string-append (xkey->name (car xkeys))
", "
- (loop (cdr xchars))))))
+ (loop (cdr xkeys))))))
(define (print-variable-binding variable)
(write-string " which is bound to: ")
(let ((bindings (comtab-key-bindings (current-comtabs) command)))
(if (null? bindings)
(string-append "M-x " (command-name-string command))
- (xchar->name (car bindings)))))
\ No newline at end of file
+ (xkey->name (car bindings)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.104 1991/05/16 23:14:02 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.105 1991/08/06 15:38:47 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(message (if end-visible?
"Type Space to return to Info"
"Type Space to see more"))
- (let ((char (keyboard-peek-char)))
- (if (char=? char #\Space)
+ (let ((key (keyboard-peek)))
+ (if (and (char? key)
+ (char=? key #\Space))
(begin
- (keyboard-read-char)
+ (keyboard-read)
(if (not end-visible?)
(begin
((ref-command scroll-up) false)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.89 1991/05/02 20:38:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.90 1991/08/06 15:38:30 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(if (not command-prompt-displayed?)
(clear-current-message!)))))
\f
-(define (keyboard-peek-char)
+(define (keyboard-peek)
(if *executing-keyboard-macro?*
- (keyboard-macro-peek-char)
- (keyboard-read-char-1 (editor-peek-char current-editor))))
+ (keyboard-macro-peek-key)
+ (keyboard-read-1 (editor-peek-char current-editor))))
-(define (keyboard-read-char)
- (set! keyboard-chars-read (1+ keyboard-chars-read))
+(define (keyboard-read)
+ (set! keyboard-keys-read (1+ keyboard-keys-read))
(if *executing-keyboard-macro?*
- (keyboard-macro-read-char)
- (let ((char (keyboard-read-char-1 (editor-read-char current-editor))))
+ (keyboard-macro-read-key)
+ (let ((key (keyboard-read-1 (editor-read-char current-editor))))
(set! auto-save-keystroke-count (1+ auto-save-keystroke-count))
- (ring-push! (current-char-history) char)
- (if *defining-keyboard-macro?* (keyboard-macro-write-char char))
- char)))
+ (ring-push! (current-char-history) key)
+ (if *defining-keyboard-macro?* (keyboard-macro-write-key key))
+ key)))
+
+(define (keyboard-read-char)
+ (let loop ((key (keyboard-read)))
+ (if (char? key)
+ key
+ (loop (keyboard-read)))))
-(define read-char-timeout/fast 500)
-(define read-char-timeout/slow 2000)
+(define read-key-timeout/fast 500)
+(define read-key-timeout/slow 2000)
-(define (keyboard-read-char-1 read-char)
- (remap-alias-char
+(define (keyboard-read-1 read-key)
+ (remap-alias-key
(let ((char-ready? (editor-char-ready? current-editor)))
(if (not (char-ready?))
(begin
(cond ((within-typein-edit?)
(if message-string
(begin
- (wait read-char-timeout/slow)
+ (wait read-key-timeout/slow)
(set! message-string false)
(set! message-should-be-erased? false)
(clear-current-message!))))
((and (or message-should-be-erased?
(and command-prompt-string
(not command-prompt-displayed?)))
- (wait read-char-timeout/fast))
+ (wait read-key-timeout/fast))
(set! message-string false)
(set! message-should-be-erased? false)
(if command-prompt-string
(set-current-message! command-prompt-string))
(clear-current-message!)))))
(let loop ()
- (or (read-char)
+ (or (read-key)
(begin
(accept-process-output)
(notify-process-status-changes)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.13 1991/05/17 04:52:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.14 1991/08/06 15:39:15 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(dispatch-on-command result))
(else
(push-current-mark! point)
- (if result (execute-char (current-comtabs) result))))))))
+ (if result (execute-key (current-comtabs) result))))))))
(define (isearch-loop state)
(if (not ((editor-char-ready? current-editor)))
(let ((char (keyboard-read-char)))
(let ((test-for
(lambda (char*)
- (char=? char (remap-alias-char char*)))))
+ (char=? char (remap-alias-key char*)))))
(cond ((test-for (ref-variable search-quote-char))
(isearch-append-char
state
(isearch-append-char state char))))))
\f
(define (nonincremental-search forward? regexp?)
- (cond ((char=? (remap-alias-char (ref-variable search-yank-word-char))
+ (cond ((char=? (remap-alias-key (ref-variable search-yank-word-char))
(prompt-for-typein
(if regexp?
(prompt-for-string/prompt
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.9 1991/05/06 22:27:45 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.10 1991/08/06 15:39:26 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (sort-and-simplify elements)
(map (lambda (element)
- (cons (xchar->name (car element))
+ (cons (xkey->name (car element))
(command-name-string (cdr element))))
- (sort elements (lambda (a b) (xchar<? (car a) (car b))))))
+ (sort elements (lambda (a b) (xkey<? (car a) (car b))))))
(define (sort-by-prefix elements)
(let ((prefix-alist '()))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.33 1991/03/16 00:02:29 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.34 1991/08/06 15:40:44 arthur Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(define (keyboard-macro-event)
(window-modeline-event! (current-window) 'KEYBOARD-MACRO-EVENT))
\f
-(define (keyboard-macro-read-char)
- (let ((char (keyboard-macro-peek-char)))
+(define (keyboard-macro-read-key)
+ (let ((key (keyboard-macro-peek-key)))
(set! *keyboard-macro-position* (cdr *keyboard-macro-position*))
- char))
+ key))
-(define (keyboard-macro-peek-char)
+(define (keyboard-macro-peek-key)
(if (null? *keyboard-macro-position*)
(*keyboard-macro-continuation* true)
(car *keyboard-macro-position*)))
-(define (keyboard-macro-write-char char)
- (set! keyboard-macro-buffer (cons char keyboard-macro-buffer)))
+(define (keyboard-macro-write-key key)
+ (set! keyboard-macro-buffer (cons key keyboard-macro-buffer)))
-(define (keyboard-macro-finalize-chars)
+(define (keyboard-macro-finalize-keys)
(set! keyboard-macro-buffer-end keyboard-macro-buffer))
(define (keyboard-macro-execute *macro repeat)
(keyboard-read-char)))))
(let ((test-for
(lambda (char*)
- (char=? char (remap-alias-char char*)))))
+ (char=? char (remap-alias-key char*)))))
(cond ((test-for #\space)
unspecific)
((test-for #\rubout)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.153 1991/07/31 18:24:47 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.154 1991/08/06 15:39:46 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
"Insert one or more close parens, flashing the matching open paren."
"p"
(lambda (argument)
- (insert-chars (current-command-char) argument)
- (if (positive? argument)
- (let ((point (current-point)))
- (if (not (mark-left-char-quoted? point))
- (mark-flash (backward-one-sexp point) 'RIGHT))))))
+ (let ((key (current-command-key)))
+ (if (char? key)
+ (begin
+ (insert-chars key argument)
+ (if (positive? argument)
+ (let ((point (current-point)))
+ (if (not (mark-left-char-quoted? point))
+ (mark-flash (backward-one-sexp point) 'RIGHT)))))))))
(define-command lisp-indent-line
"Indent current line as lisp code.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.128 1991/05/10 05:13:26 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.129 1991/08/06 15:37:47 arthur Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(define-key 'fundamental #\c-@ 'set-mark-command)
(define-key 'fundamental #\c-a 'beginning-of-line)
(define-key 'fundamental #\c-b 'backward-char)
-(define-prefix-key 'fundamental #\c-c 'prefix-char)
+(define-key 'fundamental left 'backward-char)
+(define-prefix-key 'fundamental #\c-c 'prefix-key)
(define-key 'fundamental #\c-d 'delete-char)
(define-key 'fundamental #\c-e 'end-of-line)
(define-key 'fundamental #\c-f 'forward-char)
+(define-key 'fundamental right 'forward-char)
(define-key 'fundamental #\c-g 'keyboard-quit)
(define-prefix-key 'fundamental #\c-h 'help-prefix)
(define-key 'fundamental #\c-i 'indent-for-tab-command)
(define-key 'fundamental #\c-l 'recenter)
(define-key 'fundamental #\c-m 'newline)
(define-key 'fundamental #\c-n 'next-line)
+(define-key 'fundamental down 'next-line)
(define-key 'fundamental #\c-o 'open-line)
(define-key 'fundamental #\c-p 'previous-line)
+(define-key 'fundamental up 'previous-line)
(define-key 'fundamental #\c-q 'quoted-insert)
(define-key 'fundamental #\c-r 'isearch-backward)
(define-key 'fundamental #\c-s 'isearch-forward)
(define-key 'fundamental #\c-u 'universal-argument)
(define-key 'fundamental #\c-v 'scroll-up)
(define-key 'fundamental #\c-w 'kill-region)
-(define-prefix-key 'fundamental #\c-x 'prefix-char)
+(define-prefix-key 'fundamental #\c-x 'prefix-key)
(define-key 'fundamental #\c-y 'yank)
(define-key 'fundamental #\c-z 'control-meta-prefix)
(define-key 'fundamental #\c-\[ 'meta-prefix)
(define-key 'fundamental #\c-^ 'control-prefix)
(define-key 'fundamental #\c-_ 'undo)
(define-key 'fundamental #\c-rubout 'backward-delete-char-untabify)
+(define-key 'fundamental #\h-space 'hyper-space)
\f
(define-key 'fundamental #\m-space 'just-one-space)
(define-key 'fundamental #\m-% 'query-replace)
(define-key 'fundamental '(#\c-x #\0) 'delete-window)
(define-key 'fundamental '(#\c-x #\1) 'delete-other-windows)
(define-key 'fundamental '(#\c-x #\2) 'split-window-vertically)
-(define-prefix-key 'fundamental '(#\c-x #\4) 'prefix-char)
+(define-prefix-key 'fundamental '(#\c-x #\4) 'prefix-key)
(define-key 'fundamental '(#\c-x #\4 #\c-f) 'find-file-other-window)
(define-key 'fundamental '(#\c-x #\4 #\.) 'find-tag-other-window)
(define-key 'fundamental '(#\c-x #\4 #\b) 'switch-to-buffer-other-window)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.41 1991/05/10 05:12:13 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.42 1991/08/06 15:37:33 arthur Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
(set-current-point!
(move-to-column (line-start (current-point) (- argument) 'FAILURE)
column)))
- (set-command-message! temporary-goal-column-tag column))))
\ No newline at end of file
+ (set-command-message! temporary-goal-column-tag column))))
+
+(define-command hyper-space
+ "Engage warp drive."
+ ()
+ (lambda ()
+ (message "Sorry, but superluminal travel is not available now.")))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.146 1991/05/21 02:04:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.147 1991/08/06 15:38:39 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(begin
(message "Hit space to flush.")
(reset-command-prompt!)
- (let ((char (keyboard-peek-char)))
- (if (char=? #\space char)
+ (let ((char (keyboard-peek)))
+ (if (and (char? char)
+ (char=? #\space char))
(begin
- (keyboard-read-char)
+ (keyboard-read)
(kill-pop-up-buffer false))))
(clear-message)))))))
(lambda ()
(prompt-for-typein (string-append prompt ": ") false
(lambda ()
- (let ((char (keyboard-read-char)))
- (set-typein-string! (char-name char) true)
- char))))))
+ (let ((key (keyboard-read)))
+ (if (not (and (char? key)
+ (char-ascii? key)))
+ (editor-error "Not an ASCII character" key))
+ (set-typein-string! (key-name key) true)
+ key))))))
(define (prompt-for-key prompt #!optional comtab)
(let ((comtab (if (default-object? comtab) (current-comtabs) comtab)))
(with-editor-interrupts-disabled
(lambda ()
(let outer-loop ((prefix '()))
- (let inner-loop ((char (keyboard-read-char)))
+ (let inner-loop ((char (keyboard-read)))
(let ((chars (append! prefix (list char))))
- (set-typein-string! (xchar->name chars) true)
- (if (prefix-char-list? comtab chars)
+ (set-typein-string! (xkey->name chars) true)
+ (if (prefix-key-list? comtab chars)
(outer-loop chars)
(let ((command (comtab-entry comtab chars)))
(if (memq command extension-commands)
(prompt-for-typein (string-append prompt " (y or n)? ") false
(lambda ()
(let loop ((lost? false))
- (let ((char (keyboard-read-char)))
- (cond ((or (char-ci=? char #\y)
- (char-ci=? char #\space))
+ (let ((char (keyboard-read)))
+ (cond ((and (char? char)
+ (or (char-ci=? char #\y)
+ (char-ci=? char #\space)))
(set-typein-string! "y" true)
true)
- ((or (char-ci=? char #\n)
- (char-ci=? char #\rubout))
+ ((and (char? char)
+ (or (char-ci=? char #\n)
+ (char-ci=? char #\rubout)))
(set-typein-string! "n" true)
false)
(else
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regcom.scm,v 1.19 1991/05/10 04:58:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regcom.scm,v 1.20 1991/08/06 15:39:38 arthur Exp $
;;;
;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
(lambda (register)
(let ((value (get-register register)))
(if (not value)
- (message "Register " (char-name register) " is empty")
+ (message "Register " (key-name register) " is empty")
(with-output-to-temporary-buffer "*Output*"
(lambda ()
(write-string "Register ")
- (write-string (char-name register))
+ (write-string (key-name register))
(write-string " contains ")
(cond ((integer? value)
(write value))
(write value)))))))))
\f
(define (register-error register . strings)
- (apply editor-error "Register " (char-name register) " " strings))
+ (apply editor-error "Register " (key-name register) " " strings))
(define (get-register char)
(let ((entry (assv char register-alist)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.70 1991/05/04 20:14:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.71 1991/08/06 15:40:39 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((char (with-editor-interrupts-disabled keyboard-peek-char)))
(let ((test-for
(lambda (char*)
- (and (char=? char (remap-alias-char char*))
+ (and (char=? char (remap-alias-key char*))
(begin
- (keyboard-read-char)
+ (keyboard-read)
true)))))
(cond ((test-for #\C-h)
(with-output-to-help-display
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.59 1991/05/17 18:39:00 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.60 1991/08/06 15:39:42 arthur Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((char (prompt-for-char "Character search")))
(let ((test-for
(lambda (char*)
- (char=? char (remap-alias-char char*)))))
+ (char=? char (remap-alias-key char*)))))
(if (test-for #\C-a)
(dispatch-on-command
(if forward?
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.104 1991/05/18 03:23:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.105 1991/08/06 15:39:34 arthur Exp $
;;;
;;; Copyright (c) 1987, 1989-91 Massachusetts Institute of Technology
;;;
""
(let ((char (mark-right-char point)))
(let ((n (char->ascii char)))
- (string-append "Char: " (char-name char)
+ (string-append "Char: " (key-name char)
" ("
(if (zero? n) "" "0")
(number->string n 8)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.20 1991/07/26 21:56:09 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.21 1991/08/06 15:39:21 arthur Exp $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
;;;
;;;; X Terminal
+;;; Package: (edwin x-screen)
(declare (usual-integrations))
\f
\f
;;;; Event Handling
+(define-integrable control-bucky-bit 2)
+
(define (get-xterm-input-operations)
(let ((display x-display-data)
(queue x-display-events)
(bucky-bits 0)
+ (keysym false)
+ (special-key? false)
(string false)
(start 0)
(end 0)
(lambda (event)
(set! string (vector-ref event 2))
(set! bucky-bits (vector-ref event 3))
+ (set! keysym (vector-ref event 4))
(set! start 0)
(set! end (string-length string))
- (if signal-interrupts?
+ (set! special-key? (zero? end))
+ (if (and signal-interrupts?
+ (not special-key?))
(let ((i (string-find-previous-char string #\BEL)))
(if i
(begin
(error "#F returned from blocking read"))
((eq? true event)
false)
- ((fix:= event-type:key-press (vector-ref event 0))
+ ((fix:= event-type:key-press
+ (vector-ref event 0))
(process-key-press-event event)
- (if (fix:< start end) true (loop)))
+ (if (or special-key? (fix:< start end))
+ true
+ (loop)))
(else
(process-special-event event)
(loop)))))))
(if (and (zero? start)
(= end 1))
(make-char (char-code character)
- bucky-bits)
+ (fix:andc bucky-bits
+ control-bucky-bit))
character))))
(values
(lambda () ;halt-update?
- (if (or (fix:< start end) pending-event)
+ (if (or special-key? (fix:< start end) pending-event)
true
(let ((event (get-next-event 0)))
(and event
(set! pending-event event)
true)))))
(lambda () ;char-ready?
- (if (fix:< start end)
+ (if (or special-key? (fix:< start end))
true
(let loop ()
(let ((event (get-next-event 0)))
false)
((fix:= event-type:key-press (vector-ref event 0))
(process-key-press-event event)
- (if (fix:< start end) true (loop)))
+ (if (or special-key? (fix:< start end))
+ true
+ (loop)))
(else
(process-special-event event)
(loop)))))))
(lambda () ;peek-char
- (and (or (fix:< start end) (guarantee-input))
- (apply-bucky-bits (string-ref string start))))
+ (and (or special-key? (fix:< start end) (guarantee-input))
+ (if special-key?
+ (x-make-special-key keysym bucky-bits)
+ (apply-bucky-bits (string-ref string start)))))
(lambda () ;read-char
- (and (or (fix:< start end) (guarantee-input))
- (let ((char
- (apply-bucky-bits
- (string-ref string start))))
- (set! start (fix:+ start 1))
- char)))))))))
+ (and (or special-key? (fix:< start end) (guarantee-input))
+ (if special-key?
+ (begin (set! special-key? false)
+ (x-make-special-key keysym bucky-bits))
+ (let ((char
+ (apply-bucky-bits
+ (string-ref string start))))
+ (set! start (fix:+ start 1))
+ char))))))))))
\f
(define (read-event queue display time-limit)
;; If no time-limit, we're reading from the keyboard. In that case,
projects / mit-scheme.git / commitdiff