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