/[cmucl]/src/code/string.lisp
ViewVC logotype

Contents of /src/code/string.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12.30.29 - (show annotations)
Fri Jun 5 19:17:01 2009 UTC (4 years, 10 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
Changes since 1.12.30.28: +140 -13 lines
First cut at full-casing support.

code/string.lisp:
o Add :CASING parameter to STRING-UPCASE, STRING-DOWNCASE, and
  STRING-CAPITALIZE to allow whether :SIMPLE or :FULL casing is done.
  Default is :SIMPLE.
o Implement full casing for upcase, downcase, and capitalize.

compiler/fndb.lisp:
o Tell compiler about the extra parameter.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/string.lisp,v 1.12.30.29 2009/06/05 19:17:01 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions to implement strings for CMU Common Lisp
13 ;;; Written by David Dill
14 ;;; Rewritten by Skef Wholey, Bill Chiles and Rob MacLachlan.
15 ;;;
16 ;;; ****************************************************************
17 ;;;
18 (in-package "LISP")
19 (export '(char schar glyph sglyph string
20 string= string-equal string< string> string<= string>= string/=
21 string-lessp string-greaterp string-not-lessp string-not-greaterp
22 string-not-equal
23 string-to-nfd string-to-nfkd string-to-nfc string-to-nfkc
24 make-string
25 string-trim string-left-trim string-right-trim
26 string-upcase
27 string-downcase string-capitalize nstring-upcase nstring-downcase
28 nstring-capitalize))
29
30
31 (declaim (inline surrogatep surrogates-to-codepoint codepoint surrogates))
32
33 (defun surrogatep (c &optional surrogate-type)
34 "Test if C is a surrogate. C may be either an integer or a
35 character. Surrogate-type indicates what kind of surrogate to test
36 for. :High means to test for the high (leading) surrogate; :Low
37 tests for the low (trailing surrogate). A value of :Any or Nil
38 tests for any surrogate value (high or low)."
39 (declare (type (or character codepoint) c))
40 (let ((code (if (characterp c)
41 (char-code c)
42 c)))
43 (ecase surrogate-type
44 ((:high :leading)
45 ;; Test for high surrogate
46 (<= #xD800 code #xDBFF))
47 ((:low :trailing)
48 ;; Test for low surrogate
49 (<= #xDC00 code #xDFFF))
50 ((:any nil)
51 ;; Test for any surrogate
52 (<= #xD800 code #xDFFF)))))
53
54 (defun surrogates-to-codepoint (hi lo)
55 "Convert the given Hi and Lo surrogate characters to the
56 corresponding codepoint value"
57 (declare (type character hi lo))
58 (+ (ash (- (the (integer #xD800 #xDBFF) (char-code hi)) #xD800) 10)
59 (the (integer #xDC00 #xDFFF) (char-code lo)) #x2400))
60
61 (defun codepoint (string i &optional (end (length string)))
62 "Return the codepoint value from String at position I. If that
63 position is a surrogate, it is combined with either the previous or
64 following character (when possible) to compute the codepoint. The
65 second return value is NIL if the position is not a surrogate pair.
66 Otherwise +1 or -1 is returned if the position is the high or low
67 surrogate value, respectively."
68 (declare (type simple-string string) (type kernel:index i end))
69 (let ((code (char-code (schar string i))))
70 (cond ((and (surrogatep code :high) (< (1+ i) end))
71 (let ((tmp (char-code (schar string (1+ i)))))
72 (if (surrogatep tmp :low)
73 (values (+ (ash (- code #xD800) 10) tmp #x2400) +1)
74 (values code nil))))
75 ((and (surrogatep code :low) (> i 0))
76 (let ((tmp (char-code (schar string (1- i)))))
77 (if (surrogatep tmp :high)
78 (values (+ (ash (- tmp #xD800) 10) code #x2400) -1)
79 (values code nil))))
80 (t (values code nil)))))
81
82 (defun surrogates (codepoint)
83 "Return the high and low surrogate characters for Codepoint. If
84 Codepoint is in the BMP, the first return value is the corresponding
85 character and the second is NIL."
86 (declare (type codepoint codepoint))
87 (if (< codepoint #x10000)
88 (values (code-char codepoint) nil)
89 (let* ((tmp (- codepoint #x10000))
90 (hi (logior (ldb (byte 10 10) tmp) #xD800))
91 (lo (logior (ldb (byte 10 0) tmp) #xDC00)))
92 (values (code-char hi) (code-char lo)))))
93
94 (defun (setf codepoint) (codepoint string i)
95 "Set the codepoint at string position I to the Codepoint. If the
96 codepoint requires a surrogate pair, the high (leading surrogate) is
97 stored at position I and the low (trailing) surrogate is stored at
98 I+1"
99 (declare (type codepoint codepoint)
100 (type simple-string string))
101 (let ((widep nil))
102 (multiple-value-bind (hi lo)
103 (surrogates codepoint)
104 (setf (aref string i) hi)
105 (when lo
106 (setf (aref string (1+ i)) lo)
107 (setf widep t)))
108 (values codepoint widep)))
109
110 (defun utf16-string-p (string)
111 "Check if String is a valid UTF-16 string. If the string is valid,
112 T is returned. If the string is not valid, NIL is returned, and the
113 second value is the index into the string of the invalid character.
114 A string is also invalid if it contains any unassigned codepoints."
115 (do ((len (length string))
116 (index 0 (1+ index)))
117 ((>= index len)
118 t)
119 (multiple-value-bind (codepoint wide)
120 (codepoint string index)
121 ;; We step through the string in order. If there are any
122 ;; surrogates pairs, we must reach the lead surrogate first,
123 ;; which means WIDE is +1. Otherwise, we have an invalid
124 ;; surrogate pair. If we get any codepoint that is in the
125 ;; surrogate range, we also have an invalid string. An
126 ;; unassigned codepoint is also considered invalid.
127 (when (or (eq wide -1)
128 (surrogatep codepoint)
129 (lisp::unicode-assigned-codepoint-p codepoint))
130 (return-from utf16-string-p (values nil index)))
131 (when wide (incf index)))))
132
133 (defun string (X)
134 "Coerces X into a string. If X is a string, X is returned. If X is a
135 symbol, X's pname is returned. If X is a character then a one element
136 string containing that character is returned. If X cannot be coerced
137 into a string, an error occurs."
138 (cond ((stringp x) x)
139 ((symbolp x) (symbol-name x))
140 ((characterp x)
141 (let ((res (make-string 1)))
142 (setf (schar res 0) x) res))
143 (t
144 (error 'simple-type-error
145 :datum x
146 :expected-type '(or string symbol character)
147 :format-control "~S cannot be coerced to a string."
148 :format-arguments (list x)))))
149
150 ;;; With-One-String is used to set up some string hacking things. The keywords
151 ;;; are parsed, and the string is hacked into a simple-string.
152
153 (eval-when (compile)
154
155 (defmacro with-one-string (string start end cum-offset &rest forms)
156 `(let ((,string (if (stringp ,string) ,string (string ,string))))
157 ;; Optimizer may prove STRING is one.
158 (declare (optimize (ext:inhibit-warnings 3)))
159 (with-array-data ((,string ,string :offset-var ,cum-offset)
160 (,start ,start)
161 (,end (or ,end (length (the vector ,string)))))
162 ,@forms)))
163
164 )
165
166 ;;; With-String is like With-One-String, but doesn't parse keywords.
167
168 (eval-when (compile)
169
170 (defmacro with-string (string &rest forms)
171 `(let ((,string (if (stringp ,string) ,string (string ,string))))
172 (with-array-data ((,string ,string)
173 (start)
174 (end (length (the vector ,string))))
175 ,@forms)))
176
177 )
178
179 ;;; With-Two-Strings is used to set up string comparison operations. The
180 ;;; keywords are parsed, and the strings are hacked into simple-strings.
181
182 (eval-when (compile)
183
184 (defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
185 start2 end2 &rest forms)
186 `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))
187 (,string2 (if (stringp ,string2) ,string2 (string ,string2))))
188 (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
189 (,start1 ,start1)
190 (,end1 (or ,end1 (length (the vector ,string1)))))
191 (with-array-data ((,string2 ,string2)
192 (,start2 ,start2)
193 (,end2 (or ,end2 (length (the vector ,string2)))))
194 ,@forms))))
195
196 )
197
198
199 (defun char (string index)
200 "Given a string and a non-negative integer index less than the length of
201 the string, returns the character object representing the character at
202 that position in the string."
203 (declare (optimize (safety 1)))
204 (char string index))
205
206 (defun %charset (string index new-el)
207 (declare (optimize (safety 1)))
208 (setf (char string index) new-el))
209
210 (defun schar (string index)
211 "SCHAR returns the character object at an indexed position in a string
212 just as CHAR does, except the string must be a simple-string."
213 (declare (optimize (safety 1)))
214 (schar string index))
215
216 (defun %scharset (string index new-el)
217 (declare (optimize (safety 1)))
218 (setf (schar string index) new-el))
219
220 (defun string=* (string1 string2 start1 end1 start2 end2)
221 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
222 (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))
223
224
225 (defun string/=* (string1 string2 start1 end1 start2 end2)
226 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
227 (let ((comparison (%sp-string-compare string1 start1 end1
228 string2 start2 end2)))
229 (if comparison (- (the fixnum comparison) offset1)))))
230
231 (eval-when (compile eval)
232
233 ;;; Lessp is true if the desired expansion is for string<* or string<=*.
234 ;;; Equalp is true if the desired expansion is for string<=* or string>=*.
235 (defmacro string<>=*-body (lessp equalp)
236 (let ((offset1 (gensym)))
237 `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
238 (let ((index (%sp-string-compare string1 start1 end1
239 string2 start2 end2)))
240 (if index
241 (cond ((= (the fixnum index) (the fixnum end1))
242 ,(if lessp
243 `(- (the fixnum index) ,offset1)
244 `nil))
245 ((= (+ (the fixnum index) (- start2 start1))
246 (the fixnum end2))
247 ,(if lessp
248 `nil
249 `(- (the fixnum index) ,offset1)))
250 #-unicode
251 ((,(if lessp 'char< 'char>)
252 (schar string1 index)
253 (schar string2 (+ (the fixnum index) (- start2 start1))))
254 (- (the fixnum index) ,offset1))
255 #-unicode
256 (t nil)
257 #+unicode
258 (t
259 ;; Compare in code point order. See
260 ;; http://icu-project.org/docs/papers/utf16_code_point_order.html
261 (flet ((fixup (code)
262 (if (>= code #xe000)
263 (- code #x800)
264 (+ code #x2000))))
265 (declare (inline fixup))
266 (let* ((c1 (char-code (schar string1 index)))
267 (c2 (char-code (schar string2
268 (+ (the fixnum index)
269 (- start2 start1))))))
270 (cond ((and (>= c1 #xd800)
271 (>= c2 #xd800))
272 (let ((fix-c1 (fixup c1))
273 (fix-c2 (fixup c2)))
274 (if (,(if lessp '< '>) fix-c1 fix-c2)
275 (- (the fixnum index) ,offset1)
276 nil)))
277 (t
278 (if (,(if lessp '< '>) c1 c2)
279 (- (the fixnum index) ,offset1)
280 nil)))))))
281 ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
282 ) ; eval-when
283
284 (defun string<* (string1 string2 start1 end1 start2 end2)
285 (declare (fixnum start1 start2))
286 (string<>=*-body t nil))
287
288 (defun string>* (string1 string2 start1 end1 start2 end2)
289 (declare (fixnum start1 start2))
290 (string<>=*-body nil nil))
291
292 (defun string<=* (string1 string2 start1 end1 start2 end2)
293 (declare (fixnum start1 start2))
294 (string<>=*-body t t))
295
296 (defun string>=* (string1 string2 start1 end1 start2 end2)
297 (declare (fixnum start1 start2))
298 (string<>=*-body nil t))
299
300
301
302 (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
303 "Given two strings, if the first string is lexicographically less than
304 the second string, returns the longest common prefix (using char=)
305 of the two strings. Otherwise, returns ()."
306 (string<* string1 string2 start1 end1 start2 end2))
307
308 (defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
309 "Given two strings, if the first string is lexicographically greater than
310 the second string, returns the longest common prefix (using char=)
311 of the two strings. Otherwise, returns ()."
312 (string>* string1 string2 start1 end1 start2 end2))
313
314
315 (defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
316 "Given two strings, if the first string is lexicographically less than
317 or equal to the second string, returns the longest common prefix
318 (using char=) of the two strings. Otherwise, returns ()."
319 (string<=* string1 string2 start1 end1 start2 end2))
320
321 (defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
322 "Given two strings, if the first string is lexicographically greater
323 than or equal to the second string, returns the longest common prefix
324 (using char=) of the two strings. Otherwise, returns ()."
325 (string>=* string1 string2 start1 end1 start2 end2))
326
327 (defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
328 "Given two strings (string1 and string2), and optional integers start1,
329 start2, end1 and end2, compares characters in string1 to characters in
330 string2 (using char=)."
331 (string=* string1 string2 start1 end1 start2 end2))
332
333 (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
334 "Given two strings, if the first string is not lexicographically equal
335 to the second string, returns the longest common prefix (using char=)
336 of the two strings. Otherwise, returns ()."
337 (string/=* string1 string2 start1 end1 start2 end2))
338
339
340 (eval-when (compile eval)
341
342 ;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
343 ;;; STRING-EQUAL and STRING-NOT-EQUAL.
344 (defmacro string-not-equal-loop (end end-value
345 &optional (abort-value nil abortp))
346 (declare (fixnum end))
347 (let ((end-test (if (= end 1)
348 `(= index1 (the fixnum end1))
349 `(= index2 (the fixnum end2)))))
350 `(do ((index1 start1 (1+ index1))
351 (index2 start2 (1+ index2)))
352 (,(if abortp
353 end-test
354 `(or ,end-test
355 (not (char-equal (schar string1 index1)
356 (schar string2 index2)))))
357 ,end-value)
358 (declare (fixnum index1 index2))
359 ,@(if abortp
360 `((if (not (char-equal (schar string1 index1)
361 (schar string2 index2)))
362 (return ,abort-value)))))))
363
364 ) ; eval-when
365
366 (defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
367 "Given two strings (string1 and string2), and optional integers start1,
368 start2, end1 and end2, compares characters in string1 to characters in
369 string2 (using char-equal)."
370 (declare (fixnum start1 start2))
371 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
372 (let ((slen1 (- (the fixnum end1) start1))
373 (slen2 (- (the fixnum end2) start2)))
374 (declare (fixnum slen1 slen2))
375 (if (or (minusp slen1) (minusp slen2))
376 ;;prevent endless looping later.
377 (error "Improper bounds for string comparison."))
378 (if (= slen1 slen2)
379 ;;return () immediately if lengths aren't equal.
380 (string-not-equal-loop 1 t nil)))))
381
382 (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
383 "Given two strings, if the first string is not lexicographically equal
384 to the second string, returns the longest common prefix (using char-equal)
385 of the two strings. Otherwise, returns ()."
386 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
387 (let ((slen1 (- end1 start1))
388 (slen2 (- end2 start2)))
389 (declare (fixnum slen1 slen2))
390 (if (or (minusp slen1) (minusp slen2))
391 ;;prevent endless looping later.
392 (error "Improper bounds for string comparison."))
393 (cond ((or (minusp slen1) (or (minusp slen2)))
394 (error "Improper substring for comparison."))
395 ((= slen1 slen2)
396 (string-not-equal-loop 1 nil (- index1 offset1)))
397 ((< slen1 slen2)
398 (string-not-equal-loop 1 (- index1 offset1)))
399 (t
400 (string-not-equal-loop 2 (- index1 offset1)))))))
401
402
403
404 (eval-when (compile eval)
405
406 ;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
407 ;;; and string2 and a test on the current characters from string1 and string2
408 ;;; for the following macro.
409 (defun string-less-greater-equal-tests (lessp equalp)
410 (if lessp
411 (if equalp
412 ;; STRING-NOT-GREATERP
413 (values '<=
414 #-unicode `(not (char-greaterp char1 char2))
415 #+unicode `(<= char1 char2))
416 ;; STRING-LESSP
417 (values '<
418 #-unicode `(char-lessp char1 char2)
419 #+unicode `(< char1 char2)))
420 (if equalp
421 ;; STRING-NOT-LESSP
422 (values '>=
423 #-unicode `(not (char-lessp char1 char2))
424 #+unicode `(>= char1 char2))
425 ;; STRING-GREATERP
426 (values '>
427 #-unicode `(char-greaterp char1 char2)
428 #+unicode `(> char1 char2)))))
429
430 #-unicode
431 (defmacro string-less-greater-equal (lessp equalp)
432 (multiple-value-bind (length-test character-test)
433 (string-less-greater-equal-tests lessp equalp)
434 `(with-two-strings string1 string2 start1 end1 offset1 start2 end2
435 (let ((slen1 (- (the fixnum end1) start1))
436 (slen2 (- (the fixnum end2) start2)))
437 (declare (fixnum slen1 slen2))
438 (if (or (minusp slen1) (minusp slen2))
439 ;;prevent endless looping later.
440 (error "Improper bounds for string comparison."))
441 (do ((index1 start1 (1+ index1))
442 (index2 start2 (1+ index2))
443 (char1)
444 (char2))
445 ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
446 (if (,length-test slen1 slen2) (- index1 offset1)))
447 (declare (fixnum index1 index2))
448 (setq char1 (schar string1 index1))
449 (setq char2 (schar string2 index2))
450 (if (not (char-equal char1 char2))
451 (if ,character-test
452 (return (- index1 offset1))
453 (return ()))))))))
454
455 ;; Convert to lowercase for case folding, to match what Unicode
456 ;; CaseFolding.txt says. An example where this matters: U+1E9E maps
457 ;; to U+00DF. But the uppercase version of U+00DF is U+00DF.
458 #+unicode
459 (defmacro equal-char-codepoint (codepoint)
460 `(let ((ch ,codepoint))
461 ;; Handle ASCII separately for bootstrapping and for unidata missing.
462 (if (< 64 ch 91)
463 (+ ch 32)
464 #-(and unicode (not unicode-bootstrap))
465 ch
466 #+(and unicode (not unicode-bootstrap))
467 (if (> ch 127) (unicode-lower ch) ch))))
468
469 #+unicode
470 (defmacro string-less-greater-equal (lessp equalp)
471 (multiple-value-bind (length-test character-test)
472 (string-less-greater-equal-tests lessp equalp)
473 `(with-two-strings string1 string2 start1 end1 offset1 start2 end2
474 (let ((slen1 (- (the fixnum end1) start1))
475 (slen2 (- (the fixnum end2) start2)))
476 (declare (fixnum slen1 slen2))
477 (if (or (minusp slen1) (minusp slen2))
478 ;;prevent endless looping later.
479 (error "Improper bounds for string comparison."))
480 (do ((index1 start1 (1+ index1))
481 (index2 start2 (1+ index2)))
482 ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
483 (if (,length-test slen1 slen2) (- index1 offset1)))
484 (declare (fixnum index1 index2))
485 (multiple-value-bind (char1 wide1)
486 (codepoint string1 index1)
487 (declare (type codepoint char1))
488 (multiple-value-bind (char2 wide2)
489 (codepoint string2 index2)
490 (declare (type codepoint char2))
491 (setf char1 (equal-char-codepoint char1))
492 (setf char2 (equal-char-codepoint char2))
493 (if (= char1 char2)
494 (progn
495 (when wide1 (incf index1))
496 (when wide2 (incf index2)))
497 (if ,character-test
498 (return (- index1 offset1))
499 (return ()))))))))))
500
501 ) ; eval-when
502
503 (defun string-lessp* (string1 string2 start1 end1 start2 end2)
504 (declare (fixnum start1 start2))
505 (string-less-greater-equal t nil))
506
507 (defun string-greaterp* (string1 string2 start1 end1 start2 end2)
508 (declare (fixnum start1 start2))
509 (string-less-greater-equal nil nil))
510
511 (defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
512 (declare (fixnum start1 start2))
513 (string-less-greater-equal nil t))
514
515 (defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
516 (declare (fixnum start1 start2))
517 (string-less-greater-equal t t))
518
519 (defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
520 "Given two strings, if the first string is lexicographically less than
521 the second string, returns the longest common prefix (using char-equal)
522 of the two strings. Otherwise, returns ()."
523 (string-lessp* string1 string2 start1 end1 start2 end2))
524
525 (defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
526 "Given two strings, if the first string is lexicographically greater than
527 the second string, returns the longest common prefix (using char-equal)
528 of the two strings. Otherwise, returns ()."
529 (string-greaterp* string1 string2 start1 end1 start2 end2))
530
531 (defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
532 "Given two strings, if the first string is lexicographically greater
533 than or equal to the second string, returns the longest common prefix
534 (using char-equal) of the two strings. Otherwise, returns ()."
535 (string-not-lessp* string1 string2 start1 end1 start2 end2))
536
537 (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
538 end2)
539 "Given two strings, if the first string is lexicographically less than
540 or equal to the second string, returns the longest common prefix
541 (using char-equal) of the two strings. Otherwise, returns ()."
542 (string-not-greaterp* string1 string2 start1 end1 start2 end2))
543
544
545 (defun make-string (count &key element-type ((:initial-element fill-char)))
546 "Given a character count and an optional fill character, makes and returns
547 a new string Count long filled with the fill character."
548 (declare (type fixnum count))
549 (assert (subtypep element-type 'character))
550 (if fill-char
551 (do ((i 0 (1+ i))
552 (string (make-string count)))
553 ((= i count) string)
554 (declare (fixnum i))
555 (setf (schar string i) fill-char))
556 (make-string count)))
557
558 (defun string-upcase-simple (string &key (start 0) end)
559 (declare (fixnum start))
560 (let* ((string (if (stringp string) string (string string)))
561 (slen (length string)))
562 (declare (fixnum slen))
563 (with-one-string string start end offset
564 (let ((offset-slen (+ slen offset))
565 (newstring (make-string slen)))
566 (declare (fixnum offset-slen))
567 (do ((index offset (1+ index))
568 (new-index 0 (1+ new-index)))
569 ((= index start))
570 (declare (fixnum index new-index))
571 (setf (schar newstring new-index) (schar string index)))
572 (do ((index start (1+ index))
573 (new-index (- start offset) (1+ new-index)))
574 ((= index (the fixnum end)))
575 (declare (fixnum index new-index))
576 (multiple-value-bind (code wide) (codepoint string index)
577 (when wide (incf index))
578 ;; Handle ASCII specially because this is called early in
579 ;; initialization, before unidata is available.
580 (cond ((< 96 code 123) (decf code 32))
581 ((> code 127) (setq code (unicode-upper code))))
582 ;;@@ WARNING: this may, in theory, need to extend newstring
583 ;; but that never actually occurs as of Unicode 5.1.0,
584 ;; so I'm just going to ignore it for now...
585 (multiple-value-bind (hi lo) (surrogates code)
586 (setf (schar newstring new-index) hi)
587 (when lo
588 (setf (schar newstring (incf new-index)) lo)))))
589 ;;@@ WARNING: see above
590 (do ((index end (1+ index))
591 (new-index (- (the fixnum end) offset) (1+ new-index)))
592 ((= index offset-slen))
593 (declare (fixnum index new-index))
594 (setf (schar newstring new-index) (schar string index)))
595 newstring))))
596
597 (defun string-upcase-full (string &key (start 0) end)
598 (declare (fixnum start))
599 (let* ((string (if (stringp string) string (string string)))
600 (slen (length string)))
601 (declare (fixnum slen))
602 (with-output-to-string (s)
603 (with-one-string string start end offset
604 (let ((offset-slen (+ slen offset)))
605 (declare (fixnum offset-slen))
606 (write-string string s :start offset :end start)
607 (do ((index start (1+ index)))
608 ((= index (the fixnum end)))
609 (declare (fixnum index))
610 (multiple-value-bind (code wide)
611 (codepoint string index)
612 (when wide (incf index))
613 ;; Handle ASCII specially because this is called early in
614 ;; initialization, before unidata is available.
615 (cond ((< 96 code 123)
616 (write-char (code-char (decf code 32)) s))
617 ((> code 127)
618 (write-string (unicode-full-case-upper code) s))
619 (t
620 (multiple-value-bind (hi lo)
621 (surrogates code)
622 (write-char hi s)
623 (when lo
624 (write-char lo s)))))))
625 (write-string string s :start end :end offset-slen))))))
626
627 (defun string-upcase (string &key (start 0) end #+unicode (casing :simple))
628 "Given a string, returns a new string that is a copy of it with all
629 lower case alphabetic characters converted to uppercase. If Casing
630 is :full, then Unicode full-casing operation is done."
631 (declare (fixnum start))
632 #-unicode
633 (string-upcase-simple string :start start :end end)
634 #+unicode
635 (if (eq casing :simple)
636 (string-upcase-simple string :start start :end end)
637 (string-upcase-full string :start start :end end)))
638
639 (defun string-downcase-simple (string &key (start 0) end)
640 (declare (fixnum start))
641 (let* ((string (if (stringp string) string (string string)))
642 (slen (length string)))
643 (declare (fixnum slen))
644 (with-one-string string start end offset
645 (let ((offset-slen (+ slen offset))
646 (newstring (make-string slen)))
647 (declare (fixnum offset-slen))
648 (do ((index offset (1+ index))
649 (new-index 0 (1+ new-index)))
650 ((= index start))
651 (declare (fixnum index new-index))
652 (setf (schar newstring new-index) (schar string index)))
653 (do ((index start (1+ index))
654 (new-index (- start offset) (1+ new-index)))
655 ((= index (the fixnum end)))
656 (declare (fixnum index new-index))
657 (multiple-value-bind (code wide) (codepoint string index)
658 (when wide (incf index))
659 ;; Handle ASCII specially because this is called early in
660 ;; initialization, before unidata is available.
661 (cond ((< 64 code 91) (incf code 32))
662 ((> code 127) (setq code (unicode-lower code))))
663 ;;@@ WARNING: this may, in theory, need to extend newstring
664 ;; but that never actually occurs as of Unicode 5.1.0,
665 ;; so I'm just going to ignore it for now...
666 (multiple-value-bind (hi lo) (surrogates code)
667 (setf (schar newstring new-index) hi)
668 (when lo
669 (setf (schar newstring (incf new-index)) lo)))))
670 ;;@@ WARNING: see above
671 (do ((index end (1+ index))
672 (new-index (- (the fixnum end) offset) (1+ new-index)))
673 ((= index offset-slen))
674 (declare (fixnum index new-index))
675 (setf (schar newstring new-index) (schar string index)))
676 newstring))))
677
678 (defun string-downcase-full (string &key (start 0) end)
679 (declare (fixnum start))
680 (let* ((string (if (stringp string) string (string string)))
681 (slen (length string)))
682 (declare (fixnum slen))
683 (with-output-to-string (s)
684 (with-one-string string start end offset
685 (let ((offset-slen (+ slen offset)))
686 (declare (fixnum offset-slen))
687 (write-string string s :start offset :end start)
688 (do ((index start (1+ index)))
689 ((= index (the fixnum end)))
690 (declare (fixnum index))
691 (multiple-value-bind (code wide)
692 (codepoint string index)
693 (when wide (incf index))
694 ;; Handle ASCII specially because this is called early in
695 ;; initialization, before unidata is available.
696 (cond ((< 64 code 91)
697 (write-char (code-char (incf code 32)) s))
698 ((> code 127)
699 (write-string (unicode-full-case-lower code) s))
700 (t
701 (multiple-value-bind (hi lo)
702 (surrogates code)
703 (write-char hi s)
704 (when lo
705 (write-char lo s)))))))
706 (write-string string s :start end :end offset-slen))))))
707
708 (defun string-downcase (string &key (start 0) end #+unicode (casing :simple))
709 "Given a string, returns a new string that is a copy of it with all
710 upper case alphabetic characters converted to lowercase. If Casing
711 is :full, then Unicode full-casing is done"
712 (declare (fixnum start))
713 #-unicode
714 (string-downcase-simple string :start start :end end)
715 #+unicode
716 (if (eq casing :simple)
717 (string-downcase-simple string :start start :end end)
718 (string-downcase-full string :start start :end end)))
719
720 (defun string-capitalize-simple (string &key (start 0) end)
721 (declare (fixnum start))
722 (let* ((string (if (stringp string) string (string string)))
723 (slen (length string)))
724 (declare (fixnum slen))
725 (with-one-string string start end offset
726 (let ((offset-slen (+ slen offset))
727 (newstring (make-string slen)))
728 (declare (fixnum offset-slen))
729 (do ((index offset (1+ index))
730 (new-index 0 (1+ new-index)))
731 ((= index start))
732 (declare (fixnum index new-index))
733 (setf (schar newstring new-index) (schar string index)))
734 (do ((index start (1+ index))
735 (new-index (- start offset) (1+ new-index))
736 (newword t)
737 (char ()))
738 ((= index (the fixnum end)))
739 (declare (fixnum index new-index))
740 (setq char (schar string index))
741 (cond ((not (alphanumericp char))
742 (setq newword t))
743 (newword
744 ;;char is first case-modifiable after non-case-modifiable
745 (setq char (char-titlecase char))
746 (setq newword ()))
747 ;;char is case-modifiable, but not first
748 (t (setq char (char-downcase char))))
749 (setf (schar newstring new-index) char))
750 (do ((index end (1+ index))
751 (new-index (- (the fixnum end) offset) (1+ new-index)))
752 ((= index offset-slen))
753 (declare (fixnum index new-index))
754 (setf (schar newstring new-index) (schar string index)))
755 newstring))))
756
757 (defun string-capitalize-full (string &key (start 0) end)
758 (declare (fixnum start))
759 (let* ((string (if (stringp string) string (string string)))
760 (slen (length string)))
761 (declare (fixnum slen))
762 (with-output-to-string (s)
763 (with-one-string string start end offset
764 (let ((offset-slen (+ slen offset)))
765 (declare (fixnum offset-slen))
766 (write-string string s :start offset :end start)
767 (flet ((alphanump (m)
768 (or (< 47 m 58) (< 64 m 91) (< 96 m 123)
769 #+(and unicode (not unicode-bootstrap))
770 (and (> m 127)
771 (<= +unicode-category-letter+ (unicode-category m)
772 (+ +unicode-category-letter+ #x0F))))))
773 (do ((index start (1+ index))
774 (newword t))
775 ((= index (the fixnum end)))
776 (declare (fixnum index))
777 (multiple-value-bind (code wide)
778 (codepoint string index)
779 (when wide (incf index))
780 (cond ((not (alphanump code))
781 (multiple-value-bind (hi lo)
782 (surrogates code)
783 (write-char hi s)
784 (when lo (write-char lo s)))
785 (setq newword t))
786 (newword
787 ;;char is first case-modifiable after non-case-modifiable
788 (write-string (unicode-full-case-title code) s)
789 (setq newword ()))
790 ;;char is case-modifiable, but not first
791 (t
792 (write-string (unicode-full-case-lower code) s))))))
793 (write-string string s :start end :end offset-slen))))))
794
795 (defun string-capitalize (string &key (start 0) end #+unicode (casing :simple))
796 "Given a string, returns a copy of the string with the first
797 character of each ``word'' converted to upper-case, and remaining
798 chars in the word converted to lower case. A ``word'' is defined
799 to be a string of case-modifiable characters delimited by
800 non-case-modifiable chars."
801 (declare (fixnum start))
802 #-unicode
803 (string-capitalize-simple string :start start :end end)
804 #+unicode
805 (if (eq casing :simple)
806 (string-capitalize-simple string :start start :end end)
807 (string-capitalize-full string :start start :end end)))
808
809 (defun nstring-upcase (string &key (start 0) end)
810 "Given a string, returns that string with all lower case alphabetic
811 characters converted to uppercase."
812 (declare (fixnum start))
813 (let ((save-header string))
814 (with-one-string string start end offset
815 (do ((index start (1+ index)))
816 ((= index (the fixnum end)))
817 (declare (fixnum index))
818 (multiple-value-bind (code wide) (codepoint string index)
819 (declare (ignore wide))
820 ;; Handle ASCII specially because this is called early in
821 ;; initialization, before unidata is available.
822 (cond ((< 96 code 123) (decf code 32))
823 ((> code 127) (setq code (unicode-upper code))))
824 ;;@@ WARNING: this may, in theory, need to extend string
825 ;; (which, obviously, we can't do here. Unless
826 ;; STRING is adjustable, maybe)
827 ;; but that never actually occurs as of Unicode 5.1.0,
828 ;; so I'm just going to ignore it for now...
829 (multiple-value-bind (hi lo) (surrogates code)
830 (setf (schar string index) hi)
831 (when lo
832 (setf (schar string (incf index)) lo))))))
833 save-header))
834
835 (defun nstring-downcase (string &key (start 0) end)
836 "Given a string, returns that string with all upper case alphabetic
837 characters converted to lowercase."
838 (declare (fixnum start))
839 (let ((save-header string))
840 (with-one-string string start end offset
841 (do ((index start (1+ index)))
842 ((= index (the fixnum end)))
843 (declare (fixnum index))
844 (multiple-value-bind (code wide) (codepoint string index)
845 (declare (ignore wide))
846 (cond ((< 64 code 91) (incf code 32))
847 ((> code 127) (setq code (unicode-lower code))))
848 ;;@@ WARNING: this may, in theory, need to extend string
849 ;; (which, obviously, we can't do here. Unless
850 ;; STRING is adjustable, maybe)
851 ;; but that never actually occurs as of Unicode 5.1.0,
852 ;; so I'm just going to ignore it for now...
853 (multiple-value-bind (hi lo) (surrogates code)
854 (setf (schar string index) hi)
855 (when lo
856 (setf (schar string (incf index)) lo))))))
857 save-header))
858
859 (defun nstring-capitalize (string &key (start 0) end)
860 "Given a string, returns that string with the first
861 character of each ``word'' converted to upper-case, and remaining
862 chars in the word converted to lower case. A ``word'' is defined
863 to be a string of case-modifiable characters delimited by
864 non-case-modifiable chars."
865 (declare (fixnum start))
866 (let ((save-header string))
867 (with-one-string string start end offset
868 (do ((index start (1+ index))
869 (newword t)
870 (char ()))
871 ((= index (the fixnum end)))
872 (declare (fixnum index))
873 (setq char (schar string index))
874 (cond ((not (alphanumericp char))
875 (setq newword t))
876 (newword
877 ;;char is first case-modifiable after non-case-modifiable
878 (setf (schar string index) (char-titlecase char))
879 (setq newword ()))
880 (t
881 (setf (schar string index) (char-downcase char))))))
882 save-header))
883
884 (defun string-left-trim (char-bag string)
885 "Given a set of characters (a list or string) and a string, returns
886 a copy of the string with the characters in the set removed from the
887 left end."
888 (with-string string
889 (do ((index start (1+ index)))
890 ((or (= index (the fixnum end))
891 (not (find (schar string index) char-bag)))
892 (subseq (the simple-string string) index end))
893 (declare (fixnum index)))))
894
895 (defun string-right-trim (char-bag string)
896 "Given a set of characters (a list or string) and a string, returns
897 a copy of the string with the characters in the set removed from the
898 right end."
899 (with-string string
900 (do ((index (1- (the fixnum end)) (1- index)))
901 ((or (< index start) (not (find (schar string index) char-bag)))
902 (subseq (the simple-string string) start (1+ index)))
903 (declare (fixnum index)))))
904
905 (defun string-trim (char-bag string)
906 "Given a set of characters (a list or string) and a string, returns a
907 copy of the string with the characters in the set removed from both
908 ends."
909 (with-string string
910 (let* ((left-end (do ((index start (1+ index)))
911 ((or (= index (the fixnum end))
912 (not (find (schar string index) char-bag)))
913 index)
914 (declare (fixnum index))))
915 (right-end (do ((index (1- (the fixnum end)) (1- index)))
916 ((or (< index left-end)
917 (not (find (schar string index) char-bag)))
918 (1+ index))
919 (declare (fixnum index)))))
920 (subseq (the simple-string string) left-end right-end))))
921
922 (declaim (inline %glyph-f %glyph-b))
923 (defun %glyph-f (string index)
924 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
925 (type simple-string string) (type kernel:index index))
926 (let* ((prev 0)
927 (l (length string))
928 (c (codepoint string index l))
929 (n (+ index (if (> c #xFFFF) 2 1))))
930 (declare (type codepoint c) (type kernel:index l n))
931 (loop while (< n l) do
932 (let* ((c (codepoint string n l))
933 (d (the (unsigned-byte 8) (unicode-combining-class c))))
934 (when (or (zerop d) (< d prev))
935 (return))
936 (setq prev d)
937 (incf n (if (> c #xFFFF) 2 1))))
938 n))
939
940 (defun %glyph-b (string index)
941 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))
942 (type simple-string string) (type kernel:index index))
943 (let* ((prev 255)
944 (n (1- index)))
945 (declare (type kernel:index n))
946 (loop until (< n 0) do
947 (let* ((c (codepoint string n 0))
948 (d (the (unsigned-byte 8) (unicode-combining-class c))))
949 (cond ((zerop d) (return))
950 ((> d prev) (incf n (if (> c #xFFFF) 2 1)) (return)))
951 (setq prev d)
952 (decf n (if (> c #xFFFF) 2 1))))
953 n))
954
955 (defun glyph (string index &key (from-end nil))
956 "GLYPH returns the glyph at the indexed position in a string, and the
957 position of the next glyph (or NIL) as a second value. A glyph is
958 a substring consisting of the character at INDEX followed by all
959 subsequent combining characters."
960 (declare (type simple-string string) (type kernel:index index))
961 #-unicode
962 (char string index)
963 #+unicode
964 (with-array-data ((string string) (start) (end))
965 (declare (ignore start end))
966 (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
967 (if from-end
968 (values (subseq string n index) (and (> n 0) n))
969 (values (subseq string index n) (and (< n (length string)) n))))))
970
971 (defun sglyph (string index &key (from-end nil))
972 "SGLYPH returns the glyph at the indexed position, the same as GLYPH,
973 except that the string must be a simple-string"
974 (declare (type simple-string string) (type kernel:index index))
975 #-unicode
976 (schar string index)
977 #+unicode
978 (let ((n (if from-end (%glyph-b string index) (%glyph-f string index))))
979 (if from-end
980 (values (subseq string n index) (and (> n 0) n))
981 (values (subseq string index n) (and (< n (length string)) n)))))
982
983 #+unicode
984 (defun string-reverse* (sequence)
985 (declare (optimize (speed 3) (space 0) (safety 0))
986 (type string sequence))
987 (with-string sequence
988 (let* ((length (- end start))
989 (string (make-string length))
990 (j length))
991 (declare (type kernel:index length j))
992 (loop for i = start then n as n = (%glyph-f sequence i) do
993 (replace string sequence :start1 (decf j (- n i)) :start2 i :end2 n)
994 while (< n end))
995 string)))
996
997 #+unicode
998 (defun string-nreverse* (sequence)
999 (declare (optimize (speed 3) (space 0) (safety 0))
1000 (type string sequence))
1001 (with-string sequence
1002 (flet ((rev (start end)
1003 (do ((i start (1+ i))
1004 (j (1- end) (1- j)))
1005 ((>= i j))
1006 (declare (type kernel:index i j))
1007 (rotatef (schar sequence i) (schar sequence j)))))
1008 (let ((len end))
1009 (loop for i = start then n as n = (%glyph-f sequence i) do
1010 (rev i n) while (< n len))
1011 (rev start end))))
1012 sequence)
1013
1014
1015
1016
1017 (defun decompose (string &optional (compatibility t))
1018 (declare (type string string))
1019 (let ((result (make-string (cond ((< (length string) 40)
1020 (* 5 (length string)))
1021 ((< (length string) 4096)
1022 (* 2 (length string)))
1023 (t (round (length string) 5/6)))))
1024 (fillptr 0))
1025 (declare (type kernel:index fillptr))
1026 (labels ((rec (string start end)
1027 (declare (type simple-string string))
1028 (do ((i start (1+ i)))
1029 ((= i end))
1030 (declare (type kernel:index i))
1031 (multiple-value-bind (code wide) (codepoint string i)
1032 (when wide (incf i))
1033 (let ((decomp (unicode-decomp code compatibility)))
1034 (if decomp (rec decomp 0 (length decomp)) (out code))))))
1035 (out (code)
1036 (multiple-value-bind (hi lo) (surrogates code)
1037 (outch hi)
1038 (when lo
1039 (outch lo))
1040 (let ((cc (unicode-combining-class code)))
1041 (unless (zerop cc)
1042 (order lo cc (- fillptr (if lo 3 2)))))))
1043 (outch (char)
1044 (when (= fillptr (length result))
1045 (let ((tmp (make-string (round (length result) 5/6))))
1046 (replace tmp result)
1047 (setq result tmp)))
1048 (setf (schar result fillptr) char)
1049 (incf fillptr))
1050 (order (wide1 cc last)
1051 (loop until (minusp last) do
1052 (multiple-value-bind (code2 wide2) (codepoint result last)
1053 (let ((cc2 (unicode-combining-class code2)))
1054 (cond ((zerop cc2) (return))
1055 ((> cc2 cc)
1056 (case (+ (if wide2 2 0) (if wide1 1 0))
1057 (0 (rotatef (schar result last)
1058 (schar result (1+ last))))
1059 (1 (rotatef (schar result last)
1060 (schar result (+ last 1))
1061 (schar result (+ last 2))))
1062 (2 (rotatef (schar result last)
1063 (schar result (1- last))
1064 (schar result (1+ last))))
1065 (3 (rotatef (schar result last)
1066 (schar result (+ last 2)))
1067 (rotatef (schar result (1- last))
1068 (schar result (1+ last)))))
1069 (decf last (if wide2 2 1)))
1070 (t (return))))))))
1071 (with-string string
1072 (rec string start end))
1073 (shrink-vector result fillptr))))
1074
1075 (declaim (inline normalized-codepoint-p))
1076 (defun normalized-codepoint-p (cp form)
1077 (ecase form
1078 (:nfc (unicode-nfc-qc cp))
1079 (:nfkc (unicode-nfkc-qc cp))
1080 (:nfd (unicode-nfd-qc cp))
1081 (:nfkd (unicode-nfkd-qc cp))))
1082
1083 ;; Perform check to see if string is already normalized. The Unicode
1084 ;; example can return YES, NO, or MAYBE. For our purposes, only YES
1085 ;; is important, for which we return T. For NO or MAYBE, we return NIL.
1086 (defun normalized-form-p (string &optional (form :nfc))
1087 (declare (type (member :nfc :nfkc :nfd :nfkd) form)
1088 (optimize (speed 3)))
1089 (with-string string
1090 (let ((last-class 0))
1091 (declare (type (integer 0 256) last-class))
1092 (do ((k start (1+ k)))
1093 ((>= k end))
1094 (declare (type kernel:index k))
1095 (multiple-value-bind (ch widep)
1096 (codepoint string k end)
1097 (when widep (incf k))
1098 ;; Handle ASCII specially
1099 (unless (< ch 128)
1100 (let ((class (unicode-combining-class ch)))
1101 (declare (type (unsigned-byte 8) class))
1102 (when (and (> last-class class) (not (zerop class)))
1103 ;; Definitely not normalized
1104 (return-from normalized-form-p nil))
1105 (let ((check (normalized-codepoint-p ch form)))
1106 (unless (eq check :y)
1107 (return-from normalized-form-p nil)))
1108 (setf last-class class)))))
1109 t)))
1110
1111
1112 ;; Compose a string in place. The string must already be in decomposed form.
1113 (defun %compose (target)
1114 (declare (type string target)
1115 (optimize (speed 3)))
1116 (let ((len (length target))
1117 (starter-pos 0))
1118 (declare (type kernel:index starter-pos))
1119 (multiple-value-bind (starter-ch wide)
1120 (codepoint target 0 len)
1121 (let ((comp-pos (if wide 2 1))
1122 (last-class (unicode-combining-class starter-ch)))
1123 (declare (type (integer 0 256) last-class)
1124 (type kernel:index comp-pos))
1125 (unless (zerop last-class)
1126 ;; Fix for strings starting with a combining character
1127 (setf last-class 256))
1128 ;; Loop on decomposed characters, combining where possible
1129 (do ((decomp-pos comp-pos (1+ decomp-pos)))
1130 ((>= decomp-pos len))
1131 (declare (type kernel:index decomp-pos))
1132 (multiple-value-bind (ch wide)
1133 (codepoint target decomp-pos len)
1134 (when wide (incf decomp-pos))
1135 (let ((ch-class (unicode-combining-class ch))
1136 (composite (get-pairwise-composition starter-ch ch)))
1137 (declare (type (integer 0 256) ch-class))
1138 (cond ((and composite
1139 (or (< last-class ch-class) (zerop last-class)))
1140 ;; Don't have to worry about surrogate pairs here
1141 ;; because the composite is always in the BMP.
1142 (setf (aref target starter-pos) (code-char composite))
1143 (setf starter-ch composite))
1144 (t
1145 (when (zerop ch-class)
1146 (setf starter-pos comp-pos)
1147 (setf starter-ch ch))
1148 (setf last-class ch-class)
1149 (multiple-value-bind (hi lo)
1150 (surrogates ch)
1151 (setf (aref target comp-pos) hi)
1152 (when lo
1153 (incf comp-pos)
1154 (setf (aref target comp-pos) lo))
1155 (incf comp-pos)))))))
1156 (shrink-vector target comp-pos)))))
1157
1158 (defun string-to-nfd (string)
1159 "Convert String to Unicode Normalization Form D (NFD) using the
1160 canonical decomposition. The NFD string is returned"
1161 (decompose string nil))
1162
1163 (defun string-to-nfkd (string)
1164 "Convert String to Unicode Normalization Form KD (NFKD) uisng the
1165 compatible decomposition form. The NFKD string is returned."
1166 (decompose string t))
1167
1168 #+unicode
1169 (defun string-to-nfc (string)
1170 "Convert String to Unicode Normalization Form C (NFC)."
1171 (if (normalized-form-p string :nfc)
1172 (if (simple-string-p string) string (coerce string 'simple-string))
1173 (coerce (if (normalized-form-p string :nfd)
1174 (%compose (copy-seq string))
1175 (%compose (string-to-nfd string)))
1176 'simple-string)))
1177
1178 #-unicode ;; Needed by package.lisp
1179 (defun string-to-nfc (string)
1180 (if (simple-string-p string) string (coerce string 'simple-string)))
1181
1182 (defun string-to-nfkc (string)
1183 "Convert String to Unicode Normalization Form KC (NFKC)."
1184 (if (normalized-form-p string :nfkc)
1185 (if (simple-string-p string) string (coerce string 'simple-string))
1186 (coerce (if (normalized-form-p string :nfkd)
1187 (%compose (copy-seq string))
1188 (%compose (string-to-nfkd string)))
1189 'simple-string)))

  ViewVC Help
Powered by ViewVC 1.1.5