home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / char.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  283 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: char.scm,v 14.10 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Character Abstraction
  23. ;;; package: (runtime character)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-primitives
  28.   (char? 1)
  29.   make-char char-code char-bits char->integer integer->char char->ascii
  30.   char-ascii? ascii->char char-upcase char-downcase)
  31.  
  32. (define-integrable char-code-limit #x10000)
  33. (define-integrable char-bits-limit #x20)
  34. (define-integrable char-integer-limit #x200000)
  35.  
  36. (define-integrable (chars->ascii chars)
  37.   (map char->ascii chars))
  38.  
  39. (define-integrable (code->char code)
  40.   (make-char code 0))
  41.  
  42. (define-integrable (char=? x y)
  43.   (fix:= (char->integer x) (char->integer y)))
  44.  
  45. (define-integrable (char<? x y)
  46.   (fix:< (char->integer x) (char->integer y)))
  47.  
  48. (define-integrable (char<=? x y)
  49.   (fix:<= (char->integer x) (char->integer y)))
  50.  
  51. (define-integrable (char>? x y)
  52.   (fix:> (char->integer x) (char->integer y)))
  53.  
  54. (define-integrable (char>=? x y)
  55.   (fix:>= (char->integer x) (char->integer y)))
  56.  
  57. (define-integrable (char-ci->integer char)
  58.   (char->integer (char-upcase char)))
  59.  
  60. (define-integrable (char-ci=? x y)
  61.   (fix:= (char-ci->integer x) (char-ci->integer y)))
  62.  
  63. (define-integrable (char-ci<? x y)
  64.   (fix:< (char-ci->integer x) (char-ci->integer y)))
  65.  
  66. (define-integrable (char-ci<=? x y)
  67.   (fix:<= (char-ci->integer x) (char-ci->integer y)))
  68.  
  69. (define-integrable (char-ci>? x y)
  70.   (fix:> (char-ci->integer x) (char-ci->integer y)))
  71.  
  72. (define-integrable (char-ci>=? x y)
  73.   (fix:>= (char-ci->integer x) (char-ci->integer y)))
  74.  
  75. (define 0-code)
  76. (define upper-a-code)
  77. (define lower-a-code)
  78. (define hyphen-char)
  79. (define backslash-char)
  80.  
  81. (define (initialize-package!)
  82.   (set! 0-code (char-code (ascii->char #x30)))
  83.   ;; Next two codes are offset by 10 to speed up CHAR->DIGIT.
  84.   (set! upper-a-code (fix:- (char-code (ascii->char #x41)) 10))
  85.   (set! lower-a-code (fix:- (char-code (ascii->char #x61)) 10))
  86.   (set! hyphen-char (ascii->char #x2D))
  87.   (set! backslash-char (ascii->char #x5C))
  88.   unspecific)
  89.  
  90. (define (digit->char digit #!optional radix)
  91.   (if (not (fix:fixnum? digit))
  92.       (error:wrong-type-argument digit "digit" 'DIGIT->CHAR))
  93.   (and (fix:<= 0 digit)
  94.        (fix:< digit
  95.           (cond ((default-object? radix)
  96.              10)
  97.             ((and (fix:fixnum? radix)
  98.               (fix:<= 2 radix) (fix:<= radix 36))
  99.              radix)
  100.             (else
  101.              (error:wrong-type-argument radix "radix" 'DIGIT->CHAR))))
  102.        (string-ref "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" digit)))
  103.  
  104. (define (char->digit char #!optional radix)
  105.   (if (not (char? char))
  106.       (error:wrong-type-argument char "character" 'CHAR->DIGIT))
  107.   (and (fix:= 0 (char-bits char))
  108.        (let ((code (char-code char))
  109.          (radix
  110.           (cond ((default-object? radix)
  111.              10)
  112.             ((and (fix:fixnum? radix)
  113.               (fix:<= 2 radix) (fix:<= radix 36))
  114.              radix)
  115.             (else
  116.              (error:wrong-type-argument radix "radix" 'CHAR->DIGIT)))))
  117.      (let ((n (fix:- code 0-code)))
  118.        (if (and (fix:<= 0 n) (fix:< n radix))
  119.            n
  120.            (let ((n (fix:- code upper-a-code)))
  121.          (if (and (fix:<= 10 n) (fix:< n radix))
  122.              n
  123.              (let ((n (fix:- code lower-a-code)))
  124.                (if (and (fix:<= 10 n) (fix:< n radix))
  125.                n
  126.                #f)))))))))
  127.  
  128. ;;;; Character Names
  129.  
  130. (define (name->char string)
  131.   (let ((end (string-length string))
  132.     (bits '()))
  133.     (define (loop start)
  134.       (let ((left (fix:- end start)))
  135.     (cond ((fix:= 0 left)
  136.            (error "Missing character name"))
  137.           ((fix:= 1 left)
  138.            (let ((char (string-ref string start)))
  139.          (if (char-graphic? char)
  140.              (char-code char)
  141.              (error "Non-graphic character" char))))
  142.           (else
  143.            (let ((hyphen (substring-find-next-char string start end
  144.                                hyphen-char)))
  145.          (if (not hyphen)
  146.              (name->code string start end)
  147.              (let ((bit (-map-> named-bits string start hyphen)))
  148.                (if (not bit)
  149.                (name->code string start end)
  150.                (begin (if (not (memv bit bits))
  151.                       (set! bits (cons bit bits)))
  152.                   (loop (fix:+ hyphen 1)))))))))))
  153.     (let ((code (loop 0)))
  154.       (make-char code (apply + bits)))))
  155.  
  156. (define (name->code string start end)
  157.   (if (substring-ci=? string start end "Newline" 0 7)
  158.       (char-code char:newline)
  159.       (or (-map-> named-codes string start end)
  160.       (numeric-name->code string start end)
  161.       (error "Unknown character name" (substring string start end)))))
  162.  
  163. (define (numeric-name->code string start end)
  164.   (and (> (- end start) 6)
  165.        (substring-ci=? string start (+ start 5) "<code" 0 5)
  166.        (substring-ci=? string (- end 1)  end    ">" 0 1)
  167.        (string->number (substring string (+ start 5) (- end 1)) 10)))
  168.  
  169. (define (char->name char #!optional slashify?)
  170.   (if (default-object? slashify?) (set! slashify? false))
  171.   (define (loop weight bits)
  172.     (if (fix:= 0 bits)
  173.     (let ((code (char-code char)))
  174.       (let ((base-char (code->char code)))
  175.         (cond ((<-map- named-codes code))
  176.           ((and slashify?
  177.             (not (fix:= 0 (char-bits char)))
  178.             (or (char=? base-char backslash-char)
  179.                 (char-set-member? char-set/atom-delimiters
  180.                           base-char)))
  181.            (string-append "\\" (string base-char)))
  182.           ((char-graphic? base-char)
  183.            (string base-char))
  184.           (else
  185.            (string-append "<code"
  186.                   (number->string code 10)
  187.                   ">")))))
  188.     (let ((qr (integer-divide bits 2)))
  189.       (let ((rest (loop (fix:* weight 2) (integer-divide-quotient qr))))
  190.         (if (fix:= 0 (integer-divide-remainder qr))
  191.         rest
  192.         (string-append (or (<-map- named-bits weight)
  193.                    (string-append "<bits-"
  194.                           (number->string weight 10)
  195.                           ">"))
  196.                    "-"
  197.                    rest))))))
  198.   (loop 1 (char-bits char)))
  199.  
  200. (define (-map-> alist string start end)
  201.   (and (not (null? alist))
  202.        (let ((key (caar alist)))
  203.      (if (substring-ci=? string start end
  204.                  key 0 (string-length key))
  205.          (cdar alist)
  206.          (-map-> (cdr alist) string start end)))))
  207.  
  208. (define (<-map- alist n)
  209.   (and (not (null? alist))
  210.        (if (fix:= n (cdar alist))
  211.        (caar alist)
  212.        (<-map- (cdr alist) n))))
  213.  
  214. (define named-codes
  215.   '(
  216.     ;; Some are aliases for previous definitions, and will not appear
  217.     ;; as output.
  218.  
  219.     ("Backspace" . #x08)
  220.     ("Tab" . #x09)
  221.     ("Linefeed" . #x0A)
  222.     ("Newline" . #x0A)
  223.     ("Page" . #x0C)
  224.     ("Return" . #x0D)
  225.     ("Call" . #x1A)
  226.     ("Altmode" . #x1B)
  227.     ("Escape" . #x1B)
  228.     ("Backnext" . #x1F)
  229.     ("Space" . #x20)
  230.     ("Rubout" . #x7F)
  231.  
  232.     ;; ASCII codes
  233.  
  234.     ("NUL" . #x0)            ; ^@
  235.     ("SOH" . #x1)            ; ^A
  236.     ("STX" . #x2)            ; ^B
  237.     ("ETX" . #x3)            ; ^C
  238.     ("EOT" . #x4)            ; ^D
  239.     ("ENQ" . #x5)            ; ^E
  240.     ("ACK" . #x6)            ; ^F
  241.     ("BEL" . #x7)            ; ^G
  242.     ("BS" . #x8)            ; ^H <Backspace>
  243.     ("HT" . #x9)            ; ^I <Tab>
  244.     ("LF" . #xA)            ; ^J <Linefeed> <Newline>
  245.     ("NL" . #xA)            ; ^J <Linefeed> <Newline>
  246.     ("VT" . #xB)            ; ^K
  247.     ("FF" . #xC)            ; ^L <Page>
  248.     ("NP" . #xC)            ; ^L <Page>
  249.     ("CR" . #xD)            ; ^M <Return>
  250.     ("SO" . #xE)            ; ^N
  251.     ("SI" . #xF)            ; ^O
  252.     ("DLE" . #x10)            ; ^P
  253.     ("DC1" . #x11)            ; ^Q
  254.     ("DC2" . #x12)            ; ^R
  255.     ("DC3" . #x13)            ; ^S
  256.     ("DC4" . #x14)            ; ^T
  257.     ("NAK" . #x15)            ; ^U
  258.     ("SYN" . #x16)            ; ^V
  259.     ("ETB" . #x17)            ; ^W
  260.     ("CAN" . #x18)            ; ^X
  261.     ("EM" . #x19)            ; ^Y
  262.     ("SUB" . #x1A)            ; ^Z <Call>
  263.     ("ESC" . #x1B)            ; ^[ <Altmode> <Escape>
  264.     ("FS" . #x1C)            ; ^\
  265.     ("GS" . #x1D)            ; ^]
  266.     ("RS" . #x1E)            ; ^^
  267.     ("US" . #x1F)            ; ^_ <Backnext>
  268.     ("SP" . #x20)            ; <Space>
  269.     ("DEL" . #x7F)            ; ^? <Rubout>
  270.     ))
  271.  
  272. (define named-bits
  273.   '(("M" . #x01)
  274.     ("Meta" . #x01)
  275.     ("C" . #x02)
  276.     ("Control" . #x02)
  277.     ("S" . #x04)
  278.     ("Super" . #x04)
  279.     ("H" . #x08)
  280.     ("Hyper" . #x08)
  281.     ("T" . #x10)
  282.     ("Top" . #x10)
  283.     ))