different terminal drivers to supply them.
#| -*-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.
(if entry
(unmap-alias-key (car entry))
key))))
-
-(define-integrable (ascii-controlified? char)
- (< (char-code char) #x20))
\f
(define-variable enable-emacs-key-names
"True means keys are shown using Emacs-style names."
((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
(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)
(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=?)))))
#| -*-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.
(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
#| -*-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.
\f
;;;; 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)
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
#| -*-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
screen-pel-height)
(import (runtime os2-window-primitives)
button-event-type:down
+ button-event/flags
button-event/number
button-event/type
button-event/x
#| -*-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.
(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))
(and key
(if (fix:fixnum? key)
(process-code key)
- (make-special-key key (fix:or meta control))))))))))
+ (make-special-key key bits)))))))))
\f
(define (process-change-event event)
(cond ((fix:= event event:process-output) (accept-process-output))
(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)))))
(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
#| -*-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.
(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))
#| -*-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.
(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)))
\f
(define-event-handler event-type:mouse
(lambda (screen event)
(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))))
#| -*-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
'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)))))))
'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)))))))
\f
projects / mit-scheme.git / commitdiff