From 01392066afdcc3f0725c10079e6368942b38d2db Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 8 Sep 1998 04:10:26 +0000
Subject: [PATCH] Fix bug: when defining a command that is bound to a
 lower-case letter, don't define the corresponding upper-case letter unless it
 is undefined in the entire comtab chain.  Previously, the code only looked at
 the current comtab and ignored the ancestor comtabs.

---
 v7/src/edwin/comtab.scm | 89 +++++++++++++++++++++--------------------
 1 file changed, 46 insertions(+), 43 deletions(-)

diff --git a/v7/src/edwin/comtab.scm b/v7/src/edwin/comtab.scm
index 16ca00d28..a766d34b0 100644
--- a/v7/src/edwin/comtab.scm
+++ b/v7/src/edwin/comtab.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: comtab.scm,v 1.67 1996/10/01 05:55:55 cph Exp $
+;;;	$Id: comtab.scm,v 1.68 1998/09/08 04:10:26 cph Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-98 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -78,29 +78,23 @@
 			      (lambda ()
 				(set-comtab-vector! comtab vector)
 				(set-comtab-alist! comtab alist)))
-			     (let ((vector (make-vector 256 false)))
-			       (let ((alist
-				      (list-transform-negative alist
-					(lambda (entry)
-					  (let ((key (car entry)))
-					    (and (char? key)
-						 (< (char->integer key) 256)
-						 (begin
-						   (vector-set!
-						    vector
-						    (char->integer key)
-						    (cdr entry))
-						   true)))))))
-				 (without-interrupts
-				  (lambda ()
-				    (set-comtab-vector! comtab vector)
-				    (set-comtab-alist! comtab alist))))))))))))
-	 ;; Defining a lower-case character defines the corresponding
-	 ;; upper-case character to be an alias if not already defined.
-	 (let ((key* (char-upcase key)))
-	   (if (and (not (char=? key key*))
-		    (not (comtab-get comtab key*)))
-	       (comtab-put! comtab key* (cons comtab key)))))
+			     (let* ((vector (make-vector 256 false))
+				    (alist
+				     (list-transform-negative alist
+				       (lambda (entry)
+					 (let ((key (car entry)))
+					   (and (char? key)
+						(< (char->integer key) 256)
+						(begin
+						  (vector-set!
+						   vector
+						   (char->integer key)
+						   (cdr entry))
+						  true)))))))
+			       (without-interrupts
+				(lambda ()
+				  (set-comtab-vector! comtab vector)
+				  (set-comtab-alist! comtab alist))))))))))))
 	(else
 	 (let ((alist (comtab-alist comtab)))
 	   (let ((entry (assq key alist)))
@@ -284,13 +278,13 @@
 	(command&comtab? object))))
 
 (define (define-key mode key datum)
-  (%define-key (car (guarantee-comtabs mode 'DEFINE-KEY))
+  (%define-key (guarantee-comtabs mode 'DEFINE-KEY)
 	       key
 	       (if (valid-datum? datum) datum (->command datum))
 	       'DEFINE-KEY))
 
 (define (define-prefix-key mode key #!optional command)
-  (%define-key (car (guarantee-comtabs mode 'DEFINE-PREFIX-KEY))
+  (%define-key (guarantee-comtabs mode 'DEFINE-PREFIX-KEY)
 	       (begin
 		 (if (button? key)
 		     (error:wrong-type-argument key
@@ -306,22 +300,31 @@
 			   (cons command comtab)))))
 	       'DEFINE-PREFIX-KEY))
 
-(define (%define-key comtab key datum procedure)
-  (cond ((or (key? key) (button? key))
-	 (comtab-put! comtab (remap-alias-key key) datum))
-	((char-set? key)
-	 (for-each (lambda (key)
-		     (comtab-put! comtab (remap-alias-key key) datum))
-		   (char-set-members key)))
-	((prefixed-key? key)
-	 (let ((prefix (except-last-pair key)))
-	   (comtab-put! (if (null? prefix)
-			    comtab
-			    (lookup-prefix comtab prefix true))
-			(remap-alias-key (car (last-pair key)))
-			datum)))
-	(else
-	 (error:wrong-type-argument key "comtab key" procedure)))
+(define (%define-key comtabs key datum procedure)
+  (let* ((comtab (car comtabs))
+	 (put!
+	  (lambda (key)
+	    (comtab-put! comtab (remap-alias-key key) datum)
+	    ;; Defining a lower-case character defines the
+	    ;; corresponding upper-case character to be an alias if not
+	    ;; already defined.
+	    (if (and (char? key) (char-lower-case? key))
+		(let ((key* (char-upcase key)))
+		  (if (not (lookup-key comtabs key*))
+		      (comtab-put! comtab key* (cons comtab key))))))))
+    (cond ((or (key? key) (button? key))
+	   (put! key))
+	  ((char-set? key)
+	   (for-each put! (char-set-members key)))
+	  ((prefixed-key? key)
+	   (let ((prefix (except-last-pair key)))
+	     (comtab-put! (if (null? prefix)
+			      comtab
+			      (lookup-prefix comtab prefix true))
+			  (remap-alias-key (car (last-pair key)))
+			  datum)))
+	  (else
+	   (error:wrong-type-argument key "comtab key" procedure))))
   key)
 
 (define (comtab-alist* comtab)
-- 
2.25.1