source: release/1.3/source/lib/chars.lisp @ 12879

Last change on this file since 12879 was 12879, checked in by rme, 10 years ago

Merge r12764 (refs bug 524)

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