source: trunk/source/lib/chars.lisp @ 12259

Last change on this file since 12259 was 12259, checked in by gb, 10 years ago

GRAPHIC-CHAR-P: return false for characters whose codes are in ranges
assigned to/reserved for control/formatting characters, T otherwise.
(On Darwin, part of the vendor-private range starting at #xf700 is
used for arrow/function key characters, so recognize those characters
as non-graphic, too.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.0 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(declaim (inline %control-char-p))
59
60(defun %control-char-p (char)
61  (let* ((code (char-code char)))
62    (declare (type (mod #x110000) code))
63    ;; If we believe that "most" characters will have relatively
64    ;; small codes, then doing a linear search on this short
65    ;; list is probably faster than binary search on a vector
66    ;; or other approaches.
67    (dolist (pair '((0 . #x1f)                          ;c0
68                    (#x7f . #x9f)                       ;#\rubout, c1
69                    (#x34f . #x34f)                     ;combining grapheme joiner.
70                    (#x200c . #x200f)
71                    (#x202a . #x202e)
72                    (#x2060 . #x2063)
73                    (#x206a . #x206f)
74                    #+darwin-target
75                    (#xf700 . #xf7ff)
76                    (#xfe00 . #xfe0f)
77                    (#xfeff . #xfeff)                   ;byte-order mark (0-width space).
78                    (#xfff0 . #xfffd)
79                   
80                    (#xe0000 . #xefffd)))
81      (let* ((low (car pair))
82             (high (cdr pair)))
83        (declare (type (mod #x110000) low high))
84        (if (> low code)
85          (return nil)
86          (if (<= code high)
87            (return t)))))))
88
89
90
91;;; Characters that aren't control/formatting characters are graphic.
92(defun graphic-char-p (c)
93  "The argument must be a character object. GRAPHIC-CHAR-P returns NIL if the
94  argument is a Unicode control character, otherwise returns T."
95  (not (%control-char-p c)))
96
97
98;True for ascii codes 10 and 32-126 inclusive.
99(defun standard-char-p (c)
100  "The argument must be a character object. STANDARD-CHAR-P returns T if the
101   argument is a standard character -- one of the 95 ASCII printing characters
102   or <return>."
103  (let* ((code (char-code c)))
104    (or (eq c #\newline)
105        (and 
106         (>= code (char-code #\space))
107         (< code (char-code #\rubout))))))
108
109
110
111
112
113
114
115(defun upper-case-p (c)
116  "The argument must be a character object; UPPER-CASE-P returns T if the
117   argument is an upper-case character, NIL otherwise."
118  (let* ((code (char-code c))
119         (to-lower *upper-to-lower*))
120    (declare (type (mod #x110000) code)
121             (type (simple-array (signed-byte 16) (*)) to-lower))
122    (and (< code (length to-lower))
123         (not (zerop (aref to-lower code))))))
124
125
126
127
128(defun both-case-p (c)
129  "The argument must be a character object. BOTH-CASE-P returns T if the
130  argument is an alphabetic character and if the character exists in
131  both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
132  (let* ((code (char-code c))
133         (to-upper *lower-to-upper*)
134         (to-lower *upper-to-lower*))
135    (declare (type (mod #x110000) code)
136             (type (simple-array (signed-byte 16) (*)) to-lower to-upper))
137    (or (and (< code (length to-upper))
138             (not (zerop (aref to-upper code))))
139        (and (< code (length to-lower))
140             (not (zerop (aref to-lower code)))))))
141 
142(defun alphanumericp (c)
143  "Given a character-object argument, ALPHANUMERICP returns T if the
144   argument is either numeric or alphabetic."
145  (let ((code (char-code c)))
146    (declare (type (mod #x110000) code))
147    (or
148     (and (>= code (char-code #\0))
149          (<= code (char-code #\9)))
150     (let* ((bits *alpha-char-bits*))
151       (declare (simple-bit-vector bits))
152       (and (< code (length bits))
153            (not (eql 0 (sbit bits code))))))))
154
155(defun char= (ch &rest others)
156  "Return T if all of the arguments are the same character."
157  (declare (dynamic-extent others))
158  (unless (typep ch 'character)
159    (setq ch (require-type ch 'character)))
160  (dolist (other others t)
161    (unless (eq other ch)
162      (unless (typep other 'character)
163        (setq other (require-type other 'character)))
164      (return))))
165
166(defun char/= (ch &rest others)
167  "Return T if no two of the arguments are the same character."
168  (declare (dynamic-extent others))
169  (unless (typep ch 'character)
170    (setq ch (require-type ch 'character)))
171  (do* ((rest others (cdr rest)))
172       ((null rest) t)
173    (let ((other (car rest)))
174      (if (eq other ch) (return))
175      (unless (typep other 'character)
176        (setq other (require-type other 'character)))
177      (dolist (o2 (cdr rest))
178        (if (eq o2 other)(return-from char/= nil))))))
179
180
181(defun char-equal (char &rest others)
182  "Return T if all of the arguments are the same character.
183  Font, bits, and case are ignored."
184  (declare (dynamic-extent others))
185  (locally (declare (optimize (speed 3)(safety 0)))
186    (dolist (c others t)
187      (when (not (eq c char))
188        (unless (eq (char-upcase char) (char-upcase c))
189          (return))))))
190
191;;; Compares each char against all following chars, not just next one. Tries
192;;; to be fast for one or two args.
193(defun char-not-equal (char &rest others)
194  "Return T if no two of the arguments are the same character.
195   Font, bits, and case are ignored."
196  (declare (dynamic-extent others))
197  (locally (declare (optimize (speed 3) (safety 0)))
198    (let* ((rest (cdr others)))
199      (cond 
200       (rest                   
201        (setq char (char-code (char-upcase char)))
202        (do ((list others (cdr list)))
203            ((null list))
204          (rplaca list (char-code (char-upcase (car list)))))
205        (while others
206          (when (memq char others)
207            (return-from char-not-equal nil))
208          (setq char (car others)
209                others rest
210                rest (cdr others)))
211        t)
212       (others                     ;  2 args, no table
213        (not (eq (char-upcase char) (char-upcase (car others)))))
214       (t t)))))
215
216
217(defun char-lessp (char &rest others)
218  "Return T if the arguments are in strictly increasing alphabetic order.
219   Font, bits, and case are ignored."
220  (declare (dynamic-extent others))
221  (locally (declare (optimize (speed 3)(safety 0)))
222    (let* ((code (char-code (char-upcase char))))
223      (dolist (c others t)
224        (unless (< code (setq code (char-code (char-upcase c))))
225          (return))))))
226
227(defun char-not-lessp (char &rest others)
228  "Return T if the arguments are in strictly non-increasing alphabetic order.
229   Font, bits, and case are ignored."
230  (declare (dynamic-extent others))
231  (locally (declare (optimize (speed 3)(safety 0)))
232    (let* ((code (char-code (char-upcase char))))
233      (dolist (c others t)
234        (when (< code (setq code (char-code (char-upcase c))))
235          (return))))))
236
237(defun char-greaterp (char &rest others)
238  "Return T if the arguments are in strictly decreasing alphabetic order.
239   Font, bits, and case are ignored."
240  (declare (dynamic-extent others))
241  (locally (declare (optimize (speed 3)(safety 0)))
242    (let* ((code (char-code (char-upcase char))))
243      (dolist (c others t)
244        (unless (> code (setq code (char-code (char-upcase c))))
245          (return))))))
246
247(defun char-not-greaterp (char &rest others)
248  "Return T if the arguments are in strictly non-decreasing alphabetic order.
249   Font, bits, and case are ignored."
250  (declare (dynamic-extent others))
251  (locally (declare (optimize (speed 3)(safety 0)))
252    (let* ((code (char-code (char-upcase char))))
253      (dolist (c others t)
254        (when (> code (setq code (char-code (char-upcase c))))
255          (return))))))
256
257
258(defun char> (char &rest others)
259  "Return T if the arguments are in strictly decreasing alphabetic order."
260  (declare (dynamic-extent others))
261  (locally (declare (optimize (speed 3)(safety 0)))
262    (let* ()     
263      (setq char (char-code char))
264      (dolist (c others t)
265        (let ((code (char-code c)))
266          (when (not (%i> char (setq char code)))
267            (return)))))))
268
269(defun char>= (char &rest others)
270  "Return T if the arguments are in strictly non-increasing alphabetic order."
271  (declare (dynamic-extent others))
272  (locally (declare (optimize (speed 3)(safety 0)))
273    (let* ()     
274      (setq char (char-code char))
275      (dolist (c others t)
276        (let ((code (char-code c)))
277          (when (not (%i>= char (setq char code)))
278            (return)))))))
279
280
281(defun char< (char &rest others)
282  "Return T if the arguments are in strictly increasing alphabetic order."
283  (declare (dynamic-extent others))
284  (locally (declare (optimize (speed 3)(safety 0)))
285    (let* ()     
286      (setq char (char-code char))
287      (dolist (c others t)
288        (let ((code (char-code c)))
289          (when (not (%i< char (setq char code)))
290            (return)))))))
291
292(defun char<= (char &rest others)
293  "Return T if the arguments are in strictly non-decreasing alphabetic order."
294  (declare (dynamic-extent others))
295  (locally (declare (optimize (speed 3)(safety 0)))
296    (let* ()     
297      (setq char (char-code char))
298      (dolist (c others t)
299        (let ((code (char-code c)))
300          (when (not (%i<= char (setq char code)))
301            (return)))))))
302
303; This is Common Lisp
304(defun char-int (c)
305  "Return the integer code of CHAR."
306  (char-code c))
307
308
309;If char has an entry in the *NAME-CHAR-ALIST*, return first such entry.
310;Otherwise, if char is a graphics character, return NIL
311;Otherwise, if char code is < 128, return "^C", otherwise "1nn"
312
313(defun char-name (c)
314  "Return the name (a STRING) for a CHARACTER object."
315  (let* ((code (char-code c)))
316    (declare (type (mod #x110000) code))
317    (or (gethash c *char->name*)
318        (cond ((< code #x7f)
319               (when (< code (char-code #\space))
320                 (let ((str (make-string 2 :element-type 'base-char)))
321                   (declare (simple-base-string str))
322                   (setf (schar str 0) #\^)
323                   (setf (schar str 1)(code-char (logxor code #x40)))
324                   str)))
325              ((and (< code #x100)(graphic-char-p c)) nil)
326              (t (format nil "U+~4,'0x" code))))))
327
328
329(defun string-downcase (string &key (start 0) end)
330  (setq string (copy-string-arg string))
331  (setq end (check-sequence-bounds string start end))
332  (%strdown string start end))
333
334
335(defun %strdown (string start end)
336  (declare (fixnum start end)
337           (optimize (speed 3) (safety 0)))
338  (unless (typep string 'simple-string)
339    (check-type string simple-string))
340  (do* ((i start (1+ i))
341        (to-lower *upper-to-lower*)
342        (n (length to-lower)))
343       ((>= i end) string)
344    (declare (fixnum i n) (type (simple-array (signed-byte 16) (*)) to-lower))
345    (let* ((ch (schar string i))
346           (code (char-code ch))
347           (delta (if (< code n) (aref to-lower code) 0)))
348      (declare (character ch)
349               (type (mod #x110000) code)
350               (type (signed-byte 16) delta))
351      (unless (zerop delta)
352        (setf (schar string i)
353              (code-char (the valid-char-code (+ code delta))))))))
354
355
356
357
358(defun copy-string-arg (string &aux (org 0) len)
359  (etypecase string
360    (string
361     (setq len (length string))
362     (multiple-value-setq (string org)(array-data-and-offset string)))
363    (symbol
364     (setq string (symbol-name string))
365     (setq len (length string)))
366    (character
367     (return-from copy-string-arg
368                    (make-string 1 :initial-element string ))))
369  (%substr string org (+ len org)))     
370
371(defun string-upcase (string &key (start 0) end)
372  (setq string (copy-string-arg string))
373  (setq end (check-sequence-bounds string start end))
374  (%strup string start end))
375
376(defun %strup (string start end)
377  (declare (fixnum start end)
378           (optimize (speed 3) (safety 0)))
379  (unless (typep string 'simple-string)
380    (check-type string simple-string))
381  (do* ((i start (1+ i))
382        (to-upper *lower-to-upper*)
383        (n (length to-upper)))
384       ((>= i end) string)
385    (declare (fixnum i n) (type (simple-array (signed-byte 16) (*)) to-upper))
386    (let* ((ch (schar string i))
387           (code (char-code ch))
388           (delta (if (< code n) (aref to-upper code) 0)))
389      (declare (character ch)
390               (type (mod #x110000) code)
391               (type (signed-byte 16) delta))
392      (unless (zerop delta)
393        (setf (schar string i) (code-char (the valid-char-code (+ code delta))))))))
394
395
396
397(defun string-capitalize (string &key (start 0) end)
398  (setq string (copy-string-arg string))
399  (setq end (check-sequence-bounds string start end))
400  (%strcap string start end))
401
402(defun %strcap (string start end)
403  (declare (fixnum start end))
404  (let ((state :up)
405        (i start))
406    (declare (fixnum i))
407    (while (< i end)
408      (let* ((c (%schar string i))
409             (alphap (alphanumericp c))) ; makes no sense
410        (if alphap
411          (progn
412            (setf (%schar string i)
413                  (case state
414                    (:up (char-upcase c))
415                    (t (char-downcase c))))
416            (setq state :down))
417          (setq state :up)))
418      (setq i (1+ i)))
419    string))
420
421
422
423
424(defun nstring-downcase (string &key (start 0) end)
425  (etypecase string
426    (string
427     (setq end (check-sequence-bounds string start end))
428     (if (typep string 'simple-string)
429       (%strdown string start end)
430       (multiple-value-bind (data offset) (array-data-and-offset string)
431         (%strdown data (+ start offset) (+ end offset))))
432     string)))
433
434(defun nstring-upcase (string &key (start 0) end)
435  (etypecase string
436    (string
437     (setq end (check-sequence-bounds string start end))
438     (if (typep string 'simple-string)
439       (%strup string start end)
440       (multiple-value-bind (data offset) (array-data-and-offset string)
441         (%strup data (+ start offset) (+ end offset))))
442     string)))
443
444
445(defun nstring-capitalize (string &key (start 0) end)
446  (etypecase string
447    (string
448     (setq end (check-sequence-bounds string start end))
449     (if (typep string 'simple-string)
450       (%strcap string start end)
451       (multiple-value-bind (data offset) (array-data-and-offset string)
452         (%strcap data (+ start offset) (+ end offset))))
453     string)))
454
455
456
457(defun nstring-studlify (string &key start end)
458  (declare (ignore start end))
459  string)
460
461 
462(defun string-compare (string1 start1 end1 string2 start2 end2)
463  (let ((istart1 (or start1 0)))
464    (if (and (typep string1 'simple-string)(null start1)(null end1))
465      (setq start1 0 end1 (length string1))
466      (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
467    (if (and (typep string2 'simple-string)(null start2)(null end2))
468      (setq start2 0 end2 (length string2))
469      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
470    (setq istart1 (%i- start1 istart1))
471    (let* ((val t))
472      (declare (optimize (speed 3)(safety 0)))
473      (do* ((i start1 (%i+ 1 i))
474            (j start2 (%i+ 1 j)))
475           ()
476        (when (eq i end1)
477          (when (neq j end2)
478            (setq val -1))
479          (return))
480        (when (eq j end2)
481          (setq end1 i)
482          (setq val 1)
483          (return))
484        (let ((code1 (%scharcode string1 i))
485              (code2 (%scharcode string2 j)))
486          (declare (fixnum code1 code2))
487          (if (and (>= code1 (char-code #\a))
488                   (<= code1 (char-code #\z)))
489            (setq code1 (- code1 (- (char-code #\a) (char-code #\A)))))
490          (if (and (>= code2 (char-code #\a))
491                   (<= code2 (char-code #\z)))
492            (setq code2 (- code2 (- (char-code #\a) (char-code #\A)))))
493          (unless (= code1 code2)           
494            (setq val (if (%i< code1 code2) -1 1))
495            (setq end1 i)
496            (return))))
497      (values val (%i- end1 istart1)))))
498
499
500(defun string-greaterp (string1 string2 &key start1 end1 start2 end2)
501  "Given two strings, if the first string is lexicographically greater than
502  the second string, returns the longest common prefix (using char-equal)
503  of the two strings. Otherwise, returns ()."
504  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
505    (if (eq result 1) pos nil)))
506
507(defun string-not-greaterp (string1 string2 &key start1 end1 start2 end2)
508  "Given two strings, if the first string is lexicographically less than
509  or equal to the second string, returns the longest common prefix
510  (using char-equal) 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) nil pos)))
513
514(defun string-not-equal (string1 string2 &key start1 end1 start2 end2)
515  "Given two strings, if the first string is not lexicographically equal
516  to the second string, returns the longest common prefix (using char-equal)
517  of the two strings. Otherwise, returns ()."
518  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
519    (if (eq result t) nil pos)))
520
521(defun string-not-lessp (string1 string2 &key start1 end1 start2 end2)
522  "Given two strings, if the first string is lexicographically greater
523  than or equal to the second string, returns the longest common prefix
524  (using char-equal) of the two strings. Otherwise, returns ()."
525  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
526    (if (eq result -1) nil pos)))
527
528(declaim (inline %string-start-end))
529(defun %string-start-end (string)
530  (etypecase string
531    (string (multiple-value-bind (data offset)
532                (array-data-and-offset string)
533              (declare (fixnum offset))
534              (values data offset (+ offset (length string)))))
535    (symbol (let* ((pname (symbol-name string)))
536              (values pname 0 (length pname))))
537    (character (let* ((data (make-string 1)))
538                 (setf (schar data 0) string)
539                 (values data 0 1)))))
540                       
541;;; This is generally a bit faster then the version that deals with
542;;; user-supplied bounds, both because the caller avoids passing
543;;; some extra arguments and because those bounds don't need to be
544;;; validated.
545(defun %fixed-string-equal (string1 string2)
546  (let* ((start1 0)
547         (end1 0)
548         (start2 0)
549         (end2 0))
550    (declare (fixnum start1 end1 start2 end2))
551    (if (typep string1 'simple-string)
552      (setq end1 (uvsize string1))
553      (multiple-value-setq (string1 start1 end1)
554        (%string-start-end string1)))
555    (if (typep string2 'simple-string)
556      (setq end2 (uvsize string2))
557      (multiple-value-setq (string2 start2 end2)
558        (%string-start-end string2)))
559    (locally
560        (declare (optimize (speed 3)(safety 0))
561                 (simple-string string1 string2))
562      (when (= (the fixnum (- end1 start1))
563               (the fixnum (- end2 start2)))
564        (do* ((i start1 (1+ i))
565              (j start2 (1+ j))
566              (map *lower-to-upper*))
567             ((= i end1) t)
568          (declare (fixnum i j))
569          (let ((code1 (%scharcode string1 i))
570                (code2 (%scharcode string2 j)))
571            (declare (type (mod #x110000) code1 code2))
572            (unless (= code1 code2)
573              (unless (= (the (mod #x110000) (%char-code-case-fold code1 map))
574                         (the (mod #x110000) (%char-code-case-fold code2 map)))
575                (return)))))))))
576
577;;; Some of the start1/end1/start2/end2 args may be bogus.
578(defun %bounded-string-equal (string1 string2 start1 end1 start2 end2)
579  (let* ((disp1 nil)
580         (len1 0)
581         (disp2 nil)
582         (len2 0))
583    (declare (fixnum len1 len2))
584    (if (typep string1 'simple-string)
585      (setq len1 (length (the simple-string string1)))
586      (etypecase string1
587        (string (setq len1 (length string1))
588                (multiple-value-setq (string1 disp1)
589                  (array-data-and-offset string1)))
590        (symbol (setq string1 (symbol-name string1)
591                      len1 (length (the simple-string string1))))
592        (character (setq string1 (make-string 1 :initial-element string1)
593                         len1 1))))
594    (if (typep string2 'simple-string)
595      (setq len2 (length (the simple-string string2)))
596      (etypecase string2
597        (string (setq len2 (length string2))
598                (multiple-value-setq (string2 disp2)
599                  (array-data-and-offset string2)))
600        (symbol (setq string2 (symbol-name string2)
601                      len1 (length (the simple-string string2))))
602        (character (setq string2 (make-string 1 :initial-element string2)
603                         len1 1))))
604    (flet ((bad-index (index vector) (error "Index ~s is invalid for ~s" index vector)))
605      (if (null start1)
606        (setq start1 0)
607        (when (or (not (typep start1 'fixnum))
608                  (< (the fixnum start1) 0))
609          (bad-index start1 string1)))
610      (if (null end1)
611        (setq end1 len1)
612        (when (or (not (typep end1 'fixnum))
613                  (< (the fixnum end1) 0)
614                  (> (the fixnum end1) len1))
615          (bad-index end1 string1)))
616      (locally (declare (fixnum start1 end1))
617        (if (> start1 end1)
618          (error ":start1 argument ~s exceeds :end1 argument ~s" start1 end1))
619        (when disp1
620          (locally (declare (fixnum disp1))
621            (incf start1 disp1)
622            (incf end1 disp1)))
623        (if (null start2)
624          (setq start2 0)
625          (when (or (not (typep start2 'fixnum))
626                    (< (the fixnum start2) 0))
627            (bad-index start2 string2)))
628        (if (null end2)
629          (setq end2 len2)
630          (when (or (not (typep end2 'fixnum))
631                    (< (the fixnum end2) 0)
632                    (> (the fixnum end2) len2))
633            (bad-index end2 string2)))
634        (locally (declare (fixnum start2 end2))
635          (if (> start2 end2)
636            (error ":start2 argument ~s exceeds :end2 argument ~s" start1 end1))
637          (when disp2
638            (locally (declare (fixnum disp2))
639              (incf start2 disp2)
640              (incf end2 disp2)))
641          (locally
642              (declare (optimize (speed 3)(safety 0))
643                       (simple-string string1 string2))
644            (when (= (the fixnum (- end1 start1))
645                     (the fixnum (- end2 start2)))
646              (do* ((i start1 (1+ i))
647                    (j start2 (1+ j))
648                    (map *lower-to-upper*))
649                   ((= i end1) t)
650                (declare (fixnum i j))
651                (let ((code1 (%scharcode string1 i))
652                      (code2 (%scharcode string2 j)))
653                  (declare (type (mod #x110000) code1 code2))
654                  (unless (= code1 code2)
655                    (unless (= (the (mod #x110000) (%char-code-case-fold code1 map))
656                               (the (mod #x110000) (%char-code-case-fold code2 map)))
657                      (return))))))))))))
658
659(defun string-equal (string1 string2 &key start1 end1 start2 end2)
660  "Given two strings (string1 and string2), and optional integers start1,
661  start2, end1 and end2, compares characters in string1 to characters in
662  string2 (using char-equal)."
663  (if (or start1 end1 start2 end2)
664    (%bounded-string-equal string1 string2 start1 end1 start2 end2)
665    (%fixed-string-equal string1 string2)))
666
667
668
669(defun string-lessp (string1 string2 &key start1 end1 start2 end2)
670  "Given two strings, if the first string is lexicographically less than
671  the second string, returns the longest common prefix (using char-equal)
672  of the two strings. Otherwise, returns ()."
673  (multiple-value-bind (result pos)(string-compare string1 start1 end1 string2 start2 end2)
674    (if (eq result -1) pos nil)))
675
676;;; forget script-manager - just do codes
677(defun string-cmp (string1 start1 end1 string2 start2 end2)
678  (let ((istart1 (or start1 0)))
679    (if (and (typep string1 'simple-string)(null start1)(null end1))
680      (setq start1 0 end1 (length string1))
681      (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
682    (if (and (typep string2 'simple-string)(null start2)(null end2))
683      (setq start2 0 end2 (length string2))
684      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
685    (setq istart1 (%i- start1 istart1))       
686    (let* ((val t))
687      (declare (optimize (speed 3)(safety 0)))
688      (do* ((i start1 (%i+ 1 i))
689            (j start2 (%i+ 1 j)))
690           ()
691        (when (eq i end1)
692          (when (neq j end2)(setq val -1))
693          (return))
694        (when (eq j end2)
695          (setq end1 i)
696          (setq val 1)(return))
697        (let ((code1 (%scharcode string1 i))
698              (code2 (%scharcode string2 j)))
699          (declare (fixnum code1 code2))
700          (unless (= code1 code2)           
701            (setq val (if (%i< code1 code2) -1 1))
702            (setq end1 i)
703            (return))))
704      (values val (%i- end1 istart1)))))
705
706(defun string> (string1 string2 &key start1 end1 start2 end2)
707  "Given two strings, if the first string is lexicographically greater than
708  the second string, returns the longest common prefix (using char=)
709  of the two strings. Otherwise, returns ()."
710  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
711    (if (eq result 1) pos nil)))
712
713(defun string>= (string1 string2 &key start1 end1 start2 end2)
714  "Given two strings, if the first string is lexicographically greater
715  than or equal to the second string, returns the longest common prefix
716  (using char=) of the two strings. Otherwise, returns ()."
717  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
718    (if (eq result -1) nil pos)))
719
720(defun string< (string1 string2 &key start1 end1 start2 end2)
721  "Given two strings, if the first string is lexicographically less than
722  the second string, returns the longest common prefix (using char=)
723  of the two strings. Otherwise, returns ()."
724  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
725    (if (eq result -1) pos nil)))
726
727(defun string<= (string1 string2 &key start1 end1 start2 end2)
728  "Given two strings, if the first string is lexicographically less than
729  or equal to the second string, returns the longest common prefix
730  (using char=) of the two strings. Otherwise, returns ()."
731  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
732    (if (eq result 1) nil pos)))
733
734; this need not be so fancy?
735(defun string/= (string1 string2 &key start1 end1 start2 end2)
736  "Given two strings, if the first string is not lexicographically equal
737  to the second string, returns the longest common prefix (using char=)
738  of the two strings. Otherwise, returns ()."
739  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
740    (if (eq result t) nil pos)))
741
742
743
744(provide 'chars)
Note: See TracBrowser for help on using the repository browser.