1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
;;;; Portable definitions of char->ascii and ascii->char
; Don't detabify this file!
; This module defines char->ascii and ascii->char in terms of
; char->integer and integer->char, with no assumptions about the encoding.
; Portable except maybe for the strings that contain tab, page, and
; carriage return characters. Those can be flushed if necessary.
(define ascii-limit 128)
(define ascii-chars
(let* ((ascii-chars (make-vector ascii-limit #f))
(unusual (lambda (s)
(if (or (not (= (string-length s) 1))
(let ((c (string-ref s 0)))
(or (char=? c #\space)
(char=? c #\newline))))
(error "unusual whitespace character lost" s)
s)))
(init (lambda (i s)
(do ((i i (+ i 1))
(j 0 (+ j 1)))
((= j (string-length s)))
(vector-set! ascii-chars i (string-ref s j))))))
(init 9 (unusual " ")) ;tab
(init 12 (unusual " ")) ;page
(init 13 (unusual "
")) ;carriage return
(init 10 (string #\newline))
(init 32 " !\"#$%&'()*+,-./0123456789:;<=>?")
(init 64 "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_")
(init 96 "`abcdefghijklmnopqrstuvwxyz{|}~")
ascii-chars))
(define (ascii->char n)
(or (vector-ref ascii-chars n)
(error "not a standard character's ASCII code" n)))
(define native-chars
(let ((end (vector-length ascii-chars)))
(let loop ((i 0)
(least #f)
(greatest #f))
(cond ((= i end)
(let ((v (make-vector (+ (- greatest least) 1) #f)))
(do ((i 0 (+ i 1)))
((= i end) (cons least v))
(let ((c (vector-ref ascii-chars i)))
(if c
(vector-set! v (- (char->integer c) least) i))))))
(else
(let ((c (vector-ref ascii-chars i)))
(if c
(let ((n (char->integer c)))
(loop (+ i 1)
(if least (min least n) n)
(if greatest (max greatest n) n)))
(loop (+ i 1) least greatest))))))))
(define (char->ascii char)
(or (vector-ref (cdr native-chars)
(- (char->integer char) (car native-chars)))
(error "not a standard character" char)))
(define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return
|
