home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / sources / xlstr.c < prev    next >
C/C++ Source or Header  |  1992-02-03  |  13KB  |  472 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.  
  17. /* getbounds - get the start and end bounds of a string */
  18. #ifdef ANSI
  19. static void NEAR getbounds(LVAL str, LVAL skey, LVAL ekey, unsigned *pstart, unsigned *pend)
  20. #else
  21. LOCAL VOID getbounds(str,skey,ekey,pstart,pend)
  22.   LVAL str,skey,ekey; unsigned *pstart,*pend;
  23. #endif
  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 > 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 > 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. #ifdef ANSI
  58. static LVAL NEAR strcompare(int fcn, int icase)
  59. #else
  60. LOCAL LVAL strcompare(fcn,icase)
  61.   int fcn,icase;
  62. #endif
  63. {
  64.     unsigned start1,end1,start2,end2;
  65.     int ch1,ch2;
  66.     char FAR *p1, FAR *p2;
  67.     LVAL str1,str2;
  68.  
  69.     /* get the strings */
  70.     str1 = xlgastrorsym();
  71.     str2 = xlgastrorsym();
  72.  
  73.     /* get the substring specifiers */
  74.     getbounds(str1,k_1start,k_1end,&start1,&end1);
  75.     getbounds(str2,k_2start,k_2end,&start2,&end2);
  76.  
  77.     xllastarg();
  78.  
  79.     /* setup the string pointers */
  80.     p1 = &getstring(str1)[start1];
  81.     p2 = &getstring(str2)[start2];
  82.  
  83.     /* compare the strings */
  84.     for (; start1 < end1 && start2 < end2; ++start1,++start2) {
  85.         ch1 = *p1++;
  86.         ch2 = *p2++;
  87.         if (icase) {
  88.             if (isupper(ch1)) ch1 = tolower(ch1);
  89.             if (isupper(ch2)) ch2 = tolower(ch2);
  90.         }
  91.         if (ch1 != ch2)
  92.             switch (fcn) {
  93.             case '<':   return (ch1 < ch2 ? fix(start1) : NIL);
  94.             case 'L':   return (ch1 <= ch2 ? fix(start1) : NIL);
  95.             case '=':   return (NIL);
  96.             case '#':   return (fix(start1));
  97.             case 'G':   return (ch1 >= ch2 ? fix(start1) : NIL);
  98.             case '>':   return (ch1 > ch2 ? fix(start1) : NIL);
  99.             }
  100.     }
  101.  
  102.     /* check the termination condition */
  103.     switch (fcn) {
  104.     case '<':   return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
  105.     case 'L':   return (start1 >= end1 ? fix(start1) : NIL);
  106.     case '=':   return (start1 >= end1 && start2 >= end2 ? true : NIL);
  107.     case '#':   return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
  108.     case 'G':   return (start2 >= end2 ? fix(start1) : NIL);
  109.     case '>':   return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
  110.     }
  111.     return (NIL);   /* avoid compiler warning */
  112. }
  113.  
  114. /* string comparision functions */
  115. LVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
  116. LVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
  117. LVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
  118. LVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
  119. LVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
  120. LVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
  121.  
  122. /* string comparison functions (not case sensitive) */
  123. LVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
  124. LVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
  125. LVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
  126. LVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
  127. LVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
  128. LVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
  129.  
  130. /* changecase - change case */
  131. #ifdef ANSI
  132. static LVAL NEAR changecase(int fcn, int destructive)
  133. #else
  134. LOCAL LVAL changecase(fcn,destructive)
  135.   int fcn,destructive;
  136. #endif
  137. {
  138.     char FAR *srcp, FAR *dstp;
  139.     unsigned start,end,len,i;
  140.     int ch;
  141.     LVAL src,dst;
  142.  
  143.     /* get the string */
  144.     src = (destructive? xlgastring() : xlgastrorsym());
  145.  
  146.     /* get the substring specifiers */
  147.     getbounds(src,k_start,k_end,&start,&end);
  148.     len = getslength(src);
  149.  
  150.     xllastarg();
  151.  
  152.     /* make a destination string */
  153.     dst = (destructive ? src : newstring(len));
  154.  
  155.     /* setup the string pointers */
  156.     srcp = getstring(src);
  157.     dstp = getstring(dst);
  158.  
  159.     /* copy the source to the destination */
  160.     for (i = 0; i < len; ++i) {
  161.         ch = *srcp++;
  162.         if (i >= start && i < end)
  163.             switch (fcn) {
  164.             case 'U':   if (islower(ch)) ch = toupper(ch); break;
  165.             case 'D':   if (isupper(ch)) ch = tolower(ch); break;
  166.             }
  167.         *dstp++ = ch;
  168.     }
  169.     *dstp = '\0';
  170.  
  171.     /* return the new string */
  172.     return (dst);
  173. }
  174.  
  175. /* case conversion functions */
  176. LVAL xupcase()   { return (changecase('U',FALSE)); }
  177. LVAL xdowncase() { return (changecase('D',FALSE)); }
  178.  
  179. /* destructive case conversion functions */
  180. LVAL xnupcase()   { return (changecase('U',TRUE)); }
  181. LVAL xndowncase() { return (changecase('D',TRUE)); }
  182.  
  183. /* inbag - test if a character is in a bag */
  184. #ifdef ANSI
  185. static int NEAR inbag(int ch, LVAL bag)
  186. #else
  187. LOCAL int inbag(ch,bag)
  188.   int ch; LVAL bag;
  189. #endif
  190. {
  191.                                     /* TAA MOD -- rewritten for \0 */
  192.                                     /*            and chars >= 128 */
  193.     char FAR *p = getstring(bag);
  194.     unsigned len =getslength(bag);
  195.  
  196.     while (len--)
  197.         if (*p++ == ch)
  198.             return (TRUE);
  199.     return (FALSE);
  200. }
  201.  
  202. /* trim - trim character from a string */
  203. #ifdef ANSI
  204. static LVAL NEAR trim(int fcn)
  205. #else
  206. LOCAL LVAL trim(fcn)
  207.   int fcn;
  208. #endif
  209. {
  210.     char FAR *leftp, FAR *rightp, FAR *dstp;
  211.     LVAL bag,src,dst;
  212.  
  213.     /* get the bag and the string */
  214.     bag = xlgastrorsym();
  215.     src = xlgastrorsym();
  216.     xllastarg();
  217.  
  218.     /* setup the string pointers */
  219.     leftp = getstring(src);
  220.     rightp = leftp + getslength(src) - 1;
  221.  
  222.     /* trim leading characters */
  223.     if (fcn & TLEFT)
  224.         while (leftp <= rightp && inbag(*leftp,bag))
  225.             ++leftp;
  226.  
  227.     /* trim character from the right */
  228.     if (fcn & TRIGHT)
  229.         while (rightp >= leftp && inbag(*rightp,bag))
  230.             --rightp;
  231.  
  232.     /* make a destination string and setup the pointer */
  233.     dst = newstring((unsigned)rightp-(unsigned)leftp+1);
  234.     dstp = getstring(dst);
  235.  
  236.     /* copy the source to the destination */
  237.     while (leftp <= rightp)
  238.         *dstp++ = *leftp++;
  239.     *dstp = '\0';
  240.  
  241.     /* return the new string */
  242.     return (dst);
  243. }
  244.  
  245. /* trim functions */
  246. LVAL xtrim()      { return (trim(TLEFT|TRIGHT)); }
  247. LVAL xlefttrim()  { return (trim(TLEFT)); }
  248. LVAL xrighttrim() { return (trim(TRIGHT)); }
  249.  
  250.  
  251. /* xstring - return a string consisting of a single character */
  252. LVAL xstring()
  253. {
  254.     LVAL arg;
  255.  
  256.     /* get the argument */
  257.     arg = xlgetarg();
  258.     xllastarg();
  259.  
  260.     /* check the argument type */
  261.     switch (ntype(arg)) {
  262.     case STRING:
  263.         return (arg);
  264.     case SYMBOL:
  265.         return (getpname(arg));
  266.     case CHAR:
  267.         buf[0] = (int)getchcode(arg);
  268.         buf[1] = '\0';
  269.         return (cvstring(buf));
  270.     case FIXNUM:
  271.         buf[0] = getfixnum(arg);
  272.         buf[1] = '\0';
  273.         return (cvstring(buf));
  274.     default:
  275.         xlbadtype(arg);
  276.         return (NIL);   /* avoid compiler warning */
  277.     }
  278. }
  279.  
  280. /* xchar - extract a character from a string */
  281. LVAL xchar()
  282. {
  283.     LVAL str,num;
  284.     FIXTYPE n;
  285.  
  286.     /* get the string and the index */
  287.     str = xlgastring();
  288.     num = xlgafixnum();
  289.     xllastarg();
  290.  
  291.     /* range check the index */
  292.     if ((n = getfixnum(num)) < 0 || n >= getslength(str))
  293.         xlerror("index out of range",num);
  294.  
  295.     /* return the character */
  296.     return (cvchar(getstringch(str,(unsigned int)n)));
  297. }
  298.  
  299. /* xcharint - convert a character to an integer */
  300. LVAL xcharint()
  301. {
  302.     LVAL arg;
  303.     arg = xlgachar();
  304.     xllastarg();
  305.     return (cvfixnum((FIXTYPE)getchcode(arg)));
  306. }
  307.  
  308. /* xintchar - convert an integer to a character */
  309. LVAL xintchar()
  310. {
  311.     LVAL arg;
  312.     arg = xlgafixnum();
  313.     xllastarg();
  314.     return (cvchar((int)getfixnum(arg)));
  315. }
  316.  
  317. /* xcharcode - built-in function 'char-code' */
  318. /* TAA mod so that result is 7 bit ascii code */
  319. LVAL xcharcode()
  320. {
  321.     int ch;
  322.     ch = 0x7f  & getchcode(xlgachar());
  323.     xllastarg();
  324.     return (cvfixnum((FIXTYPE)ch));
  325. }
  326.  
  327. /* xcodechar - built-in function 'code-char' */
  328. /* like int-char except range must be 0-127 */
  329. LVAL xcodechar()
  330. {
  331.     LVAL arg;
  332.     FIXTYPE ch;
  333.     arg = xlgafixnum(); ch = getfixnum(arg);
  334.     xllastarg();
  335.     return (ch >= 0 && ch <= 127 ? cvchar((int)ch) : NIL);
  336. }
  337.  
  338. /* xuppercasep - built-in function 'upper-case-p' */
  339. LVAL xuppercasep()
  340. {
  341.     int ch;
  342.     ch = getchcode(xlgachar());
  343.     xllastarg();
  344.     return (isupper(ch) ? true : NIL);
  345. }
  346.  
  347. /* xlowercasep - built-in function 'lower-case-p' */
  348. LVAL xlowercasep()
  349. {
  350.     int ch;
  351.     ch = getchcode(xlgachar());
  352.     xllastarg();
  353.     return (islower(ch) ? true : NIL);
  354. }
  355.  
  356. /* xbothcasep - built-in function 'both-case-p' */
  357. LVAL xbothcasep()
  358. {
  359.     int ch;
  360.     ch = getchcode(xlgachar());
  361.     xllastarg();
  362.     return (isupper(ch) || islower(ch) ? true : NIL);
  363. }
  364.  
  365. /* xdigitp - built-in function 'digit-char-p' */
  366. LVAL xdigitp()
  367. {
  368.     int ch;
  369.     ch = getchcode(xlgachar());
  370.     xllastarg();
  371.     return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
  372. }
  373.  
  374. /* xchupcase - built-in function 'char-upcase' */
  375. LVAL xchupcase()
  376. {
  377.     LVAL arg;
  378.     int ch;
  379.     arg = xlgachar(); ch = getchcode(arg);
  380.     xllastarg();
  381.     return (islower(ch) ? cvchar(toupper(ch)) : arg);
  382. }
  383.  
  384. /* xchdowncase - built-in function 'char-downcase' */
  385. LVAL xchdowncase()
  386. {
  387.     LVAL arg;
  388.     int ch;
  389.     arg = xlgachar(); ch = getchcode(arg);
  390.     xllastarg();
  391.     return (isupper(ch) ? cvchar(tolower(ch)) : arg);
  392. }
  393.  
  394. /* xdigitchar - built-in function 'digit-char' */
  395. LVAL xdigitchar()
  396. {
  397.     LVAL arg;
  398.     FIXTYPE n;
  399.     arg = xlgafixnum(); n = getfixnum(arg);
  400.     xllastarg();
  401.     return (n >= 0 && n <= 9 ? cvchar((int)n + '0') : NIL);
  402. }
  403.  
  404. /* xalphanumericp - built-in function 'alphanumericp' */
  405. LVAL xalphanumericp()
  406. {
  407.     int ch;
  408.     ch = getchcode(xlgachar());
  409.     xllastarg();
  410.     return (isupper(ch) || islower(ch) || isdigit(ch) ? true : NIL);
  411. }
  412.  
  413. /* chrcompare - compare characters */
  414. #ifdef ANSI
  415. static LVAL NEAR chrcompare(int fcn, int icase)
  416. #else
  417. LOCAL LVAL chrcompare(fcn,icase)
  418.   int fcn,icase;
  419. #endif
  420. {
  421.     int ch1,ch2,icmp;
  422.     LVAL arg;
  423.  
  424.     /* get the characters */
  425.     arg = xlgachar(); ch1 = getchcode(arg);
  426.  
  427.     /* convert to lowercase if case insensitive */
  428.     if (icase && isupper(ch1))
  429.         ch1 = tolower(ch1);
  430.  
  431.     /* handle each remaining argument */
  432.     for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
  433.  
  434.         /* get the next argument */
  435.         arg = xlgachar(); ch2 = getchcode(arg);
  436.  
  437.         /* convert to lowercase if case insensitive */
  438.         if (icase && isupper(ch2))
  439.             ch2 = tolower(ch2);
  440.  
  441.         /* compare the characters */
  442.         switch (fcn) {
  443.         case '<':       icmp = (ch1 < ch2); break;
  444.         case 'L':       icmp = (ch1 <= ch2); break;
  445.         case '=':       icmp = (ch1 == ch2); break;
  446.         case '#':       icmp = (ch1 != ch2); break;
  447.         case 'G':       icmp = (ch1 >= ch2); break;
  448.         case '>':       icmp = (ch1 > ch2); break;
  449.         }
  450.     }
  451.  
  452.     /* return the result */
  453.     return (icmp ? true : NIL);
  454. }
  455.  
  456. /* character comparision functions */
  457. LVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char< */
  458. LVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<= */
  459. LVAL xchreql() { return (chrcompare('=',FALSE)); } /* char= */
  460. LVAL xchrneq() { return (chrcompare('#',FALSE)); } /* char/= */
  461. LVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>= */
  462. LVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char> */
  463.  
  464. /* character comparision functions (case insensitive) */
  465. LVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-lessp */
  466. LVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
  467. LVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-equalp */
  468. LVAL xchrineq() { return (chrcompare('#',TRUE)); } /* char-not-equalp */
  469. LVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-not-lessp */
  470. LVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-greaterp */
  471.  
  472.