home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlstr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  14.9 KB  |  558 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlstr.c
  5. * RCS:          $Header: xlstr.c,v 1.4 91/03/24 22:25:27 mayer Exp $
  6. * Description:  xlisp string and character built-in functions
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:10:58 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlstr.c,v 1.4 91/03/24 22:25:27 mayer Exp $";
  43.  
  44.  
  45.  
  46. #include "xlisp.h"
  47.  
  48. /* local definitions */
  49. #define fix(n)    cvfixnum((FIXTYPE)(n))
  50. #define TLEFT    1
  51. #define TRIGHT    2
  52.  
  53. /* external variables */
  54. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  55. extern LVAL true;
  56. extern char buf[];
  57.  
  58. /* external procedures */
  59. extern char *strcat();
  60.  
  61. /* forward declarations */
  62. LOCAL FORWARD LVAL strcompare(); /* NPM: changed this to LOCAL */
  63. LOCAL FORWARD LVAL chrcompare(); /* NPM: changed this to LOCAL */
  64. LOCAL FORWARD LVAL changecase(); /* NPM: changed this to LOCAL */
  65. LOCAL FORWARD LVAL trim();    /* NPM: changed this to LOCAL */
  66.  
  67. /* string comparision functions */
  68. LVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
  69. LVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
  70. LVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
  71. LVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
  72. LVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
  73. LVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
  74.  
  75. /* string comparison functions (not case sensitive) */
  76. LVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
  77. LVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
  78. LVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
  79. LVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
  80. LVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
  81. LVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
  82.  
  83. /* strcompare - compare strings */
  84. LOCAL LVAL strcompare(fcn,icase)
  85.   int fcn,icase;
  86. {
  87.     int start1,end1,start2,end2,ch1,ch2;
  88.     unsigned char *p1,*p2;
  89.     LVAL str1,str2;
  90.  
  91.     /* get the strings */
  92.     str1 = xlgastring();
  93.     str2 = xlgastring();
  94.  
  95.     /* get the substring specifiers */
  96.     getbounds(str1,k_1start,k_1end,&start1,&end1);
  97.     getbounds(str2,k_2start,k_2end,&start2,&end2);
  98.  
  99.     /* setup the string pointers */
  100.     p1 = &getstring(str1)[start1];
  101.     p2 = &getstring(str2)[start2];
  102.  
  103.     /* compare the strings */
  104.     for (; start1 < end1 && start2 < end2; ++start1,++start2) {
  105.     ch1 = *p1++;
  106.     ch2 = *p2++;
  107.     if (icase) {
  108.         if (isupper(ch1)) ch1 = tolower(ch1);
  109.         if (isupper(ch2)) ch2 = tolower(ch2);
  110.     }
  111.     if (ch1 != ch2)
  112.         switch (fcn) {
  113.         case '<':    return (ch1 < ch2 ? fix(start1) : NIL);
  114.         case 'L':    return (ch1 <= ch2 ? fix(start1) : NIL);
  115.         case '=':    return (NIL);
  116.         case '#':    return (fix(start1));
  117.         case 'G':    return (ch1 >= ch2 ? fix(start1) : NIL);
  118.         case '>':    return (ch1 > ch2 ? fix(start1) : NIL);
  119.         }
  120.     }
  121.  
  122.     /* check the termination condition */
  123.     switch (fcn) {
  124.     case '<':    return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
  125.     case 'L':    return (start1 >= end1 ? fix(start1) : NIL);
  126.     case '=':    return (start1 >= end1 && start2 >= end2 ? true : NIL);
  127.     case '#':    return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
  128.     case 'G':    return (start2 >= end2 ? fix(start1) : NIL);
  129.     case '>':    return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
  130.     }
  131. }
  132.  
  133. /* case conversion functions */
  134. LVAL xupcase()   { return (changecase('U',FALSE)); }
  135. LVAL xdowncase() { return (changecase('D',FALSE)); }
  136.  
  137. /* destructive case conversion functions */
  138. LVAL xnupcase()   { return (changecase('U',TRUE)); }
  139. LVAL xndowncase() { return (changecase('D',TRUE)); }
  140.  
  141. /* changecase - change case */
  142. LOCAL LVAL changecase(fcn,destructive)
  143.   int fcn,destructive;
  144. {
  145.     unsigned char *srcp,*dstp;
  146.     int start,end,len,ch,i;
  147.     LVAL src,dst;
  148.  
  149.     /* get the string */
  150.     src = xlgastring();
  151.  
  152.     /* get the substring specifiers */
  153.     getbounds(src,k_start,k_end,&start,&end);
  154.     len = getslength(src) - 1;
  155.  
  156.     /* make a destination string */
  157.     dst = (destructive ? src : newstring(len+1));
  158.  
  159.     /* setup the string pointers */
  160.     srcp = getstring(src);
  161.     dstp = getstring(dst);
  162.  
  163.     /* copy the source to the destination */
  164.     for (i = 0; i < len; ++i) {
  165.     ch = *srcp++;
  166.     if (i >= start && i < end)
  167.         switch (fcn) {
  168.         case 'U':    if (islower(ch)) ch = toupper(ch); break;
  169.         case 'D':    if (isupper(ch)) ch = tolower(ch); break;
  170.         }
  171.     *dstp++ = ch;
  172.     }
  173.     *dstp = '\0';
  174.  
  175.     /* return the new string */
  176.     return (dst);
  177. }
  178.  
  179. /* trim functions */
  180. LVAL xtrim()      { return (trim(TLEFT|TRIGHT)); }
  181. LVAL xlefttrim()  { return (trim(TLEFT)); }
  182. LVAL xrighttrim() { return (trim(TRIGHT)); }
  183.  
  184. /* trim - trim character from a string */
  185. LOCAL LVAL trim(fcn)
  186.   int fcn;
  187. {
  188.     unsigned char *leftp,*rightp,*dstp;
  189.     LVAL bag,src,dst;
  190.  
  191.     /* get the bag and the string */
  192.     bag = xlgastring();
  193.     src = xlgastring();
  194.     xllastarg();
  195.  
  196.     /* setup the string pointers */
  197.     leftp = getstring(src);
  198.     rightp = leftp + getslength(src) - 2;
  199.  
  200.     /* trim leading characters */
  201.     if (fcn & TLEFT)
  202.     while (leftp <= rightp && inbag(*leftp,bag))
  203.         ++leftp;
  204.  
  205.     /* trim character from the right */
  206.     if (fcn & TRIGHT)
  207.     while (rightp >= leftp && inbag(*rightp,bag))
  208.         --rightp;
  209.  
  210.     /* make a destination string and setup the pointer */
  211.     dst = newstring((int)(rightp-leftp+2));
  212.     dstp = getstring(dst);
  213.  
  214.     /* copy the source to the destination */
  215.     while (leftp <= rightp)
  216.     *dstp++ = *leftp++;
  217.     *dstp = '\0';
  218.  
  219.     /* return the new string */
  220.     return (dst);
  221. }
  222.  
  223. /* getbounds - get the start and end bounds of a string */
  224. LOCAL getbounds(str,skey,ekey,pstart,pend)
  225.   LVAL str,skey,ekey; int *pstart,*pend;
  226. {
  227.     LVAL arg;
  228.     int len;
  229.  
  230.     /* get the length of the string */
  231.     len = getslength(str) - 1;
  232.  
  233.     /* get the starting index */
  234.     if (xlgkfixnum(skey,&arg)) {
  235.     *pstart = (int)getfixnum(arg);
  236.     if (*pstart < 0 || *pstart > len)
  237.         xlerror("string index out of bounds",arg);
  238.     }
  239.     else
  240.     *pstart = 0;
  241.  
  242.     /* get the ending index */
  243.     if (xlgkfixnum(ekey,&arg)) {
  244.     *pend = (int)getfixnum(arg);
  245.     if (*pend < 0 || *pend > len)
  246.         xlerror("string index out of bounds",arg);
  247.     }
  248.     else
  249.     *pend = len;
  250.  
  251.     /* make sure the start is less than or equal to the end */
  252.     if (*pstart > *pend)
  253.     xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
  254. }
  255.  
  256. /* inbag - test if a character is in a bag */
  257. LOCAL int inbag(ch,bag)
  258.   int ch; LVAL bag;
  259. {
  260.     unsigned char *p;
  261.     for (p = getstring(bag); *p != '\0'; ++p)
  262.     if (*p == ch)
  263.         return (TRUE);
  264.     return (FALSE);
  265. }
  266.  
  267. /* xstrcat - concatenate a bunch of strings */
  268. LVAL xstrcat()
  269. {
  270.     LVAL *saveargv,tmp,val;
  271.     unsigned char *str;
  272.     int saveargc,len;
  273.  
  274.     /* save the argument list */
  275.     saveargv = xlargv;
  276.     saveargc = xlargc;
  277.  
  278.     /* find the length of the new string */
  279.     for (len = 0; moreargs(); ) {
  280.     tmp = xlgastring();
  281.     len += (int)getslength(tmp) - 1;
  282.     }
  283.  
  284.     /* create the result string */
  285.     val = newstring(len+1);
  286.     str = getstring(val);
  287.  
  288.     /* restore the argument list */
  289.     xlargv = saveargv;
  290.     xlargc = saveargc;
  291.     
  292.     /* combine the strings */
  293.     for (*str = '\0'; moreargs(); ) {
  294.     tmp = nextarg();
  295.     strcat(str,getstring(tmp));
  296.     }
  297.  
  298.     /* return the new string */
  299.     return (val);
  300. }
  301.  
  302. /* xsubseq - return a subsequence */
  303. LVAL xsubseq()
  304. {
  305.     unsigned char *srcp,*dstp;
  306.     int start,end,len;
  307.     LVAL src,dst;
  308.  
  309.     /* get string and starting and ending positions */
  310.     src = xlgastring();
  311.  
  312.     /* get the starting position */
  313.     dst = xlgafixnum(); start = (int)getfixnum(dst);
  314.     if (start < 0 || start > getslength(src) - 1)
  315.     xlerror("string index out of bounds",dst);
  316.  
  317.     /* get the ending position */
  318.     if (moreargs()) {
  319.     dst = xlgafixnum(); end = (int)getfixnum(dst);
  320.     if (end < 0 || end > getslength(src) - 1)
  321.         xlerror("string index out of bounds",dst);
  322.     }
  323.     else
  324.     end = getslength(src) - 1;
  325.     xllastarg();
  326.  
  327.     /* setup the source pointer */
  328.     srcp = getstring(src) + start;
  329.     len = end - start;
  330.  
  331.     /* make a destination string and setup the pointer */
  332.     dst = newstring(len+1);
  333.     dstp = getstring(dst);
  334.  
  335.     /* copy the source to the destination */
  336.     while (--len >= 0)
  337.     *dstp++ = *srcp++;
  338.     *dstp = '\0';
  339.  
  340.     /* return the substring */
  341.     return (dst);
  342. }
  343.  
  344. /* xstring - return a string consisting of a single character */
  345. LVAL xstring()
  346. {
  347.     LVAL arg;
  348.  
  349.     /* get the argument */
  350.     arg = xlgetarg();
  351.     xllastarg();
  352.  
  353.     /* make sure its not NIL */
  354.     if (null(arg))
  355.     xlbadtype(arg);
  356.  
  357.     /* check the argument type */
  358.     switch (ntype(arg)) {
  359.     case STRING:
  360.     return (arg);
  361.     case SYMBOL:
  362.     return (getpname(arg));
  363.     case CHAR:
  364.     buf[0] = (int)getchcode(arg);
  365.     buf[1] = '\0';
  366.     return (cvstring(buf));
  367.     default:
  368.     xlbadtype(arg);
  369.     }
  370. }
  371.  
  372. /* xchar - extract a character from a string */
  373. LVAL xchar()
  374. {
  375.     LVAL str,num;
  376.     int n;
  377.  
  378.     /* get the string and the index */
  379.     str = xlgastring();
  380.     num = xlgafixnum();
  381.     xllastarg();
  382.  
  383.     /* range check the index */
  384.     if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
  385.     xlerror("index out of range",num);
  386.  
  387.     /* return the character */
  388.     return (cvchar(getstring(str)[n]));
  389. }
  390.  
  391. /* xcharint - convert an integer to a character */
  392. LVAL xcharint()
  393. {
  394.     LVAL arg;
  395.     arg = xlgachar();
  396.     xllastarg();
  397.     return (cvfixnum((FIXTYPE)getchcode(arg)));
  398. }
  399.  
  400. /* xintchar - convert a character to an integer */
  401. LVAL xintchar()
  402. {
  403.     LVAL arg;
  404.     arg = xlgafixnum();
  405.     xllastarg();
  406.     return (cvchar((int)getfixnum(arg)));
  407. }
  408.  
  409. /* xuppercasep - built-in function 'upper-case-p' */
  410. LVAL xuppercasep()
  411. {
  412.     int ch;
  413.     ch = getchcode(xlgachar());
  414.     xllastarg();
  415.     return (isupper(ch) ? true : NIL);
  416. }
  417.  
  418. /* xlowercasep - built-in function 'lower-case-p' */
  419. LVAL xlowercasep()
  420. {
  421.     int ch;
  422.     ch = getchcode(xlgachar());
  423.     xllastarg();
  424.     return (islower(ch) ? true : NIL);
  425. }
  426.  
  427. /* xbothcasep - built-in function 'both-case-p' */
  428. LVAL xbothcasep()
  429. {
  430.     int ch;
  431.     ch = getchcode(xlgachar());
  432.     xllastarg();
  433.     return (isupper(ch) || islower(ch) ? true : NIL);
  434. }
  435.  
  436. /* xdigitp - built-in function 'digit-char-p' */
  437. LVAL xdigitp()
  438. {
  439.     int ch;
  440.     ch = getchcode(xlgachar());
  441.     xllastarg();
  442.     return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
  443. }
  444.  
  445. /* xcharcode - built-in function 'char-code' */
  446. LVAL xcharcode()
  447. {
  448.     int ch;
  449.     ch = getchcode(xlgachar());
  450.     xllastarg();
  451.     return (cvfixnum((FIXTYPE)ch));
  452. }
  453.  
  454. /* xcodechar - built-in function 'code-char' */
  455. LVAL xcodechar()
  456. {
  457.     LVAL arg;
  458.     int ch;
  459.     arg = xlgafixnum(); ch = getfixnum(arg);
  460.     xllastarg();
  461.     return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
  462. }
  463.  
  464. /* xchupcase - built-in function 'char-upcase' */
  465. LVAL xchupcase()
  466. {
  467.     LVAL arg;
  468.     int ch;
  469.     arg = xlgachar(); ch = getchcode(arg);
  470.     xllastarg();
  471.     return (islower(ch) ? cvchar(toupper(ch)) : arg);
  472. }
  473.  
  474. /* xchdowncase - built-in function 'char-downcase' */
  475. LVAL xchdowncase()
  476. {
  477.     LVAL arg;
  478.     int ch;
  479.     arg = xlgachar(); ch = getchcode(arg);
  480.     xllastarg();
  481.     return (isupper(ch) ? cvchar(tolower(ch)) : arg);
  482. }
  483.  
  484. /* xdigitchar - built-in function 'digit-char' */
  485. LVAL xdigitchar()
  486. {
  487.     LVAL arg;
  488.     int n;
  489.     arg = xlgafixnum(); n = getfixnum(arg);
  490.     xllastarg();
  491.     return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
  492. }
  493.  
  494. /* xalphanumericp - built-in function 'alphanumericp' */
  495. LVAL xalphanumericp()
  496. {
  497.     int ch;
  498.     ch = getchcode(xlgachar());
  499.     xllastarg();
  500.     return (isupper(ch) || islower(ch) || isdigit(ch) ? true : NIL);
  501. }
  502.  
  503. /* character comparision functions */
  504. LVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char< */
  505. LVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<= */
  506. LVAL xchreql() { return (chrcompare('=',FALSE)); } /* char= */
  507. LVAL xchrneq() { return (chrcompare('#',FALSE)); } /* char/= */
  508. LVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>= */
  509. LVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char> */
  510.  
  511. /* character comparision functions (case insensitive) */
  512. LVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-lessp */
  513. LVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
  514. LVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-equalp */
  515. LVAL xchrineq() { return (chrcompare('#',TRUE)); } /* char-not-equalp */
  516. LVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-not-lessp */
  517. LVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-greaterp */
  518.  
  519. /* chrcompare - compare characters */
  520. LOCAL LVAL chrcompare(fcn,icase)
  521.   int fcn,icase;
  522. {
  523.     int ch1,ch2,icmp;
  524.     LVAL arg;
  525.     
  526.     /* get the characters */
  527.     arg = xlgachar(); ch1 = getchcode(arg);
  528.  
  529.     /* convert to lowercase if case insensitive */
  530.     if (icase && isupper(ch1))
  531.     ch1 = tolower(ch1);
  532.  
  533.     /* handle each remaining argument */
  534.     for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
  535.  
  536.     /* get the next argument */
  537.     arg = xlgachar(); ch2 = getchcode(arg);
  538.  
  539.     /* convert to lowercase if case insensitive */
  540.     if (icase && isupper(ch2))
  541.         ch2 = tolower(ch2);
  542.  
  543.     /* compare the characters */
  544.     switch (fcn) {
  545.     case '<':    icmp = (ch1 < ch2); break;
  546.     case 'L':    icmp = (ch1 <= ch2); break;
  547.     case '=':    icmp = (ch1 == ch2); break;
  548.     case '#':    icmp = (ch1 != ch2); break;
  549.     case 'G':    icmp = (ch1 >= ch2); break;
  550.     case '>':    icmp = (ch1 > ch2); break;
  551.     }
  552.     }
  553.  
  554.     /* return the result */
  555.     return (icmp ? true : NIL);
  556. }
  557.  
  558.