src/c/xlstr.c

   1 /* xlstr - xlisp string and character built-in functions */
   2 /* Copyright (c) 1989, by David Michael Betz.                            */
   3 /* You may give out copies of this software; for conditions see the file */
   4 /* COPYING included with this distribution.                              */
   5
   6 #include "xlisp.h"
   7
   8 /* local definitions */
   9 #define fix(n)  cvfixnum((FIXTYPE)(n))
  10 #define TLEFT   1
  11 #define TRIGHT  2
  12
  13 /* Function prototypes */
  14 LOCAL VOID getbounds P5H(LVAL, LVAL, LVAL, unsigned *, unsigned *);
  15 LOCAL LVAL strcompare P2H(int, int);
  16 LOCAL LVAL changecase P2H(int, int);
  17 LOCAL int inbag P2H(int, LVAL);
  18 LOCAL LVAL trim P1H(int);
  19 LOCAL LVAL chrcompare P2H(int, int);
  20
  21 /* getbounds - get the start and end bounds of a string */
  22 LOCAL VOID getbounds P5C(LVAL, str, LVAL, skey, LVAL, ekey,
  23                          unsigned *, pstart, unsigned *, pend)
  24 {
  25     LVAL arg;
  26     unsigned len;
  27     FIXTYPE n;
  28
  29     /* get the length of the string */
  30     len = getslength(str);
  31
  32     /* get the starting index */
  33     if (xlgkfixnum(skey,&arg)) {
  34         *pstart = (unsigned) (n = getfixnum(arg));
  35         if (n < 0 || n > (FIXTYPE)len)
  36             xlerror("string index out of bounds",arg);
  37     }
  38     else
  39         *pstart = 0;
  40
  41     /* get the ending index */
  42     if (xlgetkeyarg(ekey, &arg) && arg != NIL) {
  43         if (!fixp(arg)) xlbadtype(arg);
  44         *pend = (unsigned)(n = getfixnum(arg));
  45         if (n < 0 || n > (FIXTYPE)len)
  46             xlerror("string index out of bounds",arg);
  47     }
  48     else
  49         *pend = len;
  50
  51     /* make sure the start is less than or equal to the end */
  52     if (*pstart > *pend)
  53         xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
  54 }
  55
  56 /* strcompare - compare strings */
  57 LOCAL LVAL strcompare P2C(int, fcn, int, icase)
  58 {
  59     unsigned start1,end1,start2,end2;
  60     int ch1,ch2;
  61     unsigned char *p1, *p2;
  62     LVAL str1,str2;
  63
  64     /* get the strings */
  65     str1 = xlgastrorsym();
  66     str2 = xlgastrorsym();
  67
  68     /* get the substring specifiers */
  69     getbounds(str1,k_1start,k_1end,&start1,&end1);
  70     getbounds(str2,k_2start,k_2end,&start2,&end2);
  71
  72     xllastkey();
  73
  74     /* setup the string pointers */
  75     p1 = (unsigned char *) &getstring(str1)[start1];
  76     p2 = (unsigned char *) &getstring(str2)[start2];
  77
  78     /* compare the strings */
  79     for (; start1 < end1 && start2 < end2; ++start1,++start2) {
  80         ch1 = *p1++;
  81         ch2 = *p2++;
  82         if (icase) {
  83             if (ISUPPER(ch1)) ch1 = TOLOWER(ch1);
  84             if (ISUPPER(ch2)) ch2 = TOLOWER(ch2);
  85         }
  86         if (ch1 != ch2)
  87             switch (fcn) {
  88             case '<':   return (ch1 < ch2 ? fix(start1) : NIL);
  89             case 'L':   return (ch1 <= ch2 ? fix(start1) : NIL);
  90             case '=':   return (NIL);
  91             case '#':   return (fix(start1));
  92             case 'G':   return (ch1 >= ch2 ? fix(start1) : NIL);
  93             case '>':   return (ch1 > ch2 ? fix(start1) : NIL);
  94             }
  95     }
  96
  97     /* check the termination condition */
  98     switch (fcn) {
  99     case '<':   return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
 100     case 'L':   return (start1 >= end1 ? fix(start1) : NIL);
 101     case '=':   return (start1 >= end1 && start2 >= end2 ? s_true : NIL);
 102     case '#':   return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
 103     case 'G':   return (start2 >= end2 ? fix(start1) : NIL);
 104     case '>':   return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
 105     }
 106     return (NIL);   /* avoid compiler warning */
 107 }
 108
 109 /* string comparision functions */
 110 LVAL xstrlss(V) { return (strcompare('<',FALSE)); } /* string< */
 111 LVAL xstrleq(V) { return (strcompare('L',FALSE)); } /* string<= */
 112 LVAL xstreql(V) { return (strcompare('=',FALSE)); } /* string= */
 113 LVAL xstrneq(V) { return (strcompare('#',FALSE)); } /* string/= */
 114 LVAL xstrgeq(V) { return (strcompare('G',FALSE)); } /* string>= */
 115 LVAL xstrgtr(V) { return (strcompare('>',FALSE)); } /* string> */
 116
 117 /* string comparison functions (not case sensitive) */
 118 LVAL xstrilss(V) { return (strcompare('<',TRUE)); } /* string-lessp */
 119 LVAL xstrileq(V) { return (strcompare('L',TRUE)); } /* string-not-greaterp */
 120 LVAL xstrieql(V) { return (strcompare('=',TRUE)); } /* string-equal */
 121 LVAL xstrineq(V) { return (strcompare('#',TRUE)); } /* string-not-equal */
 122 LVAL xstrigeq(V) { return (strcompare('G',TRUE)); } /* string-not-lessp */
 123 LVAL xstrigtr(V) { return (strcompare('>',TRUE)); } /* string-greaterp */
 124
 125 /* changecase - change case */
 126 LOCAL LVAL changecase P2C(int, fcn, int, destructive)
 127 {
 128     char *srcp, *dstp;
 129     unsigned start,end,len,i;
 130     int ch;
 131     int lastspace = TRUE;
 132     LVAL src,dst;
 133
 134     /* get the string */
 135     src = (destructive? xlgastring() : xlgastrorsym());
 136
 137     /* get the substring specifiers */
 138     getbounds(src,k_start,k_end,&start,&end);
 139     len = getslength(src);
 140
 141     xllastkey();
 142
 143     /* make a destination string */
 144     dst = (destructive ? src : newstring(len));
 145
 146     /* setup the string pointers */
 147     srcp = getstring(src);
 148     dstp = getstring(dst);
 149
 150     /* copy the source to the destination */
 151     for (i = 0; i < len; ++i) {
 152         ch = *srcp++;
 153         if (i >= start && i < end)
 154             switch (fcn) {
 155             case 'U':   if (ISLOWER(ch)) ch = TOUPPER(ch); break;
 156             case 'D':   if (ISUPPER(ch)) ch = TOLOWER(ch); break;
 157             case 'C':   if (lastspace && ISLOWER(ch)) ch = TOUPPER(ch);
 158                         if (!lastspace && ISUPPER(ch)) ch = TOLOWER(ch);
 159                         lastspace = !ISLOWERA(ch) && !ISUPPER(ch);
 160                         break;
 161             }
 162         *dstp++ = (char) ch;
 163     }
 164     *dstp = '\0';
 165
 166     /* return the new string */
 167     return (dst);
 168 }
 169
 170 /* case conversion functions */
 171 LVAL xupcase(V)   { return (changecase('U',FALSE)); }
 172 LVAL xdowncase(V) { return (changecase('D',FALSE)); }
 173 LVAL xcapcase(V)  { return (changecase('C',FALSE)); }
 174
 175 /* destructive case conversion functions */
 176 LVAL xnupcase(V)   { return (changecase('U',TRUE)); }
 177 LVAL xndowncase(V) { return (changecase('D',TRUE)); }
 178 LVAL xncapcase(V)  { return (changecase('C',TRUE)); }
 179
 180 /* inbag - test if a character is in a bag */
 181 LOCAL int inbag P2C(int, ch, LVAL, bag)
 182 {
 183                                     /* TAA MOD -- rewritten for \0 */
 184                                     /*            and chars >= 128 */
 185     char *p = getstring(bag);
 186     unsigned len =getslength(bag);
 187
 188     while (len--)
 189         if (*p++ == ch)
 190             return (TRUE);
 191     return (FALSE);
 192 }
 193
 194 /* trim - trim character from a string */
 195 LOCAL LVAL trim P1C(int, fcn)
 196 {
 197     char *leftp, *rightp, *dstp;
 198     LVAL bag,src,dst;
 199
 200     /* get the bag and the string */
 201     bag = xlgaseq();
 202     src = xlgastrorsym();
 203     xllastarg();
 204
 205     xlprot1(bag);
 206     bag = coerce_to_tvec(bag, a_char);
 207
 208     /* setup the string pointers */
 209     leftp = getstring(src);
 210     rightp = leftp + getslength(src) - 1;
 211
 212     /* trim leading characters */
 213     if (fcn & TLEFT)
 214         while (leftp <= rightp && inbag(*leftp,bag))
 215             ++leftp;
 216
 217     /* trim character from the right */
 218     if (fcn & TRIGHT)
 219         while (rightp >= leftp && inbag(*rightp,bag))
 220             --rightp;
 221
 222     /* make a destination string and setup the pointer */
 223     dst = newstring(((unsigned)(rightp-leftp))+1);
 224     dstp = getstring(dst);
 225
 226     /* copy the source to the destination */
 227     while (leftp <= rightp)
 228         *dstp++ = *leftp++;
 229     *dstp = '\0';
 230
 231     xlpop();
 232
 233     /* return the new string */
 234     return (dst);
 235 }
 236
 237 /* trim functions */
 238 LVAL xtrim(V)      { return (trim(TLEFT|TRIGHT)); }
 239 LVAL xlefttrim(V)  { return (trim(TLEFT)); }
 240 LVAL xrighttrim(V) { return (trim(TRIGHT)); }
 241
 242
 243 /* xstring - return a string consisting of a single character */
 244 LVAL xstring(V)
 245 {
 246     LVAL arg,val;
 247
 248     /* get the argument */
 249     arg = xlgetarg();
 250     xllastarg();
 251
 252     /* check the argument type */
 253     switch (ntype(arg)) {
 254     case STRING:
 255         return (arg);
 256     case SYMBOL:
 257         return (getpname(arg));
 258     case CHAR:
 259         /* Changed 10/94 to allow string '\000' */
 260         val = newstring(1);
 261         val->n_string[0] = (char)getchcode(arg);
 262         val->n_string[1] = '\0';
 263         return (val);
 264     case FIXNUM:
 265         /* Changed 10/94 to allow string 0 */
 266         val = newstring(1);
 267         val->n_string[0] = (char)getfixnum(arg);
 268         val->n_string[1] = '\0';
 269         return (val);
 270     default:
 271         xlbadtype(arg);
 272         return (NIL);   /* avoid compiler warning */
 273     }
 274 }
 275
 276 /* xchar - extract a character from a string */
 277 LVAL xchar(V)
 278 {
 279     LVAL str,num;
 280     FIXTYPE n;
 281
 282     /* get the string and the index */
 283     str = xlgastring();
 284     num = xlgafixnum();
 285     xllastarg();
 286
 287     /* range check the index */
 288     if ((n = getfixnum(num)) < 0 || n >= (FIXTYPE)getslength(str))
 289         xlerror("index out of range",num);
 290
 291     /* return the character */
 292     return (cvchar(getstringch(str,(unsigned int)n)));
 293 }
 294
 295 /* xcharint - convert a character to an integer */
 296 LVAL xcharint(V)
 297 {
 298     LVAL arg;
 299     arg = xlgachar();
 300     xllastarg();
 301     return (cvfixnum((FIXTYPE)getchcode(arg)));
 302 }
 303
 304 /* xintchar - convert an integer to a character */
 305 LVAL xintchar(V)
 306 {
 307     LVAL arg;
 308     arg = xlgafixnum();
 309     xllastarg();
 310     return (cvchar((int)getfixnum(arg)));
 311 }
 312
 313 /* xcharcode - built-in function 'char-code' */
 314 /* TAA mod so that result is 7 bit ascii code */
 315 LVAL xcharcode(V)
 316 {
 317     int ch;
 318     ch = 0x7f  & getchcode(xlgachar());
 319     xllastarg();
 320     return (cvfixnum((FIXTYPE)ch));
 321 }
 322
 323 /* xcodechar - built-in function 'code-char' */
 324 /* like int-char except range must be 0-127 */
 325 LVAL xcodechar(V)
 326 {
 327     LVAL arg;
 328     FIXTYPE ch;
 329 #ifdef __SASC__
 330     FIXTYPE testch;
 331 #endif
 332
 333     arg = xlgafixnum(); ch = getfixnum(arg);
 334     xllastarg();
 335
 336 #ifdef __SASC__
 337     /* On MVS/CMS, convert EBCDIC character to ASCII for subsequent */
 338     /* test - Dave Rivers (rivers@ponds.uucp) */
 339     testch = etoa((unsigned char)ch);
 340     return (testch >= 0 && testch <= 127 ? cvchar((int)ch) : NIL);
 341 #else
 342     return (ch >= 0 && ch <= 127 ? cvchar((int)ch) : NIL);
 343 #endif
 344 }
 345
 346 /* xuppercasep - built-in function 'upper-case-p' */
 347 LVAL xuppercasep(V)
 348 {
 349     int ch;
 350     ch = getchcode(xlgachar());
 351     xllastarg();
 352     return (ISUPPER(ch) ? s_true : NIL);
 353 }
 354
 355 /* xlowercasep - built-in function 'lower-case-p' */
 356 LVAL xlowercasep(V)
 357 {
 358     int ch;
 359     ch = getchcode(xlgachar());
 360     xllastarg();
 361     return (ISLOWERA(ch) ? s_true : NIL);
 362 }
 363
 364 /* xbothcasep - built-in function 'both-case-p' */
 365 LVAL xbothcasep(V)
 366 {
 367     int ch;
 368     ch = getchcode(xlgachar());
 369     xllastarg();
 370     return (ISUPPER(ch) || ISLOWER(ch) ? s_true : NIL);
 371 }
 372
 373 /* xdigitp - built-in function 'digit-char-p' */
 374 LVAL xdigitp(V)
 375 {
 376     int ch;
 377     FIXTYPE radix = 10;
 378     ch = getchcode(xlgachar());
 379     if (moreargs()) {
 380         radix = getfixnum(xlgafixnum());
 381         if (radix < 1 || radix > 36) xlfail("radix out of range");
 382     }
 383     xllastarg();
 384
 385     if (isdigit(ch)) ch = ch - '0';
 386     else if (ISUPPER(ch)) ch = ch - 'A' + 10;
 387     else if (ISLOWER(ch)) ch = ch - 'a' + 10;
 388     else return NIL;
 389
 390     return (ch < radix ? cvfixnum((FIXTYPE) ch) : NIL);
 391 }
 392
 393 /* xchupcase - built-in function 'char-upcase' */
 394 LVAL xchupcase(V)
 395 {
 396     LVAL arg;
 397     int ch;
 398     arg = xlgachar(); ch = getchcode(arg);
 399     xllastarg();
 400     return (ISLOWER(ch) ? cvchar(TOUPPER(ch)) : arg);
 401 }
 402
 403 /* xchdowncase - built-in function 'char-downcase' */
 404 LVAL xchdowncase(V)
 405 {
 406     LVAL arg;
 407     int ch;
 408     arg = xlgachar(); ch = getchcode(arg);
 409     xllastarg();
 410     return (ISUPPER(ch) ? cvchar(TOLOWER(ch)) : arg);
 411 }
 412
 413 /* xdigitchar - built-in function 'digit-char' */
 414 LVAL xdigitchar(V)
 415 {
 416     FIXTYPE n, radix = 10;
 417     n = getfixnum(xlgafixnum());
 418     if (moreargs()) {
 419         radix = getfixnum(xlgafixnum());
 420         if (radix < 1 || radix > 36) xlfail("radix out of range");
 421     }
 422     if (moreargs()) xlgetarg(); /* read and ignore font argument */
 423     xllastarg();
 424     return (n >= 0 && n < radix ? cvchar((int) n + (n < 10 ? '0' : 'A' - 10))
 425                                 : NIL);
 426 }
 427
 428 /* xalphanumericp - built-in function 'alphanumericp' */
 429 LVAL xalphanumericp(V)
 430 {
 431     int ch;
 432     ch = getchcode(xlgachar());
 433     xllastarg();
 434     return (ISUPPER(ch) || ISLOWERA(ch) || isdigit(ch) ? s_true : NIL);
 435 }
 436
 437 /* xalphacharp - built-in function 'alpha-char-p' */
 438 LVAL xalphacharp(V)
 439 {
 440     int ch;
 441     ch = getchcode(xlgachar());
 442     xllastarg();
 443     return (ISUPPER(ch) || ISLOWERA(ch) ? s_true : NIL);
 444 }
 445
 446 /* chrcompare - compare characters */
 447 LOCAL LVAL chrcompare P2C(int, fcn, int, icase)
 448 {
 449     int ch1,ch2,icmp;
 450     LVAL arg;
 451
 452     /* get the characters */
 453     arg = xlgachar(); ch1 = getchcode(arg);
 454
 455     /* convert to lowercase if case insensitive */
 456     if (icase && ISUPPER(ch1))
 457         ch1 = TOLOWER(ch1);
 458
 459     /* handle each remaining argument */
 460     for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
 461
 462         /* get the next argument */
 463         arg = xlgachar(); ch2 = getchcode(arg);
 464
 465         /* convert to lowercase if case insensitive */
 466         if (icase && ISUPPER(ch2))
 467             ch2 = TOLOWER(ch2);
 468
 469         /* compare the characters */
 470         switch (fcn) {
 471         case '<':       icmp = (ch1 < ch2); break;
 472         case 'L':       icmp = (ch1 <= ch2); break;
 473         case '=':       icmp = (ch1 == ch2); break;
 474         case '#':       icmp = (ch1 != ch2); break;
 475         case 'G':       icmp = (ch1 >= ch2); break;
 476         case '>':       icmp = (ch1 > ch2); break;
 477         }
 478     }
 479
 480     /* return the result */
 481     return (icmp ? s_true : NIL);
 482 }
 483
 484 /* character comparision functions */
 485 LVAL xchrlss(V) { return (chrcompare('<',FALSE)); } /* char< */
 486 LVAL xchrleq(V) { return (chrcompare('L',FALSE)); } /* char<= */
 487 LVAL xchreql(V) { return (chrcompare('=',FALSE)); } /* char= */
 488 LVAL xchrneq(V) { return (chrcompare('#',FALSE)); } /* char/= */
 489 LVAL xchrgeq(V) { return (chrcompare('G',FALSE)); } /* char>= */
 490 LVAL xchrgtr(V) { return (chrcompare('>',FALSE)); } /* char> */
 491
 492 /* character comparision functions (case insensitive) */
 493 LVAL xchrilss(V) { return (chrcompare('<',TRUE)); } /* char-lessp */
 494 LVAL xchrileq(V) { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
 495 LVAL xchrieql(V) { return (chrcompare('=',TRUE)); } /* char-equalp */
 496 LVAL xchrineq(V) { return (chrcompare('#',TRUE)); } /* char-not-equalp */
 497 LVAL xchrigeq(V) { return (chrcompare('G',TRUE)); } /* char-not-lessp */
 498 LVAL xchrigtr(V) { return (chrcompare('>',TRUE)); } /* char-greaterp */
 499
 500 LVAL xmkstring(V)
 501 {
 502   int n, i;
 503   char c = ' ';
 504   LVAL arg, result;
 505
 506   arg = xlgafixnum();
 507   n = getfixnum(arg);
 508   if (n < 0) xlerror("Not a nonnegative integer", arg);
 509
 510   if (xlgetkeyarg(k_initelem, &arg)) {
 511     if (! charp(arg)) xlbadtype(arg);
 512     c = getchcode(arg);
 513   }
 514   result = newstring(n);
 515   for (i = 0; i < n; i++)
 516     setstringch(result, i, c);
 517   return(result);
 518 }