From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 22 Oct 2006 16:10:06 +0000 (+0000)
Subject: Change pointer-button abstraction to have bucky bits, and update
X-Git-Tag: 20090517-FFI~882
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6accfb619a1918c6bde325f2e8fe9394994a2a5a;p=mit-scheme.git

Change pointer-button abstraction to have bucky bits, and update
different terminal drivers to supply them.
---

diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm
index 43d853c40..aa9fdcacb 100644
--- a/v7/src/edwin/calias.scm
+++ b/v7/src/edwin/calias.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: calias.scm,v 1.31 2003/04/25 03:09:55 cph Exp $
+$Id: calias.scm,v 1.32 2006/10/22 16:09:24 cph Exp $
 
 Copyright 1986,1989,1991,1992,1994,1995 Massachusetts Institute of Technology
-Copyright 1998,2000,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 1998,2000,2001,2002,2003,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -78,9 +78,6 @@ USA.
 	(if entry
 	    (unmap-alias-key (car entry))
 	    key))))
-
-(define-integrable (ascii-controlified? char)
-  (< (char-code char) #x20))
 
 (define-variable enable-emacs-key-names
   "True means keys are shown using Emacs-style names."
@@ -94,12 +91,6 @@ USA.
 	((button? key) (button-name key))
         (else (error:wrong-type-argument key "key" 'KEY-NAME))))
 
-(define (button-name button)
-  (string-append "button-"
-		 (if (button/down? button) "down" "up")
-		 "-"
-		 (number->string (button/number button))))
-
 (define (xkey->name xkey)
   (let ((keys (xkey->list xkey)))
     (string-append-separated
@@ -161,7 +152,7 @@ USA.
 (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))
+	((button? key) (button-bits key))
         (else (error:wrong-type-argument key "key" 'KEY-BUCKY-BITS))))
 
 (define (key<? key1 key2)
@@ -190,8 +181,7 @@ USA.
 	      (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))))
+	      (eq? key1 key2))
 	     (else
 	      (error:wrong-type-argument key1 "key" 'KEY=?)))))
 
diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm
index a0b27fc04..812927379 100644
--- a/v7/src/edwin/edtfrm.scm
+++ b/v7/src/edwin/edtfrm.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: edtfrm.scm,v 1.94 2003/02/14 18:28:12 cph Exp $
+$Id: edtfrm.scm,v 1.95 2006/10/22 16:09:29 cph Exp $
 
-Copyright 1985, 1989-1999, 2002 Massachusetts Institute of Technology
+Copyright 1987,1989,1990,1991,1993,1995 Massachusetts Institute of Technology
+Copyright 1996,2002,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -185,5 +186,5 @@ USA.
 		      (with-current-button-event
 			  (make-button-event frame relative-x relative-y)
 			(lambda () (execute-command command)))))
-		((button/down? button)
+		((button-down? button)
 		 (editor-beep)))))))
\ No newline at end of file
diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm
index 735d3e9e6..68b567871 100644
--- a/v7/src/edwin/edtstr.scm
+++ b/v7/src/edwin/edtstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: edtstr.scm,v 1.31 2003/03/06 05:14:21 cph Exp $
+$Id: edtstr.scm,v 1.32 2006/10/22 16:09:35 cph Exp $
 
-Copyright 1989,1990,1991,1992,2003 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,2003,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -87,6 +87,50 @@ USA.
 
 ;;;; Buttons
 
+(define-record-type <button>
+    (%%make-button number bits down? symbol)
+    button?
+  (number button-number)
+  (bits button-bits)
+  (down? button-down?)
+  (symbol button-symbol))
+
+(define (make-down-button number #!optional bits)
+  (%make-button number bits #t 'MAKE-DOWN-BUTTON))
+
+(define (make-up-button number #!optional bits)
+  (%make-button number bits #f 'MAKE-UP-BUTTON))
+
+(define (%make-button number bits down? caller)
+  (let ((bits (if (default-object? bits) 0 bits)))
+    (guarantee-limited-index-fixnum number #x100 caller)
+    (guarantee-limited-index-fixnum bits #x10 caller)
+    (let ((name
+	   (symbol (bucky-bits->prefix bits)
+		   'BUTTON-
+		   number
+		   (if down? '-DOWN '-UP))))
+      (hash-table/intern! buttons-table name
+	(lambda ()
+	  (%%make-button number bits down? name))))))
+
+(define buttons-table
+  (make-strong-eq-hash-table))
+
+(define (down-button? object)
+  (and (button? object)
+       (button-down? object)))
+
+(define (up-button? object)
+  (and (button? object)
+       (not (button-down? object))))
+
+(define (button-name button)
+  (symbol-name (button-symbol button)))
+
+(set-record-type-unparser-method! <button>
+  (simple-unparser-method (record-type-name <button>) button-symbol))
+
 (define-structure (button-event (conc-name button-event/))
   (window #f read-only #t)
   (x #f read-only #t)
@@ -111,50 +155,4 @@ USA.
        unspecific)
      thunk
      (lambda ()
-       (set-editor-button-event! current-editor old-button-event)))))
-
-(define-record-type <button>
-  (%%make-button number down?)
-  button?
-  (number button/number)
-  (down? button/down?))
-
-(define make-down-button)
-(define make-up-button)
-(let ((%make-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) #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) #f)))
-	  (%make-button up-buttons number #f))))
-
-(define (down-button? object)
-  (and (button? object)
-       (button/down? object)))
-
-(define (up-button? object)
-  (and (button? object)
-       (not (button/down? object))))
-
-(define (button/bucky-bits button)
-  button
-  0)
-
-(set-record-type-unparser-method! <button>
-  (standard-unparser-method (record-type-name <button>)
-    (lambda (button port)
-      (write-string (if (button/down? button) "down" "up") port)
-      (write-char #\space port)
-      (write (button/number button) port))))
\ No newline at end of file
+       (set-editor-button-event! current-editor old-button-event)))))
\ No newline at end of file
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 16e515984..12c4ee4e5 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.296 2006/06/16 19:02:27 riastradh Exp $
+$Id: edwin.pkg,v 1.297 2006/10/22 16:09:41 cph Exp $
 
 Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology
@@ -1272,6 +1272,7 @@ USA.
 	    screen-pel-height)
     (import (runtime os2-window-primitives)
 	    button-event-type:down
+	    button-event/flags
 	    button-event/number
 	    button-event/type
 	    button-event/x
diff --git a/v7/src/edwin/os2term.scm b/v7/src/edwin/os2term.scm
index 7ded4b2d5..33ddcea50 100644
--- a/v7/src/edwin/os2term.scm
+++ b/v7/src/edwin/os2term.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: os2term.scm,v 1.25 2003/02/14 18:28:12 cph Exp $
+$Id: os2term.scm,v 1.26 2006/10/22 16:09:48 cph Exp $
 
 Copyright 1994,1995,1996,1997,2000,2003 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -805,16 +806,15 @@ USA.
 (define (translate-key-event event)
   (let ((code (key-event/code event))
 	(flags (key-event/flags event)))
-    (let ((control (if (fix:= 0 (fix:and flags KC_CTRL)) 0 2))
-	  (meta (if (fix:= 0 (fix:and flags KC_ALT)) 0 1)))
+    (let ((bits (flags->bucky-bits flags)))
       (let ((process-code
 	     (lambda (code)
-	       (if (and (fix:<= #o100 code) (fix:< code #o140)
-			(not (fix:= 0 control)))
-		   (make-char (fix:and code #o037) meta)
-		   (make-char code (fix:or meta control))))))
+	       (if (and (fix:<= #x40 code) (fix:< code #x60)
+			(fix:= (fix:and bits #x1) #x1))
+		   (make-char (fix:and code #o037) (fix:andc bits #x1))
+		   (make-char code bits)))))
 	(if (fix:= 0 (fix:and flags KC_VIRTUALKEY))
-	    (and (fix:< code #o200)
+	    (and (fix:< code #x80)
 		 (process-code code))
 	    (let ((key
 		   (and (fix:< code (vector-length virtual-key-table))
@@ -822,7 +822,7 @@ USA.
 	      (and key
 		   (if (fix:fixnum? key)
 		       (process-code key)
-		       (make-special-key key (fix:or meta control))))))))))
+		       (make-special-key key bits)))))))))
 
 (define (process-change-event event)
   (cond ((fix:= event event:process-output) (accept-process-output))
@@ -895,12 +895,14 @@ USA.
   (lambda (screen event)
     (and (eq? button-event-type:down (button-event/type event))
 	 (if (os2win-focus? (screen-wid screen))
-	     (make-input-event 'BUTTON
-			       execute-button-command
-			       screen
-			       (make-down-button (button-event/number event))
-			       (x->cx screen (button-event/x event))
-			       (y->cy screen (button-event/y event)))
+	     (make-input-event
+	      'BUTTON
+	      execute-button-command
+	      screen
+	      (make-down-button (button-event/number event)
+				(flags->bucky-bits (button-event/flags event)))
+	      (x->cx screen (button-event/x event))
+	      (y->cy screen (button-event/y event)))
 	     (begin
 	       (os2win-activate (screen-wid screen))
 	       #f)))))
@@ -1026,4 +1028,8 @@ USA.
     (vector-set! table VK_CLEAR		'CLEAR)
     (vector-set! table VK_EREOF		'EREOF)
     (vector-set! table VK_PA1		'PA1)
-    table))
\ No newline at end of file
+    table))
+
+(define (flags->bucky-bits flags)
+  (fix:or (if (fix:= 0 (fix:and flags KC_CTRL)) #x2 #x0)
+	  (if (fix:= 0 (fix:and flags KC_ALT))  #x1 #x0)))
\ No newline at end of file
diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm
index 12209c06b..93e1953bf 100644
--- a/v7/src/edwin/utils.scm
+++ b/v7/src/edwin/utils.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: utils.scm,v 1.55 2005/07/31 02:59:37 cph Exp $
+$Id: utils.scm,v 1.56 2006/10/22 16:09:54 cph Exp $
 
-Copyright 1986, 1989-2002 Massachusetts Institute of Technology
+Copyright 1987,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
+Copyright 1996,1997,1999,2001,2002,2005 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -227,32 +229,34 @@ USA.
   (char-set))
 
 (define char-set:return
-  (char-set #\Return))
+  (char-set #\return))
 
 (define char-set:not-space
-  (char-set-invert (char-set #\Space)))
+  (char-set-invert (char-set #\space)))
+
+(define (ascii-controlified? char)
+  (fix:< (char-code char) #x20))
 
 (define (char-controlify char)
-  (if (ascii-controlified? char)
-      char
-      (make-char (char-code char)
-		 (let ((bits (char-bits char)))
-		   (if (odd? (quotient bits 2)) bits (+ bits 2))))))
+  (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)
-  (or (ascii-controlified? char)
-      (odd? (quotient (char-bits char) 2))))
+  (if (ascii-controlified? char)
+      #t
+      (fix:= #x2 (fix:and (char-bits char) #x2))))
 
 (define (char-metafy char)
   (make-char (char-code char)
-	     (let ((bits (char-bits char)))
-	       (if (odd? bits) bits (1+ bits)))))
+	     (fix:or (char-bits char) #x1)))
 
-(define-integrable (char-metafied? char)
-  (odd? (char-bits char)))
+(define (char-metafied? char)
+  (fix:= #x1 (fix:and (char-bits char) #x1)))
 
 (define (char-control-metafy char)
-  (char-controlify (char-metafy char)))
+  (char-metafy (char-controlify char)))
 
 (define (char-base char)
   (make-char (char-code char) 0))
diff --git a/v7/src/edwin/win32.scm b/v7/src/edwin/win32.scm
index 73670efd5..ed8695c3a 100644
--- a/v7/src/edwin/win32.scm
+++ b/v7/src/edwin/win32.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: win32.scm,v 1.18 2003/02/14 18:28:14 cph Exp $
+$Id: win32.scm,v 1.19 2006/10/22 16:10:00 cph Exp $
 
 Copyright 1994,1995,1996,1997,1999,2000 Massachusetts Institute of Technology
-Copyright 2002,2003 Massachusetts Institute of Technology
+Copyright 2002,2003,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -609,28 +609,18 @@ USA.
 
 (define (decode-key-event event)
   (let ((key (key-event/character event))
-	(cont-state (key-event/control-key-state event)))
-    (let ((alt? (some-bits? control-key:alt-pressed cont-state))
-	  (control? (some-bits? control-key:control-pressed cont-state))
-	  (shift? (some-bits? control-key:shift-pressed cont-state)))
-      (cond ((fix:= key -1)
-	     (let ((vk-code (key-event/virtual-keycode event))
-		   (bucky-bits
-		    (+ (if alt? 1 0)     ; M-
-		       (if control? 2 0) ; C-
-		       (if shift? 4 0)   ; S-
-		       )))
-	       (win32-make-special-key vk-code bucky-bits)))
-	    ((and control? alt?)
-	     (char-control-metafy (integer->char key)))
-	    (alt?
-	     (char-metafy (integer->char key)))
-	    ;;((and control? (eq? key 32))
-	    ;; #\c-space)
-	    (control?
-	     (char-controlify (integer->char key)))
-	    (else
-	     (integer->char key))))))
+	(state (key-event/control-key-state event)))
+    (let ((bits (control-keys->bits state)))
+      (if (fix:= key -1)
+	  (win32-make-special-key
+	   (key-event/virtual-keycode event)
+	   (fix:or (if (some-bits? control-key:shift-pressed state) #x4 #x0)
+		   bits))
+	  (merge-bucky-bits (integer->char key) bits)))))
+
+(define (control-keys->bits state)
+  (fix:or (if (some-bits? control-key:alt-pressed state)     #x1 #x0)
+	  (if (some-bits? control-key:control-pressed state) #x2 #x0)))
 
 (define-event-handler event-type:mouse
   (lambda (screen event)
@@ -645,7 +635,8 @@ USA.
 	(cond ((some-bits? button-state:left-pressed state) 0)
 	      ((some-bits? button-state:right-pressed state) 2)
 	      ((some-bits? button-state:middle-pressed state) 1)
-	      (else 0))))
+	      (else 0)))
+      (control-keys->bits (mouse-event/control-key-state event)))
      (mouse-event/column event)
      (mouse-event/row event))))
 
diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm
index a6c29f4bd..65db6901b 100644
--- a/v7/src/edwin/xterm.scm
+++ b/v7/src/edwin/xterm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xterm.scm,v 1.76 2006/10/21 21:16:53 riastradh Exp $
+$Id: xterm.scm,v 1.77 2006/10/22 16:10:06 cph Exp $
 
 Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1996,1998,1999,2000,2001,2002 Massachusetts Institute of Technology
@@ -672,7 +672,9 @@ USA.
 	   'BUTTON
 	   execute-button-command
 	   screen
-	   (make-down-button (vector-ref event 4))
+	   (let ((n (vector-ref event 4)))
+	     (make-down-button (fix:and n #x0FF)
+			       (fix:lsh (fix:and n #xF00) -8)))
 	   (xterm-map-x-coordinate xterm (vector-ref event 2))
 	   (xterm-map-y-coordinate xterm (vector-ref event 3)))))))
 
@@ -688,7 +690,9 @@ USA.
 	   'BUTTON
 	   execute-button-command
 	   screen
-	   (make-up-button (vector-ref event 4))
+	   (let ((n (vector-ref event 4)))
+	     (make-up-button (fix:and n #x0FF)
+			     (fix:lsh (fix:and n #xF00) -8)))
 	   (xterm-map-x-coordinate xterm (vector-ref event 2))
 	   (xterm-map-y-coordinate xterm (vector-ref event 3)))))))