From: Chris Hanson Date: Fri, 25 Apr 2003 03:10:00 +0000 (+0000) Subject: Factor out BUCKY-BITS->PREFIX so that it can be reused by Edwin for X-Git-Tag: 20090517-FFI~1919 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e9cec639b3a0c4e1e30142ae6e06f526e0feafdc;p=mit-scheme.git Factor out BUCKY-BITS->PREFIX so that it can be reused by Edwin for special characters and mouse buttons. --- diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index 498f4668c..43d853c40 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: calias.scm,v 1.30 2003/02/14 18:28:11 cph Exp $ +$Id: calias.scm,v 1.31 2003/04/25 03:09:55 cph Exp $ Copyright 1986,1989,1991,1992,1994,1995 Massachusetts Institute of Technology Copyright 1998,2000,2001,2002,2003 Massachusetts Institute of Technology @@ -245,32 +245,15 @@ USA. (cdr hashed-keys))) new-key)))) -(define hashed-keys - (list 'HASHED-KEYS)) - (define (special-key/name special-key) - (string-append (bucky-bits->name (special-key/bucky-bits special-key)) + (string-append (bucky-bits->prefix (special-key/bucky-bits special-key)) (symbol-name (special-key/symbol special-key)))) -(define (bucky-bits->name bits) - (let ((bucky-bit-map '#("M-" "C-" "S-" "H-" "T-"))) - (let loop ((n (fix:- (vector-length bucky-bit-map) 1)) - (bit (fix:lsh 1 (fix:- (vector-length bucky-bit-map) 1))) - (name "")) - (cond ((fix:< n 0) - name) - ((fix:= 0 (fix:and bit bits)) - (loop (fix:- n 1) (fix:lsh bit -1) name)) - (else - (loop (fix:- n 1) - (fix:lsh bit -1) - (string-append (vector-ref bucky-bit-map n) name))))))) - (define (make-special-key name bits) (hook/make-special-key name bits)) -(define hook/make-special-key - intern-special-key) +(define hashed-keys (list 'HASHED-KEYS)) +(define hook/make-special-key intern-special-key) ;; Predefined special keys (define-syntax define-special-key diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 6a670182b..0e3ff09b8 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.285 2003/02/14 18:28:12 cph Exp $ +$Id: edwin.pkg,v 1.286 2003/04/25 03:10:00 cph Exp $ Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology @@ -110,6 +110,8 @@ USA. make-output-buffer output-buffer/drain-block output-buffer/write-substring-block) + (import (runtime character) + bucky-bits->prefix) (import (runtime char-syntax) char-syntax-table/entries) (import (runtime) diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm index 86d070009..fb4ada10d 100644 --- a/v7/src/runtime/char.scm +++ b/v7/src/runtime/char.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: char.scm,v 14.17 2003/04/15 20:17:14 cph Exp $ +$Id: char.scm,v 14.18 2003/04/25 03:09:14 cph Exp $ Copyright 1986,1987,1988,1991,1995,1997 Massachusetts Institute of Technology Copyright 1998,2001,2003 Massachusetts Institute of Technology @@ -240,74 +240,67 @@ USA. ;;;; Character Names (define (name->char string) - (let ((end (string-length string)) - (bits '())) - (define (loop start) + (let ((end (string-length string))) + (let loop ((start 0) (bits 0)) (let ((left (fix:- end start))) - (cond ((fix:= 0 left) - (error "Missing character name")) - ((fix:= 1 left) - (let ((char (string-ref string start))) - (if (char-graphic? char) - (char-code char) - (error "Non-graphic character" char)))) - (else - (let ((hyphen - (substring-find-next-char string start end #\-))) - (if (not hyphen) - (name->code string start end) - (let ((bit (-map-> named-bits string start hyphen))) - (if (not bit) - (name->code string start end) - (begin (if (not (memv bit bits)) - (set! bits (cons bit bits))) - (loop (fix:+ hyphen 1))))))))))) - (let ((code (loop 0))) - (make-char code (apply + bits))))) + (if (fix:= 0 left) + (error:bad-range-argument string 'NAME->CHAR)) + (if (fix:= 1 left) + (let ((char (string-ref string start))) + (if (not (char-graphic? char)) + (error:bad-range-argument string 'NAME->CHAR)) + (make-char (char-code char) bits)) + (let ((hyphen (substring-find-next-char string start end #\-))) + (if hyphen + (let ((bit (-map-> named-bits string start hyphen))) + (if bit + (loop (fix:+ hyphen 1) (fix:or bit bits)) + (make-char (name->code string start end) bits))) + (make-char (name->code string start end) bits)))))))) (define (name->code string start end) - (if (substring-ci=? string start end "Newline" 0 7) + (if (substring-ci=? string start end "newline" 0 7) (char-code char:newline) (or (-map-> named-codes string start end) (numeric-name->code string start end) - (error "Unknown character name" (substring string start end))))) + (error "Unknown character name:" (substring string start end))))) (define (numeric-name->code string start end) (and (> (- end start) 6) (substring-ci=? string start (+ start 5) "" 0 1) + (substring-ci=? string (- end 1) end ">" 0 1) (string->number (substring string (+ start 5) (- end 1)) 10))) - + (define (char->name char #!optional slashify?) - (if (default-object? slashify?) (set! slashify? false)) - (define (loop weight bits) + (let ((code (char-code char)) + (bits (char-bits char))) + (string-append + (bucky-bits->prefix bits) + (let ((base-char (code->char code))) + (cond ((<-map- named-codes code)) + ((and (if (default-object? slashify?) #f slashify?) + (not (fix:= 0 bits)) + (or (char=? base-char #\\) + (char-set-member? char-set/atom-delimiters base-char))) + (string-append "\\" (string base-char))) + ((char-graphic? base-char) + (string base-char)) + (else + (string-append "string code 10) ">"))))))) + +(define (bucky-bits->prefix bits) + (let loop ((bits bits) (weight 1)) (if (fix:= 0 bits) - (let ((code (char-code char))) - (let ((base-char (code->char code))) - (cond ((<-map- named-codes code)) - ((and slashify? - (not (fix:= 0 (char-bits char))) - (or (char=? base-char #\\) - (char-set-member? char-set/atom-delimiters - base-char))) - (string-append "\\" (string base-char))) - ((char-graphic? base-char) - (string base-char)) - (else - (string-append "string code 10) - ">"))))) - (let ((qr (integer-divide bits 2))) - (let ((rest (loop (fix:* weight 2) (integer-divide-quotient qr)))) - (if (fix:= 0 (integer-divide-remainder qr)) - rest - (string-append (or (<-map- named-bits weight) - (string-append "string weight 10) - ">")) - "-" - rest)))))) - (loop 1 (char-bits char))) + "" + (let ((rest (loop (fix:lsh bits -1) (fix:lsh weight 1)))) + (if (fix:= 0 (fix:and bits 1)) + rest + (string-append (or (<-map- named-bits weight) + (string-append "string weight 10) + ">")) + "-" + rest)))))) (define (-map-> alist string start end) (and (not (null? alist))