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