source: project/release/5/string-utils/trunk/unicode-utils.scm @ 39956

Last change on this file since 39956 was 39956, checked in by Kon Lovett, 2 months ago

remove unused declarations

File size: 2.9 KB
Line 
1;;;; unicode-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Aug '10
4
5;; Issues
6;;
7;; - Implies Unicode support that is not present.
8
9(declare
10  (bound-to-procedure
11    ##sys#char->utf8-string
12    ##sys#unicode-surrogate?
13    ##sys#surrogates->codepoint))
14
15(module unicode-utils
16
17(;export
18  ascii-codepoint?
19  unicode-surrogate?
20  char->unicode-string
21  unicode-string *unicode-string
22  generic-make-string
23  unicode-make-string *unicode-make-string
24  unicode-surrogates->codepoint
25  ;
26  unicode-char->string)
27
28(import scheme)
29(import (chicken base))
30(import (chicken type))
31(import (only srfi-1 every make-list))
32(import (only srfi-13 string-concatenate))
33(import (only type-checks check-list check-natural-fixnum check-char))
34
35;;
36
37(: ascii-codepoint? (* --> boolean))
38(: unicode-surrogate? (* --> boolean))
39(: char->unicode-string (char -> string))
40(: unicode-char->string (deprecated char->unicode-string))
41(: *unicode-string ((list-of char) -> string))
42(: unicode-string (#!rest -> string))
43(: *unicode-make-string (fixnum char -> string))
44(: unicode-make-string (fixnum #!optional char -> string))
45(: unicode-surrogates->codepoint (fixnum fixnum -> (or boolean fixnum)))
46
47;; Simple UTF 8
48
49;nul is not accepted!
50(define (ascii-codepoint? ch)
51  (and
52    (char? ch)
53    (<= 0 (char->integer ch) #x7f) ) )
54
55(define (unicode-surrogate? n)
56  (and
57    (fixnum? n)
58    (##sys#unicode-surrogate? n) ) )
59
60(define (char->unicode-string ch)
61  (##sys#char->utf8-string (check-char 'char->unicode-string ch)) )
62
63(define unicode-char->string char->unicode-string)
64
65(define (*unicode-string chs)
66  (cond
67    ((null? chs)
68      "" )
69    ((null? (cdr chs))
70      (##sys#char->utf8-string (car chs)) )
71    (else
72      (let* (
73        (sts (map ##sys#char->utf8-string chs))
74        (cnt (foldl (lambda (l s) (+ l (the fixnum (##sys#size s)))) 0 sts)) )
75        (##sys#fragments->string cnt sts) ) ) ) )
76
77;inefficient
78(define (unicode-string . chs)
79  (if (null? chs)
80    ""
81    (begin
82      (if (null? (cdr chs)) (check-char 'unicode-string (car chs))
83        #;(every (cut check-char 'unicode-string <>) chs)
84        (check-list 'unicode-string chs))
85      (*unicode-string chs) ) ) )
86
87(define (*unicode-make-string len fill)
88  (cond
89    ((= 0 len)
90      "" )
91    ;ascii-codepoint < char
92    ((not (ascii-codepoint? fill))
93      (*unicode-string (the (list-of char) (make-list len fill))) )
94    (else
95      (##sys#make-string len fill) ) ) )
96
97(define (unicode-make-string len #!optional (fill #\space))
98  (*unicode-make-string
99    (check-natural-fixnum 'unicode-make-string len)
100    (check-char 'unicode-make-string fill)) )
101
102(define generic-make-string unicode-make-string)
103
104(define (unicode-surrogates->codepoint hi lo)
105  (##sys#surrogates->codepoint
106    (check-natural-fixnum 'unicode-surrogates->codepoint hi "high")
107    (check-natural-fixnum 'unicode-surrogates->codepoint lo "low")) )
108
109) ;module unicode-utils
Note: See TracBrowser for help on using the repository browser.