1 /* xlstr - xlisp string and character built-in functions */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 /* CHANGE LOG
7 * --------------------------------------------------------------------
8 * 28Apr03 dm eliminate some compiler warnings
9 */
10
11 #include "string.h"
12 #include "xlisp.h"
13
14 /* local definitions */
15 #define fix(n) cvfixnum((FIXTYPE)(n))
16 #define TLEFT 1
17 #define TRIGHT 2
18
19 /* external variables */
20 extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
21 extern LVAL s_true;
22 extern char buf[];
23
24 /* forward declarations */
25 FORWARD LOCAL LVAL strcompare(int fcn, int icase);
26 FORWARD LOCAL LVAL chrcompare(int fcn, int icase);
27 FORWARD LOCAL LVAL changecase(int fcn, int destructive);
28 FORWARD LOCAL LVAL trim(int fcn);
29 FORWARD LOCAL void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend);
30 FORWARD LOCAL int inbag(int ch, LVAL bag);
31
32 /* string comparision functions */
xstrlss(void)33 LVAL xstrlss(void) { return (strcompare('<',FALSE)); } /* string< */
xstrleq(void)34 LVAL xstrleq(void) { return (strcompare('L',FALSE)); } /* string<= */
xstreql(void)35 LVAL xstreql(void) { return (strcompare('=',FALSE)); } /* string= */
xstrneq(void)36 LVAL xstrneq(void) { return (strcompare('#',FALSE)); } /* string/= */
xstrgeq(void)37 LVAL xstrgeq(void) { return (strcompare('G',FALSE)); } /* string>= */
xstrgtr(void)38 LVAL xstrgtr(void) { return (strcompare('>',FALSE)); } /* string> */
39
40 /* string comparison functions (not case sensitive) */
xstrilss(void)41 LVAL xstrilss(void) { return (strcompare('<',TRUE)); } /* string-lessp */
xstrileq(void)42 LVAL xstrileq(void) { return (strcompare('L',TRUE)); } /* string-not-greaterp */
xstrieql(void)43 LVAL xstrieql(void) { return (strcompare('=',TRUE)); } /* string-equal */
xstrineq(void)44 LVAL xstrineq(void) { return (strcompare('#',TRUE)); } /* string-not-equal */
xstrigeq(void)45 LVAL xstrigeq(void) { return (strcompare('G',TRUE)); } /* string-not-lessp */
xstrigtr(void)46 LVAL xstrigtr(void) { return (strcompare('>',TRUE)); } /* string-greaterp */
47
48 /* strcompare - compare strings */
strcompare(int fcn,int icase)49 LOCAL LVAL strcompare(int fcn, int icase)
50 {
51 int start1,end1,start2,end2,ch1,ch2;
52 unsigned char *p1,*p2;
53 LVAL str1,str2;
54
55 /* get the strings */
56 str1 = xlgastring();
57 str2 = xlgastring();
58
59 /* get the substring specifiers */
60 getbounds(str1,k_1start,k_1end,&start1,&end1);
61 getbounds(str2,k_2start,k_2end,&start2,&end2);
62
63 /* setup the string pointers */
64 p1 = &getstring(str1)[start1];
65 p2 = &getstring(str2)[start2];
66
67 /* compare the strings */
68 for (; start1 < end1 && start2 < end2; ++start1,++start2) {
69 ch1 = *p1++;
70 ch2 = *p2++;
71 if (icase) {
72 if (isupper(ch1)) ch1 = tolower(ch1);
73 if (isupper(ch2)) ch2 = tolower(ch2);
74 }
75 if (ch1 != ch2)
76 switch (fcn) {
77 case '<': return (ch1 < ch2 ? fix(start1) : NIL);
78 case 'L': return (ch1 <= ch2 ? fix(start1) : NIL);
79 case '=': return (NIL);
80 case '#': return (fix(start1));
81 case 'G': return (ch1 >= ch2 ? fix(start1) : NIL);
82 case '>': return (ch1 > ch2 ? fix(start1) : NIL);
83 }
84 }
85
86 /* check the termination condition */
87 switch (fcn) {
88 case '<': return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
89 case 'L': return (start1 >= end1 ? fix(start1) : NIL);
90 case '=': return (start1 >= end1 && start2 >= end2 ? s_true : NIL);
91 case '#': return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
92 case 'G': return (start2 >= end2 ? fix(start1) : NIL);
93 case '>': return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
94 }
95
96 return NIL; /* Normally shouldn't happen */
97 }
98
99 /* case conversion functions */
xupcase(void)100 LVAL xupcase(void) { return (changecase('U',FALSE)); }
xdowncase(void)101 LVAL xdowncase(void) { return (changecase('D',FALSE)); }
102
103 /* destructive case conversion functions */
xnupcase(void)104 LVAL xnupcase(void) { return (changecase('U',TRUE)); }
xndowncase(void)105 LVAL xndowncase(void) { return (changecase('D',TRUE)); }
106
107 /* changecase - change case */
changecase(int fcn,int destructive)108 LOCAL LVAL changecase(int fcn, int destructive)
109 {
110 unsigned char *srcp,*dstp;
111 int start,end,len,ch,i;
112 LVAL src,dst;
113
114 /* get the string */
115 src = xlgastring();
116
117 /* get the substring specifiers */
118 getbounds(src,k_start,k_end,&start,&end);
119 len = getslength(src) - 1;
120
121 /* make a destination string */
122 dst = (destructive ? src : new_string(len+1));
123
124 /* setup the string pointers */
125 srcp = getstring(src);
126 dstp = getstring(dst);
127
128 /* copy the source to the destination */
129 for (i = 0; i < len; ++i) {
130 ch = *srcp++;
131 if (i >= start && i < end)
132 switch (fcn) {
133 case 'U': if (islower(ch)) ch = toupper(ch); break;
134 case 'D': if (isupper(ch)) ch = tolower(ch); break;
135 }
136 *dstp++ = ch;
137 }
138 *dstp = '\0';
139
140 /* return the new string */
141 return (dst);
142 }
143
144 /* search for string within a string */
xstrsearch(void)145 LVAL xstrsearch(void)
146 {
147 int start,end,pat_len,str_len;
148 unsigned char *pat,*str,*patptr,*strptr,*patend;
149 LVAL str1,str2;
150
151 /* get the strings */
152 str1 = xlgastring(); /* the pat */
153 str2 = xlgastring(); /* the string */
154
155 /* get the substring specifiers */
156 getbounds(str2, k_start, k_end, &start, &end);
157
158 /* setup the string pointers */
159 pat = getstring(str1);
160 str = &getstring(str2)[start];
161
162 pat_len = getslength(str1) - 1;
163 str_len = end - start;
164 patend = pat + pat_len;
165 for (; pat_len <= str_len; str_len--) {
166 patptr = pat;
167 strptr = str;
168 /* two outcomes: (1) no match, goto step (2) match, return */
169 while (patptr < patend) {
170 if (*patptr++ != *strptr++) goto step;
171 }
172 /* compute match index */
173 return cvfixnum(str - getstring(str2));
174 step:
175 str++;
176 }
177 /* no match */
178 return NIL;
179 }
180
181
182 /* trim functions */
xtrim(void)183 LVAL xtrim(void) { return (trim(TLEFT|TRIGHT)); }
xlefttrim(void)184 LVAL xlefttrim(void) { return (trim(TLEFT)); }
xrighttrim(void)185 LVAL xrighttrim(void) { return (trim(TRIGHT)); }
186
187 /* trim - trim character from a string */
trim(int fcn)188 LOCAL LVAL trim(int fcn)
189 {
190 unsigned char *leftp,*rightp,*dstp;
191 LVAL bag,src,dst;
192
193 /* get the bag and the string */
194 bag = xlgastring();
195 src = xlgastring();
196 xllastarg();
197
198 /* setup the string pointers */
199 leftp = getstring(src);
200 rightp = leftp + getslength(src) - 2;
201
202 /* trim leading characters */
203 if (fcn & TLEFT)
204 while (leftp <= rightp && inbag(*leftp,bag))
205 ++leftp;
206
207 /* trim character from the right */
208 if (fcn & TRIGHT)
209 while (rightp >= leftp && inbag(*rightp,bag))
210 --rightp;
211
212 /* make a destination string and setup the pointer */
213 dst = new_string((int)(rightp-leftp+2));
214 dstp = getstring(dst);
215
216 /* copy the source to the destination */
217 while (leftp <= rightp)
218 *dstp++ = *leftp++;
219 *dstp = '\0';
220
221 /* return the new string */
222 return (dst);
223 }
224
225 /* getbounds - get the start and end bounds of a string */
getbounds(LVAL str,LVAL skey,LVAL ekey,int * pstart,int * pend)226 LOCAL void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend)
227 {
228 LVAL arg;
229 int len;
230
231 /* get the length of the string */
232 len = getslength(str) - 1;
233
234 /* get the starting index */
235 if (xlgkfixnum(skey,&arg)) {
236 *pstart = (int)getfixnum(arg);
237 if (*pstart < 0 || *pstart > len)
238 xlerror("string index out of bounds",arg);
239 }
240 else
241 *pstart = 0;
242
243 /* get the ending index */
244 if (xlgkfixnum(ekey,&arg)) {
245 *pend = (int)getfixnum(arg);
246 if (*pend < 0 || *pend > len)
247 xlerror("string index out of bounds",arg);
248 }
249 else
250 *pend = len;
251
252 /* make sure the start is less than or equal to the end */
253 if (*pstart > *pend)
254 xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
255 }
256
257 /* inbag - test if a character is in a bag */
inbag(int ch,LVAL bag)258 LOCAL int inbag(int ch, LVAL bag)
259 {
260 unsigned char *p;
261 for (p = getstring(bag); *p != '\0'; ++p)
262 if (*p == ch)
263 return (TRUE);
264 return (FALSE);
265 }
266
267 /* xstrcat - concatenate a bunch of strings */
xstrcat(void)268 LVAL xstrcat(void)
269 {
270 LVAL *saveargv,tmp,val;
271 unsigned char *str;
272 int saveargc,len;
273
274 /* save the argument list */
275 saveargv = xlargv;
276 saveargc = xlargc;
277
278 /* find the length of the new string */
279 for (len = 0; moreargs(); ) {
280 tmp = xlgastring();
281 len += (int)getslength(tmp) - 1;
282 }
283
284 /* create the result string */
285 val = new_string(len+1);
286 str = getstring(val);
287
288 /* restore the argument list */
289 xlargv = saveargv;
290 xlargc = saveargc;
291
292 /* combine the strings */
293 for (*str = '\0'; moreargs(); ) {
294 tmp = nextarg();
295 strcat((char *) str, (char *) getstring(tmp));
296 }
297
298 /* return the new string */
299 return (val);
300 }
301
302 /* xsubseq - return a subsequence */
xsubseq(void)303 LVAL xsubseq(void)
304 {
305 unsigned char *srcp,*dstp;
306 int start,end,len;
307 LVAL src,dst;
308
309 /* get string and starting and ending positions */
310 src = xlgastring();
311
312 /* get the starting position */
313 dst = xlgafixnum(); start = (int)getfixnum(dst);
314 if (start < 0 || start > getslength(src) - 1)
315 xlerror("string index out of bounds",dst);
316
317 /* get the ending position */
318 if (moreargs()) {
319 dst = xlgafixnum(); end = (int)getfixnum(dst);
320 if (end < 0 || end > getslength(src) - 1)
321 xlerror("string index out of bounds",dst);
322 }
323 else
324 end = getslength(src) - 1;
325 xllastarg();
326
327 /* setup the source pointer */
328 srcp = getstring(src) + start;
329 len = end - start;
330
331 /* make a destination string and setup the pointer */
332 dst = new_string(len+1);
333 dstp = getstring(dst);
334
335 /* copy the source to the destination */
336 while (--len >= 0)
337 *dstp++ = *srcp++;
338 *dstp = '\0';
339
340 /* return the substring */
341 return (dst);
342 }
343
344 /* xstring - return a string consisting of a single character */
xstring(void)345 LVAL xstring(void)
346 {
347 LVAL arg;
348
349 /* get the argument */
350 arg = xlgetarg();
351 xllastarg();
352
353 /* make sure its not NIL */
354 if (null(arg))
355 xlbadtype(arg);
356
357 /* check the argument type */
358 switch (ntype(arg)) {
359 case STRING:
360 return (arg);
361 case SYMBOL:
362 return (getpname(arg));
363 case CHAR:
364 buf[0] = (int)getchcode(arg);
365 buf[1] = '\0';
366 return (cvstring(buf));
367 case FIXNUM:
368 buf[0] = (char)getfixnum(arg);
369 buf[1] = '\0';
370 return (cvstring(buf));
371 default:
372 xlbadtype(arg);
373 return NIL; /* never happens */
374 }
375 }
376
377 /* xchar - extract a character from a string */
xchar(void)378 LVAL xchar(void)
379 {
380 LVAL str,num;
381 int n;
382
383 /* get the string and the index */
384 str = xlgastring();
385 num = xlgafixnum();
386 xllastarg();
387
388 /* range check the index */
389 if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
390 xlerror("index out of range",num);
391
392 /* return the character */
393 return (cvchar(getstring(str)[n]));
394 }
395
396 /* xcharint - convert an integer to a character */
xcharint(void)397 LVAL xcharint(void)
398 {
399 LVAL arg;
400 arg = xlgachar();
401 xllastarg();
402 return (cvfixnum((FIXTYPE)getchcode(arg)));
403 }
404
405 /* xintchar - convert a character to an integer */
xintchar(void)406 LVAL xintchar(void)
407 {
408 LVAL arg;
409 arg = xlgafixnum();
410 xllastarg();
411 return (cvchar((int)getfixnum(arg)));
412 }
413
414 /* xuppercasep - built-in function 'upper-case-p' */
xuppercasep(void)415 LVAL xuppercasep(void)
416 {
417 int ch;
418 ch = getchcode(xlgachar());
419 xllastarg();
420 return (isupper(ch) ? s_true : NIL);
421 }
422
423 /* xlowercasep - built-in function 'lower-case-p' */
xlowercasep(void)424 LVAL xlowercasep(void)
425 {
426 int ch;
427 ch = getchcode(xlgachar());
428 xllastarg();
429 return (islower(ch) ? s_true : NIL);
430 }
431
432 /* xbothcasep - built-in function 'both-case-p' */
xbothcasep(void)433 LVAL xbothcasep(void)
434 {
435 int ch;
436 ch = getchcode(xlgachar());
437 xllastarg();
438 return (isupper(ch) || islower(ch) ? s_true : NIL);
439 }
440
441 /* xdigitp - built-in function 'digit-char-p' */
xdigitp(void)442 LVAL xdigitp(void)
443 {
444 int ch;
445 ch = getchcode(xlgachar());
446 xllastarg();
447 return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
448 }
449
450 /* xcharcode - built-in function 'char-code' */
xcharcode(void)451 LVAL xcharcode(void)
452 {
453 int ch;
454 ch = getchcode(xlgachar());
455 xllastarg();
456 return (cvfixnum((FIXTYPE)ch));
457 }
458
459 /* xcodechar - built-in function 'code-char' */
xcodechar(void)460 LVAL xcodechar(void)
461 {
462 LVAL arg;
463 int ch;
464 arg = xlgafixnum(); ch = (int) getfixnum(arg);
465 xllastarg();
466 return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
467 }
468
469 /* xchupcase - built-in function 'char-upcase' */
xchupcase(void)470 LVAL xchupcase(void)
471 {
472 LVAL arg;
473 int ch;
474 arg = xlgachar(); ch = getchcode(arg);
475 xllastarg();
476 return (islower(ch) ? cvchar(toupper(ch)) : arg);
477 }
478
479 /* xchdowncase - built-in function 'char-downcase' */
xchdowncase(void)480 LVAL xchdowncase(void)
481 {
482 LVAL arg;
483 int ch;
484 arg = xlgachar(); ch = getchcode(arg);
485 xllastarg();
486 return (isupper(ch) ? cvchar(tolower(ch)) : arg);
487 }
488
489 /* xdigitchar - built-in function 'digit-char' */
xdigitchar(void)490 LVAL xdigitchar(void)
491 {
492 LVAL arg;
493 int n;
494 arg = xlgafixnum(); n = (int) getfixnum(arg);
495 xllastarg();
496 return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
497 }
498
499 /* xalphanumericp - built-in function 'alphanumericp' */
xalphanumericp(void)500 LVAL xalphanumericp(void)
501 {
502 int ch;
503 ch = getchcode(xlgachar());
504 xllastarg();
505 return (isupper(ch) || islower(ch) || isdigit(ch) ? s_true : NIL);
506 }
507
508 /* character comparision functions */
xchrlss(void)509 LVAL xchrlss(void) { return (chrcompare('<',FALSE)); } /* char< */
xchrleq(void)510 LVAL xchrleq(void) { return (chrcompare('L',FALSE)); } /* char<= */
xchreql(void)511 LVAL xchreql(void) { return (chrcompare('=',FALSE)); } /* char= */
xchrneq(void)512 LVAL xchrneq(void) { return (chrcompare('#',FALSE)); } /* char/= */
xchrgeq(void)513 LVAL xchrgeq(void) { return (chrcompare('G',FALSE)); } /* char>= */
xchrgtr(void)514 LVAL xchrgtr(void) { return (chrcompare('>',FALSE)); } /* char> */
515
516 /* character comparision functions (case insensitive) */
xchrilss(void)517 LVAL xchrilss(void) { return (chrcompare('<',TRUE)); } /* char-lessp */
xchrileq(void)518 LVAL xchrileq(void) { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
xchrieql(void)519 LVAL xchrieql(void) { return (chrcompare('=',TRUE)); } /* char-equal */
xchrineq(void)520 LVAL xchrineq(void) { return (chrcompare('#',TRUE)); } /* char-not-equal */
xchrigeq(void)521 LVAL xchrigeq(void) { return (chrcompare('G',TRUE)); } /* char-not-lessp */
xchrigtr(void)522 LVAL xchrigtr(void) { return (chrcompare('>',TRUE)); } /* char-greaterp */
523
524 /* chrcompare - compare characters */
chrcompare(int fcn,int icase)525 LOCAL LVAL chrcompare(int fcn, int icase)
526 {
527 int ch1,ch2,icmp;
528 LVAL arg;
529
530 /* get the characters */
531 arg = xlgachar(); ch1 = getchcode(arg);
532
533 /* convert to lowercase if case insensitive */
534 if (icase && isupper(ch1))
535 ch1 = tolower(ch1);
536
537 /* handle each remaining argument */
538 for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
539
540 /* get the next argument */
541 arg = xlgachar(); ch2 = getchcode(arg);
542
543 /* convert to lowercase if case insensitive */
544 if (icase && isupper(ch2))
545 ch2 = tolower(ch2);
546
547 /* compare the characters */
548 switch (fcn) {
549 case '<': icmp = (ch1 < ch2); break;
550 case 'L': icmp = (ch1 <= ch2); break;
551 case '=': icmp = (ch1 == ch2); break;
552 case '#': icmp = (ch1 != ch2); break;
553 case 'G': icmp = (ch1 >= ch2); break;
554 case '>': icmp = (ch1 > ch2); break;
555 }
556 }
557
558 /* return the result */
559 return (icmp ? s_true : NIL);
560 }
561
562