From 1c109c8456148bbe173b6d5db74cf61a118b493c Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 24 Oct 2006 04:14:11 +0000
Subject: [PATCH] Eliminate CHAR-CONTROLIFY and friends in favor of more
 general MERGE-BUCKY-BITS.  Use new bucky-bit abstractions from runtime.

---
 v7/src/edwin/basic.scm   | 23 +++++++++++++----------
 v7/src/edwin/calias.scm  | 23 +++++++++++++++--------
 v7/src/edwin/edwin.pkg   |  6 +-----
 v7/src/edwin/os2term.scm |  8 +++++---
 v7/src/edwin/tterm.scm   |  7 ++++---
 v7/src/edwin/utils.scm   | 32 +++++++++-----------------------
 v7/src/edwin/xterm.scm   | 12 +++---------
 7 files changed, 50 insertions(+), 61 deletions(-)

diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm
index 7061a365d..74f7ec853 100644
--- a/v7/src/edwin/basic.scm
+++ b/v7/src/edwin/basic.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: basic.scm,v 1.144 2005/10/24 01:55:50 cph Exp $
+$Id: basic.scm,v 1.145 2006/10/24 04:13:14 cph Exp $
 
 Copyright 1987,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
-Copyright 1999,2000,2005 Massachusetts Institute of Technology
+Copyright 1999,2000,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -156,7 +156,9 @@ amount of space allocated to hold them is
 This command followed by an = is equivalent to a Control-=."
   ()
   (lambda ()
-    (read-extension-key char-controlify)))
+    (read-extension-key
+     (lambda (char)
+       (merge-bucky-bits char char-bit:control)))))
 
 (define-command meta-prefix
   "Sets Meta-bit of following character. 
@@ -166,19 +168,20 @@ into Control-Meta-A.  Otherwise, it turns ^A into plain Meta-A."
   ()
   (lambda ()
     (read-extension-key
-     (if (let ((char (current-command-key)))
-	   (and (char? char)
-		(char=? #\altmode char)))
-	 char-metafy
-	 (lambda (char)
-	   (char-metafy (char-base char)))))))
+     (lambda (char)
+       (merge-bucky-bits (if (eqv? (current-command-key) #\altmode)
+			     char
+			     (char-base char))
+			 char-bit:meta)))))
 
 (define-command control-meta-prefix
   "Sets Control- and Meta-bits of following character.
 Turns a following A (or C-A) into a Control-Meta-A."
   ()
   (lambda ()
-    (read-extension-key char-control-metafy)))
+    (read-extension-key
+     (lambda (char)
+       (merge-bucky-bits char (fix:or char-bit:control char-bit:meta))))))
 
 (define execute-extended-keys?
   #t)
diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm
index aa9fdcacb..279cb2bf4 100644
--- a/v7/src/edwin/calias.scm
+++ b/v7/src/edwin/calias.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: calias.scm,v 1.32 2006/10/22 16:09:24 cph Exp $
+$Id: calias.scm,v 1.33 2006/10/24 04:13:23 cph Exp $
 
 Copyright 1986,1989,1991,1992,1994,1995 Massachusetts Institute of Technology
 Copyright 1998,2000,2001,2002,2003,2006 Massachusetts Institute of Technology
@@ -46,11 +46,12 @@ USA.
     (cond (entry
 	   (remap-alias-key (cdr entry)))
 	  ((and (char? key)
-		(odd? (quotient (char-bits key) 2))) ;Control bit is set
+		(char-bits-set? char-bit:control key))
 	   (let ((code (char-code key))
 		 (remap
 		  (lambda (code)
-		    (make-char code (- (char-bits key) 2)))))
+		    (make-char code
+			       (fix:andc (char-bits key) char-bit:control)))))
 	     (cond ((<= #x40 code #x5F) (remap (- code #x40)))
 		   ((<= #x61 code #x7A) (remap (- code #x60)))
 		   (else key))))
@@ -66,11 +67,11 @@ USA.
 		      (= code #x0D)	;return
 		      (= code #x1B)	;altmode
 		      )))
-	   (even? (quotient (char-bits key) 2)))
+	   (char-bits-clear? char-bit:control key))
       (unmap-alias-key
        (make-char (let ((code (char-code key)))
 		    (+ code (if (<= #x01 code #x1A) #x60 #x40)))
-		  (+ (char-bits key) 2)))
+		  (fix:or (char-bits key) char-bit:control)))
       (let ((entry
 	     (list-search-positive alias-keys
 	       (lambda (entry)
@@ -133,10 +134,16 @@ USA.
 			     "DEL"
 			     (vector-ref (ref-variable char-image-strings #f)
 					 code)))))
-	   (cond ((< bits 2)		; no bits or Meta only
+	   (cond ((or (fix:= bits 0)
+		      (fix:= bits char-bit:meta))
 		  (process-code bits))
-		 ((and handle-prefixes? (< bits 4))
-		  (string-append (if (= 2 bits) "C-^ " "C-z ")
+		 ((and handle-prefixes?
+		       (not (fix:= 0 (fix:and bits
+					      (fix:or char-bit:control
+						      char-bit:meta)))))
+		  (string-append (if (fix:= bits char-bit:control)
+				     "C-^ "
+				     "C-z ")
 				 (process-code 0)))
 		 (else
 		  (char->name (unmap-alias-key key))))))
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 12c4ee4e5..bca6fbe28 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.297 2006/10/22 16:09:41 cph Exp $
+$Id: edwin.pkg,v 1.298 2006/10/24 04:13:31 cph Exp $
 
 Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology
@@ -466,10 +466,6 @@ USA.
   (export (edwin)
 	  append-command-prompt!
 	  append-message
-	  char-base
-	  char-control-metafy
-	  char-controlify
-	  char-metafy
 	  clear-message
 	  command-prompt
 	  keyboard-read
diff --git a/v7/src/edwin/os2term.scm b/v7/src/edwin/os2term.scm
index 33ddcea50..89d7b3ac0 100644
--- a/v7/src/edwin/os2term.scm
+++ b/v7/src/edwin/os2term.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2term.scm,v 1.26 2006/10/22 16:09:48 cph Exp $
+$Id: os2term.scm,v 1.27 2006/10/24 04:13:41 cph Exp $
 
 Copyright 1994,1995,1996,1997,2000,2003 Massachusetts Institute of Technology
 Copyright 2006 Massachusetts Institute of Technology
@@ -810,8 +810,10 @@ USA.
       (let ((process-code
 	     (lambda (code)
 	       (if (and (fix:<= #x40 code) (fix:< code #x60)
-			(fix:= (fix:and bits #x1) #x1))
-		   (make-char (fix:and code #o037) (fix:andc bits #x1))
+			(fix:= (fix:and bits char-bit:control)
+			       char-bit:control))
+		   (make-char (fix:and code #x1F)
+			      (fix:andc bits char-bit:control))
 		   (make-char code bits)))))
 	(if (fix:= 0 (fix:and flags KC_VIRTUALKEY))
 	    (and (fix:< code #x80)
diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm
index f89e01bfc..0e61578ca 100644
--- a/v7/src/edwin/tterm.scm
+++ b/v7/src/edwin/tterm.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: tterm.scm,v 1.42 2005/12/25 17:04:39 riastradh Exp $
+$Id: tterm.scm,v 1.43 2006/10/24 04:13:51 cph Exp $
 
 Copyright 1990,1991,1993,1994,1998,1999 Massachusetts Institute of Technology
-Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -198,7 +198,8 @@ USA.
 				 (let ((code (vector-8b-ref string start)))
 				   (if (fix:< code #x80)
 				       (make-char code 0)
-				       (make-char (fix:and code #x7f) 1))))))
+				       (make-char (fix:and code #x7F)
+						  char-bit:meta))))))
 			 (let* ((key-seq  (caar key-pairs))
 				(n-seq    (string-length key-seq)))
 			   (cond ((and (fix:<= n-seq n-chars)
diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm
index 93e1953bf..6066f4666 100644
--- a/v7/src/edwin/utils.scm
+++ b/v7/src/edwin/utils.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: utils.scm,v 1.56 2006/10/22 16:09:54 cph Exp $
+$Id: utils.scm,v 1.57 2006/10/24 04:14:01 cph Exp $
 
 Copyright 1987,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1996,1997,1999,2001,2002,2005 Massachusetts Institute of Technology
@@ -224,7 +224,7 @@ USA.
 	  (and (fix:>= k 0)
 	       (fix:< k 10)
 	       (loop (fix:+ index 1) (+ (* n 10) k)))))))
-
+
 (define char-set:null
   (char-set))
 
@@ -234,29 +234,15 @@ USA.
 (define char-set:not-space
   (char-set-invert (char-set #\space)))
 
-(define (ascii-controlified? char)
-  (fix:< (char-code char) #x20))
-
-(define (char-controlify char)
+(define (merge-bucky-bits char bits)
   (make-char (char-code char)
-	     (if (ascii-controlified? char)
-		 (fix:andc (char-bits char) #x2)
-		 (fix:or (char-bits char) #x2))))
-
-(define (char-controlified? char)
-  (if (ascii-controlified? char)
-      #t
-      (fix:= #x2 (fix:and (char-bits char) #x2))))
+	     (let ((bits (fix:or (char-bits char) bits)))
+	       (if (ascii-controlified? char)
+		   (fix:andc bits char-bit:control)
+		   bits))))
 
-(define (char-metafy char)
-  (make-char (char-code char)
-	     (fix:or (char-bits char) #x1)))
-
-(define (char-metafied? char)
-  (fix:= #x1 (fix:and (char-bits char) #x1)))
-
-(define (char-control-metafy char)
-  (char-metafy (char-controlify char)))
+(define (ascii-controlified? char)
+  (fix:< (char-code char) #x20))
 
 (define (char-base char)
   (make-char (char-code char) 0))
diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm
index 65db6901b..cfcc11246 100644
--- a/v7/src/edwin/xterm.scm
+++ b/v7/src/edwin/xterm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xterm.scm,v 1.77 2006/10/22 16:10:06 cph Exp $
+$Id: xterm.scm,v 1.78 2006/10/24 04:14:11 cph Exp $
 
 Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1996,1998,1999,2000,2001,2002 Massachusetts Institute of Technology
@@ -412,14 +412,8 @@ USA.
 					(vector-ref event 3)))
 		   ((fix:= end 1)
 		    (let ((char
-			   (let ((code (char-code (string-ref string 0)))
-				 (bucky-bits (vector-ref event 3)))
-			     (make-char code
-					;; Remove the control bit if this
-					;; already is a control character.
-					(if (fix:< code #x20)
-					    (fix:andc bucky-bits 2)
-					    bucky-bits)))))
+			   (merge-bucky-bits (string-ref string 0)
+					     (vector-ref event 3))))
 		      (if (and signal-interrupts? (char=? char #\BEL))
 			  (begin
 			    (signal-interrupt!)
-- 
2.25.1