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

Contents of /src/code/string.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5