Order predicates for keys must also handle buttons. Otherwise, the

code that sorts key bindings will break.

diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm
index e78b97d4222c531637bd5f7c3fa2c05029e0f303..0e160cc9577f1b2c3de06e9d04f1cf4912c307ef 100644 (file)
--- a/v7/src/edwin/calias.scm
+++ b/v7/src/edwin/calias.scm
@@ -1,25 +1,27 @@
-;;; -*-Scheme-*-
-;;;
-;;; $Id: calias.scm,v 1.26 2002/11/20 19:45:58 cph Exp $
-;;;
-;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology
-;;;
-;;; This file is part of MIT Scheme.
-;;;
-;;; MIT Scheme is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published
-;;; by the Free Software Foundation; either version 2 of the License,
-;;; or (at your option) any later version.
-;;;
-;;; MIT Scheme is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with MIT Scheme; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-;;; 02111-1307, USA.
+#| -*-Scheme-*-
+
+$Id: calias.scm,v 1.27 2003/01/10 18:50:20 cph Exp $
+
+Copyright 1986,1989,1991,1992,1994,1995 Massachusetts Institute of Technology
+Copyright 1998,2000,2001,2002,2003 Massachusetts Institute of Technology
+
+This file is part of MIT Scheme.
+
+MIT Scheme is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
+
+MIT Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT Scheme; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+|#
 
 ;;;; Alias Keys
 
@@ -89,7 +91,7 @@
        ((char? key) (char->name (unmap-alias-key key)))
        ((special-key? key) (special-key/name key))
        ((button? key) (button-name key))
-        (else (error "Unknown key type:" key))))
+        (else (error:wrong-type-argument key "key" 'KEY-NAME))))
 
 (define (button-name button)
   (string-append "button-"
@@ -148,36 +150,49 @@
                  (char->name (unmap-alias-key key))))))
        ((special-key? key) (special-key/name key))
        ((button? key) (button-name key))
-        (else (error "Unknown key type:" key))))
+        (else (error:wrong-type-argument key "key" 'EMACS-KEY-NAME))))
 \f
 (define (key? object)
   (or (char? object)
-      (special-key? object)))
+      (special-key? object)
+      (button? key)))
+
+(define (key-bucky-bits key)
+  (cond ((char? key) (char-bits key))
+       ((special-key? key) (special-key/bucky-bits key))
+       ((button? key) (button/bucky-bits key))
+        (else (error:wrong-type-argument key "key" 'KEY-BUCKY-BITS))))
 
 (define (key<? key1 key2)
-  (if (char? key1)
-      (if (char? key2)
-         (char<? key1 key2)
-         (<= (char-bits key1) (special-key/bucky-bits key2)))
-      (let ((bits1 (special-key/bucky-bits key1)))
-       (if (char? key2)
-           (< bits1 (char-bits key2))
-           (let ((bits2 (special-key/bucky-bits key2)))
-             (or (< bits1 bits2)
-                 (and (= bits1 bits2)
-                      (string<? (special-key/name key1)
-                                (special-key/name key2)))))))))
+  (or (< (key-bucky-bits key1) (key-bucky-bits key2))
+      (and (= (key-bucky-bits key1) (key-bucky-bits key2))
+          (cond ((char? key1)
+                 (or (not (char? key2))
+                     (char<? key1 key2)))
+                ((special-key? key1)
+                 (if (special-key? key2)
+                     (string<? (special-key/name key1)
+                               (special-key/name key2))
+                     (button? key2)))
+                ((button? key1)
+                 (and (button? key2)
+                      (string<? (button-name key1) (button-name key2))))
+                (else
+                 (error:wrong-type-argument key1 "key" 'KEY<?))))))
 
 (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)))))
+  (and (= (key-bucky-bits key1) (key-bucky-bits key2))
+       (cond ((char? key1)
+             (and (char? key2)
+                  (char=? key1 key2)))
+            ((special-key? key1)
+             (and (special-key? key2)
+                  (string=? (special-key/name key1) (special-key/name key2))))
+            ((button? key1)
+             (and (button? key2)
+                  (string<? (button-name key1) (button-name key2))))
+            (else
+             (error:wrong-type-argument key1 "key" 'KEY=?)))))
 
 (define (xkey<? x y)
   (let loop ((x (xkey->list x)) (y (xkey->list y)))

diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm
index a87efe89079f1d58a0efc6420d9ea3186295a7c3..887b43c6f18d5d4b0822fa8a33cd45d203e8038b 100644 (file)
--- a/v7/src/edwin/edtstr.scm
+++ b/v7/src/edwin/edtstr.scm
@@ -1,15 +1,15 @@
 #| -*-Scheme-*-
 
-$Id: edtstr.scm,v 1.25 2003/01/09 20:52:21 cph Exp $
+$Id: edtstr.scm,v 1.26 2003/01/10 18:50:26 cph Exp $
 
-Copyright (c) 1989,1990,1991,1992,2003 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
-MIT Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published
-by the Free Software Foundation; either version 2 of the License,
-or (at your option) any later version.
+MIT Scheme is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
 
 MIT Scheme is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,9 +17,8 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 General Public License for more details.
 
 You should have received a copy of the GNU General Public License
-along with MIT Scheme; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
+along with MIT Scheme; if not, write to the Free Software Foundation,
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 |#
 
@@ -113,41 +112,33 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
      (lambda ()
        (set-editor-button-event! current-editor old-button-event)))))
 
-(define button-record-type
-  (make-record-type 'BUTTON '(NUMBER DOWN?)))
+(define-record-type button-record-type
+  (%%make-button number down?)
+  button?
+  (number button/number)
+  (down? button/down?))
 
 (define make-down-button)
 (define make-up-button)
 (let ((%make-button
-       (let ((constructor
-             (record-constructor button-record-type '(NUMBER DOWN?))))
-        (lambda (buttons number down?)
-          (or (vector-ref buttons number)
-              (let ((button (constructor number down?)))
-                (vector-set! buttons number button)
-                button)))))
+       (lambda (buttons number down?)
+        (or (vector-ref buttons number)
+            (let ((button (%%make-button number down?)))
+              (vector-set! buttons number button)
+              button))))
       (down-buttons '#())
       (up-buttons '#()))
   (set! make-down-button
        (lambda (number)
          (if (>= number (vector-length down-buttons))
-             (set! down-buttons (vector-grow down-buttons (+ number 1))))
+             (set! down-buttons (vector-grow down-buttons (+ number 1) #f)))
          (%make-button down-buttons number #t)))
   (set! make-up-button
        (lambda (number)
          (if (>= number (vector-length up-buttons))
-             (set! up-buttons (vector-grow up-buttons (+ number 1))))
+             (set! up-buttons (vector-grow up-buttons (+ number 1) #f)))
          (%make-button up-buttons number #f))))
 
-(define button?
-  (record-predicate button-record-type))
-
-(define button/number
-  (record-accessor button-record-type 'NUMBER))
-
-(define button/down?
-  (record-accessor button-record-type 'DOWN?))
-
 (define (down-button? object)
   (and (button? object)
        (button/down? object)))
@@ -156,6 +147,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (and (button? object)
        (not (button/down? object))))
 
+(define (button/bucky-bits button)
+  button
+  0)
+
 (set-record-type-unparser-method! button-record-type
   (unparser/standard-method (record-type-name button-record-type)
     (lambda (state button)