From: Chris Hanson Date: Tue, 24 Oct 2006 04:14:11 +0000 (+0000) Subject: Eliminate CHAR-CONTROLIFY and friends in favor of more general X-Git-Tag: 20090517-FFI~880 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1c109c8456148bbe173b6d5db74cf61a118b493c;p=mit-scheme.git Eliminate CHAR-CONTROLIFY and friends in favor of more general MERGE-BUCKY-BITS. Use new bucky-bit abstractions from runtime. --- 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!)