From: Chris Hanson Date: Wed, 21 Jun 1989 10:31:07 +0000 (+0000) Subject: Change comtabs to have a separate slot for mouse-button bindings. X-Git-Tag: 20090517-FFI~11990 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f336b907f8b3343ac81f5b66a9683489bf3ccfa3;p=mit-scheme.git Change comtabs to have a separate slot for mouse-button bindings. These are treated differently because mouse-buttons aren't bound to commands but instead to procedures with a certain calling protocol. --- diff --git a/v7/src/edwin/comtab.scm b/v7/src/edwin/comtab.scm index ab280d740..29b942f6d 100644 --- a/v7/src/edwin/comtab.scm +++ b/v7/src/edwin/comtab.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.53 1989/06/20 16:20:48 markf Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.54 1989/06/21 10:31:07 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -47,17 +47,15 @@ (declare (usual-integrations)) (define-structure (comtab (constructor make-comtab ())) - (dispatch-alists (cons '() '()) read-only true)) + (dispatch-alists (cons '() '()) read-only true) + (button-alist '())) -(define (set-comtab-entry! alists char-or-button command) - (let ((char-or-button - (if (char? char-or-button) - (remap-alias-char char-or-button) - char-or-button))) - (let ((entry (assq char-or-button (cdr alists)))) +(define (set-comtab-entry! alists char command) + (let ((char (remap-alias-char char))) + (let ((entry (assq char (cdr alists)))) (if entry (set-cdr! entry command) - (set-cdr! alists (cons (cons char-or-button command) (cdr alists)))))) + (set-cdr! alists (cons (cons char command) (cdr alists)))))) unspecific) (define (make-prefix-char! alists char alists*) @@ -68,48 +66,50 @@ (set-car! alists (cons (cons char alists*) (car alists)))))) unspecific) -(define (comtab-lookup-prefix comtabs char-or-button receiver #!optional if-undefined) - (define (loop char->alist chars) - (let ((entry (assq (remap-alias-char (car chars)) char->alist))) - (if entry - (if (null? (cddr chars)) - (receiver (cdr entry) (cadr chars)) - (loop (cadr entry) (cdr chars))) - (if (default-object? if-undefined) - (error "Not a prefix character" (car chars)) - (if-undefined))))) - (cond ((or (char? char-or-button) - (button? char-or-button)) - (receiver (comtab-dispatch-alists (car comtabs)) char-or-button)) - ((pair? char-or-button) - (if (null? (cdr char-or-button)) - (receiver (comtab-dispatch-alists (car comtabs)) (car char-or-button)) - (loop (car (comtab-dispatch-alists (car comtabs))) char-or-button))) +(define (comtab-lookup-prefix comtabs key if-undefined if-defined) + (cond ((char? key) + (if-defined (comtab-dispatch-alists (car comtabs)) key)) + ((pair? key) + (if (null? (cdr key)) + (if-defined (comtab-dispatch-alists (car comtabs)) (car key)) + (let loop + ((char->alist (car (comtab-dispatch-alists (car comtabs)))) + (chars key)) + (let ((entry (assq (remap-alias-char (car chars)) char->alist))) + (if entry + (if (null? (cddr chars)) + (if-defined (cdr entry) (cadr chars)) + (loop (cadr entry) (cdr chars))) + (if if-undefined + (if-undefined) + (error "Not a prefix character" (car chars)))))))) (else - (error "Unrecognizable character" char-or-button)))) - -(define (comtab-entry comtabs xchar-or-button) + (error "Illegal comtab key" key)))) + +(define (comtab-entry comtabs key) (let ((continue (lambda () - (cond ((null? (cdr comtabs)) bad-command) - ((comtab? (cadr comtabs)) (comtab-entry (cdr comtabs) xchar-or-button)) + (cond ((null? (cdr comtabs)) (if (button? key) false bad-command)) + ((comtab? (cadr comtabs)) (comtab-entry (cdr comtabs) key)) (else (cadr comtabs)))))) - (comtab-lookup-prefix comtabs xchar-or-button - (lambda (alists char-or-button) - (let ((entry (assq - (if (or (char? char-or-button) - (pair? char-or-button)) - (remap-alias-char char-or-button) - char-or-button) - (cdr alists)))) - (if entry - (cdr entry) - (continue)))) - continue))) + (let ((try + (lambda (key alist) + (let ((entry (assq key alist))) + (if entry + (cdr entry) + (continue)))))) + (cond ((or (char? key) (pair? key)) + (comtab-lookup-prefix comtabs key continue + (lambda (alists char) + (try (remap-alias-char char) (cdr alists))))) + ((button? key) + (try key (comtab-button-alist (car comtabs)))) + (else + (error "Illegal comtab key" key)))))) (define bad-command (name->command '^r-bad-command)) - + (define (prefix-char-list? comtabs chars) (let loop ((char->alist (car (comtab-dispatch-alists (car comtabs)))) @@ -122,35 +122,40 @@ (comtab? (cadr comtabs)) (prefix-char-list? (cdr comtabs) chars))))))) -(define (define-key mode-name char-or-button command-name) - (let ((comtabs (mode-comtabs (name->mode mode-name))) - (command (name->command command-name))) - (cond ((or (char? char-or-button) - (pair? char-or-button) - (button? char-or-button)) - (%define-key comtabs char-or-button command)) - ((char-set? char-or-button) - (for-each (lambda (char) (%define-key comtabs char command)) - (char-set-members char-or-button))) - (else - (error "not a character or button" char-or-button)))) - char-or-button) - -(define (%define-key comtabs xchar command) - (comtab-lookup-prefix comtabs xchar - (lambda (alists char) - (set-comtab-entry! alists char command)))) +(define (define-key mode-name key command) + (let ((comtabs (mode-comtabs (name->mode mode-name)))) + (if (button? key) + (let ((alist (comtab-button-alist (car comtabs)))) + (let ((entry (assq key alist))) + (if entry + (set-cdr! entry command) + (set-comtab-button-alist! (car comtabs) + (cons (cons key command) alist))))) + (let ((normal-key + (let ((command + (if (command? command) command (name->command command)))) + (lambda (key) + (comtab-lookup-prefix comtabs key false + (lambda (alists char) + (set-comtab-entry! alists char command))))))) + (cond ((or (char? key) (pair? key)) + (normal-key key)) + ((char-set? key) + (for-each normal-key (char-set-members key))) + (else + (error "Illegal comtab key" key)))))) + key) -(define (define-prefix-key mode-name char command-name) +(define (define-prefix-key mode-name key command-name) (let ((comtabs (mode-comtabs (name->mode mode-name))) (command (name->command command-name))) - (if (or (char? char) (pair? char)) - (comtab-lookup-prefix comtabs char + (if (or (char? key) (pair? key)) + (comtab-lookup-prefix comtabs key false (lambda (alists char) (set-comtab-entry! alists char command) (make-prefix-char! alists char (cons '() '())))) - (error "not a character" char))) - char) + (error "Illegal comtab key" key))) + key) (define (define-default-key mode-name command-name) (let ((comtabs (mode-comtabs (name->mode mode-name))))