source: release/1.9/source/lib/chars.lisp @ 15888

Last change on this file since 15888 was 15888, checked in by rme, 6 years ago

Merge string-equal fix from trunk (see ticket:1103).

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