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 498f4668c9354d974c126b1dc0c9c735466f3d37..43d853c40c2ec040ebc763b233dc94703eaf2f82 100644 (file)
--- 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)))))))
-\f
 (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 6a670182b7babb732d134b0ab3f3ec75711fead8..0e3ff09b827ddf9282e6385f1be2729cebfa7d89 100644 (file)
--- 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 86d07000926bbf33655c6797d97288ca7fbde145..fb4ada10dc2cd8c807f51eb4bc2013adb7405a5c 100644 (file)
--- 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) "<code" 0 5)
-       (substring-ci=? string (- end 1)  end    ">" 0 1)
+       (substring-ci=? string (- end 1) end ">" 0 1)
        (string->number (substring string (+ start 5) (- end 1)) 10)))
-\f
+
 (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 "<code" (number->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 "<code"
-                                 (number->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 "<bits-"
-                                                 (number->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 "<bits-"
+                                               (number->string weight 10)
+                                               ">"))
+                            "-"
+                            rest))))))
 
 (define (-map-> alist string start end)
   (and (not (null? alist))