source: trunk/ccl/lib/chars.lisp @ 7369

Last change on this file since 7369 was 7369, checked in by gb, 14 years ago

Treat non STANDARD-CHARs which obviously have "case" as if they had case;
this affects UPPER-CASE-P/LOWER-CASE-P, CHAR-UPCASE/-DOWNCASE, ALPHA-CHAR-P
and BOTH-CASE-P, [N]STRING-UPCASE/DOWNCASE, etc.

This stuff is currently only defined for characters C for which either:

(char-upcase C) is distinct from C, and downcasing the uppercase version
returns C, or

(char-downcase C) is distinct from C, and uppercasing the downcase version
returns C.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 21.7 KB
Line 
1; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;; chars.lisp
17
18(in-package "CCL")
19
20; If object is a character, it is returned.  If it is an integer, its INT-CHAR
21; is returned. If it is a string of length 1, then the sole element of the
22; string is returned.  If it is a symbol whose pname is of length 1, then
23; the sole element of the pname is returned. Else error.
24
25(defun character (arg)
26  "Coerce OBJECT into a CHARACTER if possible. Legal inputs are
27  characters, strings and symbols of length 1."
28  (if (typep arg 'character)
29    arg
30    (if (typep arg 'fixnum)
31      (code-char arg)
32      (if (and (typep arg 'string)
33               (= (the fixnum (length arg)) 1))
34        (char arg 0)
35        (let* ((pname (if (typep arg 'symbol) (symbol-name arg))))
36          (if (and pname (= (the fixnum (length pname)) 1))
37            (char pname 0)
38            (%err-disp $xcoerce arg 'character)))))))
39
40
41
42(defun digit-char (weight &optional radix)
43  "All arguments must be integers. Returns a character object that
44  represents a digit of the given weight in the specified radix. Returns
45  NIL if no such character exists."
46  (let* ((r (if radix (require-type radix 'integer) 10)))
47    (if (and (typep (require-type weight 'integer) 'fixnum)
48             (>= r 2)
49             (<= r 36)
50             (>= weight 0)
51             (< weight r))
52      (locally (declare (fixnum weight))
53        (if (< weight 10)
54          (code-char (the fixnum (+ weight (char-code #\0))))
55          (code-char (the fixnum (+ weight (- (char-code #\A) 10)))))))))
56
57
58
59;True for ascii codes 32-126 inclusive.
60; and for guys >= 128. Its really a function of the font of the moment.
61(defun graphic-char-p (c)
62  "The argument must be a character object. GRAPHIC-CHAR-P returns T if the
63  argument is a printing character (space through ~ in ASCII), otherwise
64  returns NIL."
65  (let* ((code (char-code c)))
66    (unless (eq c #\rubout)
67      (>= code (char-code #\space)))))
68
69
70;True for ascii codes 10 and 32-126 inclusive.
71(defun standard-char-p (c)
72  "The argument must be a character object. STANDARD-CHAR-P returns T if the
73   argument is a standard character -- one of the 95 ASCII printing characters
74   or <return>."
75  (let* ((code (char-code c)))
76    (or (eq c #\newline)
77        (and 
78         (>= code (char-code #\space))
79         (< code (char-code #\rubout))))))
80
81
82
83(defun %non-standard-lower-case-equivalent (char)
84  (gethash char *non-standard-upper-to-lower*))
85
86
87
88(defun upper-case-p (c)
89  "The argument must be a character object; UPPER-CASE-P returns T if the
90   argument is an upper-case character, NIL otherwise."
91  (let* ((code (char-code c)))
92    (declare (type (mod #x110000) code))
93    (or (and (>= code (char-code #\A))
94             (<= code (char-code #\Z)))
95        (and (>= code #x80)
96             (not (null (%non-standard-lower-case-equivalent c)))))))
97
98
99
100
101(defun both-case-p (c)
102  "The argument must be a character object. BOTH-CASE-P returns T if the
103  argument is an alphabetic character and if the character exists in
104  both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
105  (let* ((code (char-code c)))
106    (declare (type (mod #x110000) code))
107    (or (and (>= code (char-code #\A))
108             (<= code (char-code #\Z)))
109        (and (>= code (char-code #\a))
110             (<= code (char-code #\z))))))
111 
112(defun alphanumericp (c)
113  "Given a character-object argument, ALPHANUMERICP returns T if the
114   argument is either numeric or alphabetic."
115  (let ((code (char-code c)))
116    (declare (type (mod #x110000) code))
117    (or
118     (and (>= code (char-code #\0))
119          (<= code (char-code #\9)))
120     (and (>= code (char-code #\a))
121          (<= code (char-code #\z)))
122     (and (>= code (char-code #\A))
123          (<= code (char-code #\Z)))
124     (and (> code #x80)
125          (or (not (null (%non-standard-upper-case-equivalent c)))
126              (not (null (%non-standard-lower-case-equivalent c))))))))
127
128(defun char= (ch &rest others)
129  "Return T if all of the arguments are the same character."
130  (declare (dynamic-extent others))
131  (unless (typep ch 'character)
132    (setq ch (require-type ch 'character)))
133  (dolist (other others t)
134    (unless (eq other ch)
135      (unless (typep other 'character)
136        (setq other (require-type other 'character)))
137      (return))))
138
139(defun char/= (ch &rest others)
140  "Return T if no two of the arguments are the same character."
141  (declare (dynamic-extent others))
142  (unless (typep ch 'character)
143    (setq ch (require-type ch 'character)))
144  (do* ((rest others (cdr rest)))
145       ((null rest) t)
146    (let ((other (car rest)))
147      (if (eq other ch) (return))
148      (unless (typep other 'character)
149        (setq other (require-type other 'character)))
150      (dolist (o2 (cdr rest))
151        (if (eq o2 other)(return-from char/= nil))))))
152
153
154(defun char-equal (char &rest others)
155  "Return T if all of the arguments are the same character.
156  Font, bits, and case are ignored."
157  (declare (dynamic-extent others))
158  (locally (declare (optimize (speed 3)(safety 0)))
159    (dolist (c others t)
160      (when (not (eq c char))
161        (unless (eq (char-upcase char) (char-upcase c))
162          (return))))))
163
164;;; Compares each char against all following chars, not just next one. Tries
165;;; to be fast for one or two args.
166(defun char-not-equal (char &rest others)
167  "Return T if no two of the arguments are the same character.
168   Font, bits, and case are ignored."
169  (declare (dynamic-extent others))
170  (locally (declare (optimize (speed 3) (safety 0)))
171    (let* ((rest (cdr others)))
172      (cond 
173       (rest                   
174        (setq char (char-code (char-upcase char)))
175        (do ((list others (cdr list)))
176            ((null list))
177          (rplaca list (char-code (char-upcase (car list)))))
178        (while others
179          (when (memq char others)
180            (return-from char-not-equal nil))
181          (setq char (car others)
182                others rest
183                rest (cdr others)))
184        t)
185       (others                     ;  2 args, no table
186        (not (eq (char-upcase char) (char-upcase (car others)))))
187       (t t)))))
188
189
190(defun char-lessp (char &rest others)
191  "Return T if the arguments are in strictly increasing alphabetic order.
192   Font, bits, and case are ignored."
193  (declare (dynamic-extent others))
194  (locally (declare (optimize (speed 3)(safety 0)))
195    (let* ((code (char-code (char-upcase char))))
196      (dolist (c others t)
197        (unless (< code (setq code (char-code (char-upcase c))))
198          (return))))))
199
200(defun char-not-lessp (char &rest others)
201  "Return T if the arguments are in strictly non-increasing alphabetic order.
202   Font, bits, and case are ignored."
203  (declare (dynamic-extent others))
204  (locally (declare (optimize (speed 3)(safety 0)))
205    (let* ((code (char-code (char-upcase char))))
206      (dolist (c others t)
207        (when (< code (setq code (char-code (char-upcase c))))
208          (return))))))
209
210(defun char-greaterp (char &rest others)
211  "Return T if the arguments are in strictly decreasing alphabetic order.
212   Font, bits, and case are ignored."
213  (declare (dynamic-extent others))
214  (locally (declare (optimize (speed 3)(safety 0)))
215    (let* ((code (char-code (char-upcase char))))
216      (dolist (c others t)
217        (unless (> code (setq code (char-code (char-upcase c))))
218          (return))))))
219
220(defun char-not-greaterp (char &rest others)
221  "Return T if the arguments are in strictly non-decreasing alphabetic order.
222   Font, bits, and case are ignored."
223  (declare (dynamic-extent others))
224  (locally (declare (optimize (speed 3)(safety 0)))
225    (let* ((code (char-code (char-upcase char))))
226      (dolist (c others t)
227        (when (> code (setq code (char-code (char-upcase c))))
228          (return))))))
229
230
231(defun char> (char &rest others)
232  "Return T if the arguments are in strictly decreasing alphabetic order."
233  (declare (dynamic-extent others))
234  (locally (declare (optimize (speed 3)(safety 0)))
235    (let* ()     
236      (setq char (char-code char))
237      (dolist (c others t)
238        (let ((code (char-code c)))
239          (when (not (%i> char (setq char code)))
240            (return)))))))
241
242(defun char>= (char &rest others)
243  "Return T if the arguments are in strictly non-increasing alphabetic order."
244  (declare (dynamic-extent others))
245  (locally (declare (optimize (speed 3)(safety 0)))
246    (let* ()     
247      (setq char (char-code char))
248      (dolist (c others t)
249        (let ((code (char-code c)))
250          (when (not (%i>= char (setq char code)))
251            (return)))))))
252
253
254(defun char< (char &rest others)
255  "Return T if the arguments are in strictly increasing alphabetic order."
256  (declare (dynamic-extent others))
257  (locally (declare (optimize (speed 3)(safety 0)))
258    (let* ()     
259      (setq char (char-code char))
260      (dolist (c others t)
261        (let ((code (char-code c)))
262          (when (not (%i< char (setq char code)))
263            (return)))))))
264
265(defun char<= (char &rest others)
266  "Return T if the arguments are in strictly non-decreasing alphabetic order."
267  (declare (dynamic-extent others))
268  (locally (declare (optimize (speed 3)(safety 0)))
269    (let* ()     
270      (setq char (char-code char))
271      (dolist (c others t)
272        (let ((code (char-code c)))
273          (when (not (%i<= char (setq char code)))
274            (return)))))))
275
276; This is Common Lisp
277(defun char-int (c)
278  "Return the integer code of CHAR."
279  (char-code c))
280
281
282;If char has an entry in the *NAME-CHAR-ALIST*, return first such entry.
283;Otherwise, if char is a graphics character, return NIL
284;Otherwise, if char code is < 128, return "^C", otherwise "1nn"
285
286(defun char-name (c)
287  "Return the name (a STRING) for a CHARACTER object."
288  (let* ((code (char-code c)))
289    (declare (type (mod #x110000) code))
290    (or (gethash c *char->name*)
291        (cond ((< code #x7f)
292               (when (< code (char-code #\space))
293                 (let ((str (make-string 2 :element-type 'base-char)))
294                   (declare (simple-base-string str))
295                   (setf (schar str 0) #\^)
296                   (setf (schar str 1)(code-char (logxor code #x40)))
297                   str)))
298              ((and (< code #x100)(graphic-char-p c)) nil)
299              (t (format nil "U+~4,'0x" code))))))
300
301
302(defun string-downcase (string &key start end)
303  (setq string (copy-string-arg string))
304  (if (not start) (setq start 0)(require-type start 'fixnum))
305  (if (not end)(setq end (length string))(require-type end 'fixnum))
306  (%strdown string start end))
307
308
309(defun %strdown (string start end)
310  (declare (fixnum start end)
311           (optimize (speed 3) (safety 0)))
312  (unless (typep string 'simple-string)
313    (check-type string simple-string))
314  (do* ((i start (1+ i)))
315       ((>= i end) string)
316    (declare (fixnum i))
317    (let* ((ch (schar string i))
318           (code (char-code ch))
319           (lower (if (and (char<= ch #\Z)
320                           (char>= ch #\A))
321                    (%code-char (the (unsigned-byte 8)
322                                  (+ code (- (char-code #\a)(char-code #\A)))))
323                    (if (>= code #x80)
324                      (%non-standard-lower-case-equivalent ch)))))
325      (declare (character ch) (type (mod #x11000) code))
326      (when lower
327        (setf (schar string i) lower)))))
328
329
330
331
332(defun copy-string-arg (string &aux (org 0) len)
333  (etypecase string
334    (string
335     (setq len (length string))
336     (multiple-value-setq (string org)(array-data-and-offset string)))
337    (symbol
338     (setq string (symbol-name string))
339     (setq len (length string)))
340    (character
341     (return-from copy-string-arg
342                    (make-string 1 :initial-element string :element-type (type-of string)))))
343  (%substr string org (+ len org)))     
344
345(defun string-upcase (string &key start end)
346  (setq string (copy-string-arg string))
347  (if (not start) (setq start 0)(require-type start 'fixnum))
348  (if (not end)(setq end (length string))(require-type end 'fixnum))
349  (%strup string start end))
350
351(defun %strup (string start end)
352  (declare (fixnum start end)
353           (optimize (speed 3) (safety 0)))
354  (unless (typep string 'simple-string)
355    (check-type string simple-string))
356  (do* ((i start (1+ i)))
357       ((>= i end) string)
358    (declare (fixnum i))
359    (let* ((ch (schar string i))
360           (code (char-code ch))
361           (upper (if (and (char<= ch #\z)
362                           (char>= ch #\a))
363                    (%code-char (the (unsigned-byte 8)
364                                  (- code (- (char-code #\a)(char-code #\A)))))
365                    (if (>= code #x80)
366                      (%non-standard-upper-case-equivalent ch)))))
367      (declare (character ch) (type (mod #x11000) code))
368      (when upper
369        (setf (schar string i) upper)))))
370
371
372
373(defun string-capitalize (string &key start end)
374  (setq string (copy-string-arg string))
375  (if (not start) (setq start 0)(require-type start 'fixnum))
376  (if (not end)(setq end (length string))(require-type end 'fixnum))
377  (%strcap string start end))
378
379(defun %strcap (string start end)
380  (declare (fixnum start end))
381  (let ((state :up)
382        (i start))
383    (declare (fixnum i))
384    (while (< i end)
385      (let* ((c (%schar string i))
386             (alphap (alphanumericp c))) ; makes no sense
387        (if alphap
388          (progn
389            (setf (%schar string i)
390                  (case state
391                    (:up (char-upcase c))
392                    (t (char-downcase c))))
393            (setq state :down))
394          (setq state :up)))
395      (setq i (1+ i)))
396    string))
397
398
399
400
401(defun nstring-downcase (string &key start end)
402  (etypecase string
403    (string
404     (if (not start) (setq start 0)(require-type start 'fixnum))
405     (if (not end)(setq end (length string))(require-type end 'fixnum))
406     (multiple-value-bind (sstring org) (array-data-and-offset string)
407       (%strdown sstring (+ start org)(+ end org)))
408     string)))
409
410(defun nstring-upcase (string &key start end)
411  (etypecase string
412    (string
413     (if (not start) (setq start 0)(require-type start 'fixnum))
414     (if (not end)(setq end (length string))(require-type end 'fixnum))
415     (multiple-value-bind (sstring org) (array-data-and-offset string)
416       (%strup sstring (+ start org)(+ end org)))
417     string)))
418
419
420(defun nstring-capitalize (string &key start end)
421  (etypecase string
422    (string
423     (if (not start) (setq start 0)(require-type start 'fixnum))
424     (if (not end)(setq end (length string))(require-type end 'fixnum))
425     (multiple-value-bind (sstring org) (array-data-and-offset string)
426       (%strcap sstring (+ start org)(+ end org)))
427     string)))
428
429
430
431(defun nstring-studlify (string &key start end)
432  (declare (ignore start end))
433  string)
434
435 
436(defun string-compare (string1 start1 end1 string2 start2 end2)
437  (let ((istart1 (or start1 0)))
438    (if (and (typep string1 'simple-string)(null start1)(null end1))
439      (setq start1 0 end1 (length string1))
440      (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
441    (if (and (typep string2 'simple-string)(null start2)(null end2))
442      (setq start2 0 end2 (length string2))
443      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
444    (setq istart1 (%i- start1 istart1))       
445    (let* ((val t))
446      (declare (optimize (speed 3)(safety 0)))
447      (do* ((i start1 (%i+ 1 i))
448            (j start2 (%i+ 1 j)))
449           ()
450        (when (eq i end1)
451          (when (neq j end2)(setq val -1))
452          (return))
453        (when (eq j end2)
454          (setq end1 i)
455          (setq val 1)(return))
456        (let ((code1 (%scharcode string1 i))
457              (code2 (%scharcode string2 j)))
458          (declare (fixnum code1 code2))
459          (if (and (>= code1 (char-code #\a))
460                   (<= code1 (char-code #\z)))
461            (setq code1 (- code1 (- (char-code #\a) (char-code #\A)))))
462          (if (and (>= code2 (char-code #\a))
463                   (<= code2 (char-code #\z)))
464            (setq code2 (- code2 (- (char-code #\a) (char-code #\A)))))
465          (unless (= code1 code2)           
466            (setq val (if (%i< code1 code2) -1 1))
467            (setq end1 i)
468            (return))))
469      (values val (%i- end1 istart1)))))
470
471
472(defun string-greaterp (string1 string2 &key start1 end1 start2 end2)
473  "Given two strings, if the first string is lexicographically greater than
474  the second string, returns the longest common prefix (using char-equal)
475  of the two strings. Otherwise, returns ()."
476  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
477    (if (eq result 1) pos nil)))
478
479(defun string-not-greaterp (string1 string2 &key start1 end1 start2 end2)
480  "Given two strings, if the first string is lexicographically less than
481  or equal to the second string, returns the longest common prefix
482  (using char-equal) of the two strings. Otherwise, returns ()."
483  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
484    (if (eq result 1) nil pos)))
485
486(defun string-not-equal (string1 string2 &key start1 end1 start2 end2)
487  "Given two strings, if the first string is not lexicographically equal
488  to the second string, returns the longest common prefix (using char-equal)
489  of the two strings. Otherwise, returns ()."
490  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
491    (if (eq result t) nil pos)))
492
493(defun string-not-lessp (string1 string2 &key start1 end1 start2 end2)
494  "Given two strings, if the first string is lexicographically greater
495  than or equal to the second string, returns the longest common prefix
496  (using char-equal) of the two strings. Otherwise, returns ()."
497  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
498    (if (eq result -1) nil pos)))
499
500(defun string-equal (string1 string2 &key start1 end1 start2 end2)
501  "Given two strings (string1 and string2), and optional integers start1,
502  start2, end1 and end2, compares characters in string1 to characters in
503  string2 (using char-equal)."
504  (eq t (string-compare string1 start1 end1 string2 start2 end2)))
505
506
507(defun string-lessp (string1 string2 &key start1 end1 start2 end2)
508  "Given two strings, if the first string is lexicographically less than
509  the second string, returns the longest common prefix (using char-equal)
510  of the two strings. Otherwise, returns ()."
511  (multiple-value-bind (result pos)(string-compare string1 start1 end1 string2 start2 end2)
512    (if (eq result -1) pos nil)))
513
514; forget script-manager - just do codes
515(defun string-cmp (string1 start1 end1 string2 start2 end2)
516  (let ((istart1 (or start1 0)))
517    (if (and (typep string1 'simple-string)(null start1)(null end1))
518      (setq start1 0 end1 (length string1))
519      (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
520    (if (and (typep string2 'simple-string)(null start2)(null end2))
521      (setq start2 0 end2 (length string2))
522      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
523    (setq istart1 (%i- start1 istart1))       
524    (let* ((val t))
525      (declare (optimize (speed 3)(safety 0)))
526      (do* ((i start1 (%i+ 1 i))
527            (j start2 (%i+ 1 j)))
528           ()
529        (when (eq i end1)
530          (when (neq j end2)(setq val -1))
531          (return))
532        (when (eq j end2)
533          (setq end1 i)
534          (setq val 1)(return))
535        (let ((code1 (%scharcode string1 i))
536              (code2 (%scharcode string2 j)))
537          (declare (fixnum code1 code2))
538          (unless (= code1 code2)           
539            (setq val (if (%i< code1 code2) -1 1))
540            (setq end1 i)
541            (return))))
542      (values val (%i- end1 istart1)))))
543
544(defun string> (string1 string2 &key start1 end1 start2 end2)
545  "Given two strings, if the first string is lexicographically greater than
546  the second string, returns the longest common prefix (using char=)
547  of the two strings. Otherwise, returns ()."
548  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
549    (if (eq result 1) pos nil)))
550
551(defun string>= (string1 string2 &key start1 end1 start2 end2)
552  "Given two strings, if the first string is lexicographically greater
553  than or equal to the second string, returns the longest common prefix
554  (using char=) of the two strings. Otherwise, returns ()."
555  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
556    (if (eq result -1) nil pos)))
557
558(defun string< (string1 string2 &key start1 end1 start2 end2)
559  "Given two strings, if the first string is lexicographically less than
560  the second string, returns the longest common prefix (using char=)
561  of the two strings. Otherwise, returns ()."
562  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
563    (if (eq result -1) pos nil)))
564
565(defun string<= (string1 string2 &key start1 end1 start2 end2)
566  "Given two strings, if the first string is lexicographically less than
567  or equal to the second string, returns the longest common prefix
568  (using char=) of the two strings. Otherwise, returns ()."
569  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
570    (if (eq result 1) nil pos)))
571
572; this need not be so fancy?
573(defun string/= (string1 string2 &key start1 end1 start2 end2)
574  "Given two strings, if the first string is not lexicographically equal
575  to the second string, returns the longest common prefix (using char=)
576  of the two strings. Otherwise, returns ()."
577  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
578    (if (eq result t) nil pos)))
579
580
581
582(provide 'chars)
Note: See TracBrowser for help on using the repository browser.