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

Last change on this file since 11226 was 11226, checked in by gb, 11 years ago

Use the new (bitmap) scheme to determine the ALPHA part of ALPHANUMERICP.

Use the newer (year-old ...) scheme to determine UPPER-CASE-P, LOWER-CASE-P.

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