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

Contents of /src/code/string.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5