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

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

ticket:524 : CHARACTER signals a TYPE-ERROR if its argument isn't a
character designator. Integers aren't character designators and never
have been (at least in ANSI CL.)

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