/[cmucl]/src/code/string.lisp
ViewVC logotype

Contents of /src/code/string.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Tue Feb 6 17:27:06 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; Functions to implement strings for Spice Lisp
11 ;;; Written by David Dill
12 ;;; Rewritten and currently maintained by Skef Wholey
13 ;;;
14 ;;; Runs in the standard Spice Lisp environment.
15 ;;;
16 ;;; ****************************************************************
17 ;;;
18 (in-package 'lisp)
19 (export '(char schar string
20 string= string-equal string< string> string<= string>= string/=
21 string-lessp string-greaterp string-not-lessp string-not-greaterp
22 string-not-equal
23 make-string
24 string-trim string-left-trim string-right-trim
25 string-upcase
26 string-downcase string-capitalize nstring-upcase nstring-downcase
27 nstring-capitalize))
28
29 (eval-when (compile)
30
31 ;;; %String returns its arg if it is a string, otherwise calls String.
32 ;;;
33 (defmacro %string (thing)
34 `(if (stringp ,thing) ,thing (string ,thing)))
35 )
36
37 (defun string (X)
38 "Coerces X into a string. If X is a string, X is returned. If X is a
39 symbol, X's pname is returned. If X is a character then a one element
40 string containing that character is returned. If X cannot be coerced
41 into a string, an error occurs."
42 (cond ((stringp x) x)
43 ((symbolp x) (symbol-name x))
44 ((characterp x)
45 (let ((res (make-string 1)))
46 (setf (schar res 0) x) res))
47 (t
48 (error "~S cannot be coerced to a string." x))))
49
50
51 ;;; With-One-String is used to set up some string hacking things. The keywords
52 ;;; are parsed, and the string is hacked into a simple-string.
53
54 (eval-when (compile)
55
56 (defmacro with-one-string (string start end cum-offset &rest forms)
57 (let ((data (gensym))
58 (data-start (gensym))
59 (data-end (gensym))
60 (offset (gensym)))
61 `(progn
62 (if (symbolp ,string) (setq ,string (symbol-name ,string)))
63 (if (array-header-p ,string)
64 (with-array-data ((,data ,string :offset-var ,offset)
65 (,data-start ,start)
66 (,data-end (or ,end
67 (%primitive header-ref ,string
68 %array-fill-pointer-slot))))
69 (psetq ,string ,data
70 ,cum-offset ,offset
71 ,start ,data-start
72 ,end ,data-end))
73 (if (not ,end) (setq ,end (length (the simple-string ,string)))))
74 ,@forms)))
75
76 )
77
78 ;;; With-String is like With-One-String, but doesn't parse keywords.
79
80 (eval-when (compile)
81
82 (defmacro with-string (string &rest forms)
83 `(let ((start 0)
84 (end ()))
85 (if (symbolp ,string) (setq ,string (symbol-name ,string)))
86 (if (array-header-p ,string)
87 (with-array-data ((data ,string)
88 (data-start start)
89 (data-end (%primitive header-ref ,string
90 %array-fill-pointer-slot)))
91 (psetq ,string data
92 start data-start
93 end data-end))
94 (setq end (length (the simple-string ,string))))
95 ,@forms))
96
97 )
98
99 ;;; With-Two-Strings is used to set up string comparison operations. The
100 ;;; keywords are parsed, and the strings are hacked into simple-strings.
101
102 (eval-when (compile)
103
104 (defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
105 start2 end2 &rest forms)
106 (let ((data (gensym))
107 (data-start (gensym))
108 (data-end (gensym))
109 (offset (gensym)))
110 `(progn
111 (if (symbolp ,string1) (setq ,string1 (symbol-name ,string1)))
112 (if (symbolp ,string2) (setq ,string2 (symbol-name ,string2)))
113 (if (array-header-p ,string1)
114 (with-array-data ((,data ,string1 :offset-var ,offset)
115 (,data-start ,start1)
116 (,data-end (or ,end1
117 (%primitive header-ref ,string1
118 %array-fill-pointer-slot))))
119 (psetq ,string1 ,data
120 ,cum-offset-1 ,offset
121 ,start1 ,data-start
122 ,end1 ,data-end))
123 (if (not ,end1) (setq ,end1 (length (the simple-string ,string1)))))
124 (if (array-header-p ,string2)
125 (with-array-data ((,data ,string2)
126 (,data-start ,start2)
127 (,data-end (or ,end2
128 (%primitive header-ref ,string2
129 %array-fill-pointer-slot))))
130 (psetq ,string2 ,data
131 ,start2 ,data-start
132 ,end2 ,data-end))
133 (if (not ,end2) (setq ,end2 (length (the simple-string ,string2)))))
134 ,@forms)))
135
136 )
137
138 (defun char (string index)
139 "Given a string and a non-negative integer index less than the length of
140 the string, returns the character object representing the character at
141 that position in the string."
142 (char string index))
143
144 (defun %charset (string index new-el)
145 (setf (char string index) new-el))
146
147 (defun schar (string index)
148 "SCHAR returns the character object at an indexed position in a string
149 just as CHAR does, except the string must be a simple-string."
150 (schar string index))
151
152 (defun %scharset (string index new-el)
153 (setf (schar string index) new-el))
154
155 (defun string=* (string1 string2 start1 end1 start2 end2)
156 (let ((offset1 0))
157 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
158 (not (%sp-string-compare string1 start1 end1 string2 start2 end2)))))
159
160
161 (defun string/=* (string1 string2 start1 end1 start2 end2)
162 (let ((offset1 0))
163 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
164 (let ((comparison (%sp-string-compare string1 start1 end1
165 string2 start2 end2)))
166 (if comparison (- (the fixnum comparison) offset1))))))
167
168 (eval-when (compile eval)
169
170 ;;; Lessp is true if the desired expansion is for string<* or string<=*.
171 ;;; Equalp is true if the desired expansion is for string<=* or string>=*.
172 (defmacro string<>=*-body (lessp equalp)
173 (let ((offset1 (gensym)))
174 `(let ((,offset1 0))
175 (declare (fixnum ,offset1))
176 (with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
177 (let ((index (%sp-string-compare string1 start1 end1
178 string2 start2 end2)))
179 (if index
180 (cond ((= (the fixnum index)
181 ,(if lessp `(the fixnum end1) `(the fixnum end2)))
182 (- (the fixnum index) ,offset1))
183 ((= (the fixnum index)
184 ,(if lessp `(the fixnum end2) `(the fixnum end1)))
185 nil)
186 ((,(if lessp 'char< 'char>)
187 (schar string1 index)
188 (schar string2 (+ (the fixnum index) (- start2 start1))))
189 (- (the fixnum index) ,offset1))
190 (t nil))
191 ,(if equalp `(- (the fixnum end1) ,offset1) 'nil)))))))
192 ) ; eval-when
193
194 (defun string<* (string1 string2 start1 end1 start2 end2)
195 (declare (fixnum start1 start2))
196 (string<>=*-body t nil))
197
198 (defun string>* (string1 string2 start1 end1 start2 end2)
199 (declare (fixnum start1 start2))
200 (string<>=*-body nil nil))
201
202 (defun string<=* (string1 string2 start1 end1 start2 end2)
203 (declare (fixnum start1 start2))
204 (string<>=*-body t t))
205
206 (defun string>=* (string1 string2 start1 end1 start2 end2)
207 (declare (fixnum start1 start2))
208 (string<>=*-body nil t))
209
210
211
212 (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
213 "Given two strings, if the first string is lexicographically less than
214 the second string, returns the longest common prefix (using char=)
215 of the two strings. Otherwise, returns ()."
216 (string<* string1 string2 start1 end1 start2 end2))
217
218 (defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
219 "Given two strings, if the first string is lexicographically greater than
220 the second string, returns the longest common prefix (using char=)
221 of the two strings. Otherwise, returns ()."
222 (string>* string1 string2 start1 end1 start2 end2))
223
224
225 (defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
226 "Given two strings, if the first string is lexicographically less than
227 or equal to the second string, returns the longest common prefix
228 (using char=) of the two strings. Otherwise, returns ()."
229 (string<=* string1 string2 start1 end1 start2 end2))
230
231 (defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
232 "Given two strings, if the first string is lexicographically greater
233 than or equal to the second string, returns the longest common prefix
234 (using char=) of the two strings. Otherwise, returns ()."
235 (string>=* string1 string2 start1 end1 start2 end2))
236
237 (defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
238 "Given two strings (string1 and string2), and optional integers start1,
239 start2, end1 and end2, compares characters in string1 to characters in
240 string2 (using char=)."
241 (string=* string1 string2 start1 end1 start2 end2))
242
243 (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
244 "Given two strings, if the first string is not lexicographically equal
245 to the second string, returns the longest common prefix (using char=)
246 of the two strings. Otherwise, returns ()."
247 (string/=* string1 string2 start1 end1 start2 end2))
248
249
250 (eval-when (compile eval)
251
252 ;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
253 ;;; STRING-EQUAL and STRING-NOT-EQUAL.
254 (defmacro string-not-equal-loop (end end-value
255 &optional (abort-value nil abortp))
256 (declare (fixnum end))
257 (let ((end-test (if (= end 1)
258 `(= index1 (the fixnum end1))
259 `(= index2 (the fixnum end2)))))
260 `(do ((index1 start1 (1+ index1))
261 (index2 start2 (1+ index2)))
262 (,(if abortp
263 end-test
264 `(or ,end-test
265 (not (char-equal (schar string1 index1)
266 (schar string2 index2)))))
267 ,end-value)
268 (declare (fixnum index1 index2))
269 ,@(if abortp
270 `((if (not (char-equal (schar string1 index1)
271 (schar string2 index2)))
272 (return ,abort-value)))))))
273
274 ) ; eval-when
275
276 (defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
277 "Given two strings (string1 and string2), and optional integers start1,
278 start2, end1 and end2, compares characters in string1 to characters in
279 string2 (using char-equal)."
280 (declare (fixnum start1 start2))
281 (let ((offset1 0))
282 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
283 (let ((slen1 (- (the fixnum end1) start1))
284 (slen2 (- (the fixnum end2) start2)))
285 (declare (fixnum slen1 slen2))
286 (if (or (minusp slen1) (minusp slen2))
287 ;;prevent endless looping later.
288 (error "Improper bounds for string comparison."))
289 (if (= slen1 slen2)
290 ;;return () immediately if lengths aren't equal.
291 (string-not-equal-loop 1 t nil))))))
292
293 (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
294 "Given two strings, if the first string is not lexicographically equal
295 to the second string, returns the longest common prefix (using char-equal)
296 of the two strings. Otherwise, returns ()."
297 (let ((offset1 0))
298 (declare (fixnum offset1))
299 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
300 (let ((slen1 (- end1 start1))
301 (slen2 (- end2 start2)))
302 (declare (fixnum slen1 slen2))
303 (if (or (minusp slen1) (minusp slen2))
304 ;;prevent endless looping later.
305 (error "Improper bounds for string comparison."))
306 (cond ((or (minusp slen1) (or (minusp slen2)))
307 (error "Improper substring for comparison."))
308 ((= slen1 slen2)
309 (string-not-equal-loop 1 nil (- index1 offset1)))
310 ((< slen1 slen2)
311 (string-not-equal-loop 1 (- index1 offset1)))
312 (t
313 (string-not-equal-loop 2 (- index1 offset1))))))))
314
315
316
317 (eval-when (compile eval)
318
319 ;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
320 ;;; and string2 and a test on the current characters from string1 and string2
321 ;;; for the following macro.
322 (defun string-less-greater-equal-tests (lessp equalp)
323 (if lessp
324 (if equalp
325 ;; STRING-NOT-GREATERP
326 (values '<= `(not (char-greaterp char1 char2)))
327 ;; STRING-LESSP
328 (values '< `(char-lessp char1 char2)))
329 (if equalp
330 ;; STRING-NOT-LESSP
331 (values '>= `(not (char-lessp char1 char2)))
332 ;; STRING-GREATERP
333 (values '> `(char-greaterp char1 char2)))))
334
335 (defmacro string-less-greater-equal (lessp equalp)
336 (multiple-value-bind (length-test character-test)
337 (string-less-greater-equal-tests lessp equalp)
338 `(let ((offset1 0))
339 (declare (fixnum offset1))
340 (with-two-strings string1 string2 start1 end1 offset1 start2 end2
341 (let ((slen1 (- (the fixnum end1) start1))
342 (slen2 (- (the fixnum end2) start2)))
343 (declare (fixnum slen1 slen2))
344 (if (or (minusp slen1) (minusp slen2))
345 ;;prevent endless looping later.
346 (error "Improper bounds for string comparison."))
347 (do ((index1 start1 (1+ index1))
348 (index2 start2 (1+ index2))
349 (char1)
350 (char2))
351 ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
352 (if (,length-test slen1 slen2) (- index1 offset1)))
353 (declare (fixnum index1 index2))
354 (setq char1 (schar string1 index1))
355 (setq char2 (schar string2 index2))
356 (if (not (char-equal char1 char2))
357 (if ,character-test
358 (return (- index1 offset1))
359 (return ())))))))))
360
361 ) ; eval-when
362
363 (defun string-lessp* (string1 string2 start1 end1 start2 end2)
364 (declare (fixnum start1 start2))
365 (string-less-greater-equal t nil))
366
367 (defun string-greaterp* (string1 string2 start1 end1 start2 end2)
368 (declare (fixnum start1 start2))
369 (string-less-greater-equal nil nil))
370
371 (defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
372 (declare (fixnum start1 start2))
373 (string-less-greater-equal nil t))
374
375 (defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
376 (declare (fixnum start1 start2))
377 (string-less-greater-equal t t))
378
379 (defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
380 "Given two strings, if the first string is lexicographically less than
381 the second string, returns the longest common prefix (using char-equal)
382 of the two strings. Otherwise, returns ()."
383 (string-lessp* string1 string2 start1 end1 start2 end2))
384
385 (defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
386 "Given two strings, if the first string is lexicographically greater than
387 the second string, returns the longest common prefix (using char-equal)
388 of the two strings. Otherwise, returns ()."
389 (string-greaterp* string1 string2 start1 end1 start2 end2))
390
391 (defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
392 "Given two strings, if the first string is lexicographically greater
393 than or equal to the second string, returns the longest common prefix
394 (using char-equal) of the two strings. Otherwise, returns ()."
395 (string-not-lessp* string1 string2 start1 end1 start2 end2))
396
397 (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
398 end2)
399 "Given two strings, if the first string is lexicographically less than
400 or equal to the second string, returns the longest common prefix
401 (using char-equal) of the two strings. Otherwise, returns ()."
402 (string-not-greaterp* string1 string2 start1 end1 start2 end2))
403
404
405 (defun make-string (count &key ((:initial-element fill-char)))
406 "Given a character count and an optional fill character, makes and returns
407 a new string Count long filled with the fill character."
408 (declare (fixnum count))
409 (if fill-char
410 (do ((i 0 (1+ i))
411 (string (make-string count)))
412 ((= i count) string)
413 (declare (fixnum i))
414 (setf (schar string i) fill-char))
415 (make-string count)))
416
417 (defun string-upcase (string &key (start 0) end)
418 "Given a string, returns a new string that is a copy of it with
419 all lower case alphabetic characters converted to uppercase."
420 (declare (fixnum start))
421 (if (symbolp string) (setq string (symbol-name string)))
422 (let ((slen (length string))
423 (offset 0))
424 (declare (fixnum slen offset))
425 (with-one-string string start end offset
426 (let ((offset-slen (+ slen offset))
427 (newstring (make-string slen)))
428 (declare (fixnum offset-slen))
429 (do ((index offset (1+ index))
430 (new-index 0 (1+ new-index)))
431 ((= index start))
432 (declare (fixnum index new-index))
433 (setf (schar newstring new-index) (schar string index)))
434 (do ((index start (1+ index))
435 (new-index (- start offset) (1+ new-index)))
436 ((= index (the fixnum end)))
437 (declare (fixnum index new-index))
438 (setf (schar newstring new-index)
439 (char-upcase (schar string index))))
440 (do ((index end (1+ index))
441 (new-index (- (the fixnum end) offset) (1+ new-index)))
442 ((= index offset-slen))
443 (declare (fixnum index new-index))
444 (setf (schar newstring new-index) (schar string index)))
445 newstring))))
446
447 (defun string-downcase (string &key (start 0) end)
448 "Given a string, returns a new string that is a copy of it with
449 all upper case alphabetic characters converted to lowercase."
450 (declare (fixnum start))
451 (if (symbolp string) (setq string (symbol-name string)))
452 (let ((slen (length string))
453 (offset 0))
454 (declare (fixnum slen offset))
455 (with-one-string string start end offset
456 (let ((offset-slen (+ slen offset))
457 (newstring (make-string slen)))
458 (declare (fixnum offset-slen))
459 (do ((index offset (1+ index))
460 (new-index 0 (1+ new-index)))
461 ((= index start))
462 (declare (fixnum index new-index))
463 (setf (schar newstring new-index) (schar string index)))
464 (do ((index start (1+ index))
465 (new-index (- start offset) (1+ new-index)))
466 ((= index (the fixnum end)))
467 (declare (fixnum index new-index))
468 (setf (schar newstring new-index)
469 (char-downcase (schar string index))))
470 (do ((index end (1+ index))
471 (new-index (- (the fixnum end) offset) (1+ new-index)))
472 ((= index offset-slen))
473 (declare (fixnum index new-index))
474 (setf (schar newstring new-index) (schar string index)))
475 newstring))))
476
477 (defun string-capitalize (string &key (start 0) end)
478 "Given a string, returns a copy of the string with the first
479 character of each ``word'' converted to upper-case, and remaining
480 chars in the word converted to lower case. A ``word'' is defined
481 to be a string of case-modifiable characters delimited by
482 non-case-modifiable chars."
483 (declare (fixnum start))
484 (if (symbolp string) (setq string (symbol-name string)))
485 (let ((slen (length string))
486 (offset 0))
487 (declare (fixnum slen offset))
488 (with-one-string string start end offset
489 (let ((offset-slen (+ slen offset))
490 (newstring (make-string slen)))
491 (declare (fixnum offset-slen))
492 (do ((index offset (1+ index))
493 (new-index 0 (1+ new-index)))
494 ((= index start))
495 (declare (fixnum index new-index))
496 (setf (schar newstring new-index) (schar string index)))
497 (do ((index start (1+ index))
498 (new-index (- start offset) (1+ new-index))
499 (newword t)
500 (char ()))
501 ((= index (the fixnum end)))
502 (declare (fixnum index new-index))
503 (setq char (schar string index))
504 (cond ((not (alphanumericp char))
505 (setq newword t))
506 (newword
507 ;;char is first case-modifiable after non-case-modifiable
508 (setq char (char-upcase char))
509 (setq newword ()))
510 ;;char is case-modifiable, but not first
511 (t (setq char (char-downcase char))))
512 (setf (schar newstring new-index) char))
513 (do ((index end (1+ index))
514 (new-index (- (the fixnum end) offset) (1+ new-index)))
515 ((= index offset-slen))
516 (declare (fixnum index new-index))
517 (setf (schar newstring new-index) (schar string index)))
518 newstring))))
519
520 (defun nstring-upcase (string &key (start 0) end)
521 "Given a string, returns that string with all lower case alphabetic
522 characters converted to uppercase."
523 (declare (fixnum start))
524 (let ((save-header string)
525 offset)
526 (with-one-string string start end offset
527 (do ((index start (1+ index)))
528 ((= index (the fixnum end)))
529 (declare (fixnum index))
530 (setf (schar string index) (char-upcase (schar string index)))))
531 save-header))
532
533 (defun nstring-downcase (string &key (start 0) end)
534 "Given a string, returns that string with all upper case alphabetic
535 characters converted to lowercase."
536 (declare (fixnum start))
537 (let ((save-header string)
538 offset)
539 (with-one-string string start end offset
540 (do ((index start (1+ index)))
541 ((= index (the fixnum end)))
542 (declare (fixnum index))
543 (setf (schar string index) (char-downcase (schar string index)))))
544 save-header)))
545
546 (defun nstring-capitalize (string &key (start 0) end)
547 "Given a string, returns that string with the first
548 character of each ``word'' converted to upper-case, and remaining
549 chars in the word converted to lower case. A ``word'' is defined
550 to be a string of case-modifiable characters delimited by
551 non-case-modifiable chars."
552 (declare (fixnum start))
553 (let ((save-header string)
554 offset)
555 (with-one-string string start end offset
556 (do ((index start (1+ index))
557 (newword t)
558 (char ()))
559 ((= index (the fixnum end)))
560 (declare (fixnum index))
561 (setq char (schar string index))
562 (cond ((not (alphanumericp char))
563 (setq newword t))
564 (newword
565 ;;char is first case-modifiable after non-case-modifiable
566 (setf (schar string index) (char-upcase char))
567 (setq newword ()))
568 (t
569 (setf (schar string index) (char-downcase char))))))
570 save-header))
571
572 (defun string-left-trim (char-bag string)
573 "Given a set of characters (a list or string) and a string, returns
574 a copy of the string with the characters in the set removed from the
575 left end."
576 (with-string string
577 (do ((index start (1+ index)))
578 ((or (= index (the fixnum end))
579 (not (find (schar string index) char-bag)))
580 (subseq (the simple-string string) index end))
581 (declare (fixnum index)))))
582
583 (defun string-right-trim (char-bag string)
584 "Given a set of characters (a list or string) and a string, returns
585 a copy of the string with the characters in the set removed from the
586 right end."
587 (with-string string
588 (do ((index (1- (the fixnum end)) (1- index)))
589 ((or (< index start) (not (find (schar string index) char-bag)))
590 (subseq (the simple-string string) start (1+ index)))
591 (declare (fixnum index)))))
592
593 (defun string-trim (char-bag string)
594 "Given a set of characters (a list or string) and a string, returns a
595 copy of the string with the characters in the set removed from both
596 ends."
597 (with-string string
598 (let* ((left-end (do ((index start (1+ index)))
599 ((or (= index (the fixnum end))
600 (not (find (schar string index) char-bag)))
601 index)
602 (declare (fixnum index))))
603 (right-end (do ((index (1- (the fixnum end)) (1- index)))
604 ((or (< index left-end)
605 (not (find (schar string index) char-bag)))
606 (1+ index))
607 (declare (fixnum index)))))
608 (subseq (the simple-string string) left-end right-end))))

  ViewVC Help
Powered by ViewVC 1.1.5