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