/* xlstr - xlisp string and character built-in functions */
/* Copyright (c) 1989, by David Michael Betz.                            */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution.                              */

#include "xlisp.h"

/* local definitions */
#define fix(n)	cvfixnum((FIXTYPE)(n))
#define TLEFT	1
#define TRIGHT	2

/* Function prototypes */
LOCAL VOID getbounds P5H(LVAL, LVAL, LVAL, unsigned *, unsigned *);
LOCAL LVAL strcompare P2H(int, int);
LOCAL LVAL changecase P2H(int, int);
LOCAL int inbag P2H(int, LVAL);
LOCAL LVAL trim P1H(int);
LOCAL LVAL chrcompare P2H(int, int);

/* getbounds - get the start and end bounds of a string */
LOCAL VOID getbounds P5C(LVAL, str, LVAL, skey, LVAL, ekey,
                         unsigned *, pstart, unsigned *, pend)
{
    LVAL arg;
    unsigned len;
    FIXTYPE n;

    /* get the length of the string */
    len = getslength(str);

    /* get the starting index */
    if (xlgkfixnum(skey,&arg)) {
	*pstart = (unsigned) (n = getfixnum(arg));
	if (n < 0 || n > (FIXTYPE)len)
	    xlerror("string index out of bounds",arg);
    }
    else
	*pstart = 0;

    /* get the ending index */
    if (xlgetkeyarg(ekey, &arg) && arg != NIL) {
	if (!fixp(arg)) xlbadtype(arg);
	*pend = (unsigned)(n = getfixnum(arg));
	if (n < 0 || n > (FIXTYPE)len)
	    xlerror("string index out of bounds",arg);
    }
    else
	*pend = len;

    /* make sure the start is less than or equal to the end */
    if (*pstart > *pend)
	xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
}

/* strcompare - compare strings */
LOCAL LVAL strcompare P2C(int, fcn, int, icase)
{
    unsigned start1,end1,start2,end2;
    int ch1,ch2;
    unsigned char *p1, *p2;
    LVAL str1,str2;

    /* get the strings */
    str1 = xlgastrorsym();
    str2 = xlgastrorsym();

    /* get the substring specifiers */
    getbounds(str1,k_1start,k_1end,&start1,&end1);
    getbounds(str2,k_2start,k_2end,&start2,&end2);

    xllastkey();

    /* setup the string pointers */
    p1 = (unsigned char *) &getstring(str1)[start1];
    p2 = (unsigned char *) &getstring(str2)[start2];

    /* compare the strings */
    for (; start1 < end1 && start2 < end2; ++start1,++start2) {
	ch1 = *p1++;
	ch2 = *p2++;
	if (icase) {
	    if (ISUPPER(ch1)) ch1 = TOLOWER(ch1);
	    if (ISUPPER(ch2)) ch2 = TOLOWER(ch2);
	}
	if (ch1 != ch2)
	    switch (fcn) {
	    case '<':	return (ch1 < ch2 ? fix(start1) : NIL);
	    case 'L':	return (ch1 <= ch2 ? fix(start1) : NIL);
	    case '=':	return (NIL);
	    case '#':	return (fix(start1));
	    case 'G':	return (ch1 >= ch2 ? fix(start1) : NIL);
	    case '>':	return (ch1 > ch2 ? fix(start1) : NIL);
	    }
    }

    /* check the termination condition */
    switch (fcn) {
    case '<':	return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
    case 'L':	return (start1 >= end1 ? fix(start1) : NIL);
    case '=':	return (start1 >= end1 && start2 >= end2 ? s_true : NIL);
    case '#':	return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
    case 'G':	return (start2 >= end2 ? fix(start1) : NIL);
    case '>':	return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
    }
    return (NIL);   /* avoid compiler warning */
}

/* string comparision functions */
LVAL xstrlss(V) { return (strcompare('<',FALSE)); } /* string< */
LVAL xstrleq(V) { return (strcompare('L',FALSE)); } /* string<= */
LVAL xstreql(V) { return (strcompare('=',FALSE)); } /* string= */
LVAL xstrneq(V) { return (strcompare('#',FALSE)); } /* string/= */
LVAL xstrgeq(V) { return (strcompare('G',FALSE)); } /* string>= */
LVAL xstrgtr(V) { return (strcompare('>',FALSE)); } /* string> */

/* string comparison functions (not case sensitive) */
LVAL xstrilss(V) { return (strcompare('<',TRUE)); } /* string-lessp */
LVAL xstrileq(V) { return (strcompare('L',TRUE)); } /* string-not-greaterp */
LVAL xstrieql(V) { return (strcompare('=',TRUE)); } /* string-equal */
LVAL xstrineq(V) { return (strcompare('#',TRUE)); } /* string-not-equal */
LVAL xstrigeq(V) { return (strcompare('G',TRUE)); } /* string-not-lessp */
LVAL xstrigtr(V) { return (strcompare('>',TRUE)); } /* string-greaterp */

/* changecase - change case */
LOCAL LVAL changecase P2C(int, fcn, int, destructive)
{
    char *srcp, *dstp;
    unsigned start,end,len,i;
    int ch;
    int lastspace = TRUE;
    LVAL src,dst;

    /* get the string */
    src = (destructive? xlgastring() : xlgastrorsym());

    /* get the substring specifiers */
    getbounds(src,k_start,k_end,&start,&end);
    len = getslength(src);

    xllastkey();

    /* make a destination string */
    dst = (destructive ? src : newstring(len));

    /* setup the string pointers */
    srcp = getstring(src);
    dstp = getstring(dst);

    /* copy the source to the destination */
    for (i = 0; i < len; ++i) {
	ch = *srcp++;
	if (i >= start && i < end)
	    switch (fcn) {
	    case 'U':	if (ISLOWER(ch)) ch = TOUPPER(ch); break;
	    case 'D':	if (ISUPPER(ch)) ch = TOLOWER(ch); break;
	    case 'C':   if (lastspace && ISLOWER(ch)) ch = TOUPPER(ch);
			if (!lastspace && ISUPPER(ch)) ch = TOLOWER(ch);
			lastspace = !ISLOWERA(ch) && !ISUPPER(ch);
			break;
	    }
	*dstp++ = (char) ch;
    }
    *dstp = '\0';

    /* return the new string */
    return (dst);
}

/* case conversion functions */
LVAL xupcase(V)   { return (changecase('U',FALSE)); }
LVAL xdowncase(V) { return (changecase('D',FALSE)); }
LVAL xcapcase(V)  { return (changecase('C',FALSE)); }

/* destructive case conversion functions */
LVAL xnupcase(V)   { return (changecase('U',TRUE)); }
LVAL xndowncase(V) { return (changecase('D',TRUE)); }
LVAL xncapcase(V)  { return (changecase('C',TRUE)); }

/* inbag - test if a character is in a bag */
LOCAL int inbag P2C(int, ch, LVAL, bag)
{
                                    /* TAA MOD -- rewritten for \0 */
                                    /*            and chars >= 128 */
    char *p = getstring(bag);
    unsigned len =getslength(bag);

    while (len--)
	if (*p++ == ch)
	    return (TRUE);
    return (FALSE);
}

/* trim - trim character from a string */
LOCAL LVAL trim P1C(int, fcn)
{
    char *leftp, *rightp, *dstp;
    LVAL bag,src,dst;

    /* get the bag and the string */
    bag = xlgaseq();
    src = xlgastrorsym();
    xllastarg();

    xlprot1(bag);
    bag = coerce_to_tvec(bag, a_char);

    /* setup the string pointers */
    leftp = getstring(src);
    rightp = leftp + getslength(src) - 1;

    /* trim leading characters */
    if (fcn & TLEFT)
	while (leftp <= rightp && inbag(*leftp,bag))
	    ++leftp;

    /* trim character from the right */
    if (fcn & TRIGHT)
	while (rightp >= leftp && inbag(*rightp,bag))
	    --rightp;

    /* make a destination string and setup the pointer */
    dst = newstring(((unsigned)(rightp-leftp))+1);
    dstp = getstring(dst);

    /* copy the source to the destination */
    while (leftp <= rightp)
	*dstp++ = *leftp++;
    *dstp = '\0';

    xlpop();

    /* return the new string */
    return (dst);
}

/* trim functions */
LVAL xtrim(V)      { return (trim(TLEFT|TRIGHT)); }
LVAL xlefttrim(V)  { return (trim(TLEFT)); }
LVAL xrighttrim(V) { return (trim(TRIGHT)); }


/* xstring - return a string consisting of a single character */
LVAL xstring(V)
{
    LVAL arg,val;

    /* get the argument */
    arg = xlgetarg();
    xllastarg();

    /* check the argument type */
    switch (ntype(arg)) {
    case STRING:
	return (arg);
    case SYMBOL:
	return (getpname(arg));
    case CHAR:
	/* Changed 10/94 to allow string '\000' */
	val = newstring(1);
        val->n_string[0] = (char)getchcode(arg);
        val->n_string[1] = '\0';
        return (val);
    case FIXNUM:
	/* Changed 10/94 to allow string 0 */
	val = newstring(1);
        val->n_string[0] = (char)getfixnum(arg);
        val->n_string[1] = '\0';
        return (val);
    default:
	xlbadtype(arg);
	return (NIL);   /* avoid compiler warning */
    }
}

/* xchar - extract a character from a string */
LVAL xchar(V)
{
    LVAL str,num;
    FIXTYPE n;

    /* get the string and the index */
    str = xlgastring();
    num = xlgafixnum();
    xllastarg();

    /* range check the index */
    if ((n = getfixnum(num)) < 0 || n >= (FIXTYPE)getslength(str))
	xlerror("index out of range",num);

    /* return the character */
    return (cvchar(getstringch(str,(unsigned int)n)));
}

/* xcharint - convert a character to an integer */
LVAL xcharint(V)
{
    LVAL arg;
    arg = xlgachar();
    xllastarg();
    return (cvfixnum((FIXTYPE)getchcode(arg)));
}

/* xintchar - convert an integer to a character */
LVAL xintchar(V)
{
    LVAL arg;
    arg = xlgafixnum();
    xllastarg();
    return (cvchar((int)getfixnum(arg)));
}

/* xcharcode - built-in function 'char-code' */
/* TAA mod so that result is 7 bit ascii code */
LVAL xcharcode(V)
{
    int ch;
    ch = 0x7f  & getchcode(xlgachar());
    xllastarg();
    return (cvfixnum((FIXTYPE)ch));
}

/* xcodechar - built-in function 'code-char' */
/* like int-char except range must be 0-127 */
LVAL xcodechar(V)
{
    LVAL arg;
    FIXTYPE ch;
#ifdef __SASC__
    FIXTYPE testch;
#endif

    arg = xlgafixnum(); ch = getfixnum(arg);
    xllastarg();

#ifdef __SASC__
    /* On MVS/CMS, convert EBCDIC character to ASCII for subsequent */
    /* test - Dave Rivers (rivers@ponds.uucp) */
    testch = etoa((unsigned char)ch);
    return (testch >= 0 && testch <= 127 ? cvchar((int)ch) : NIL);
#else
    return (ch >= 0 && ch <= 127 ? cvchar((int)ch) : NIL);
#endif
}

/* xuppercasep - built-in function 'upper-case-p' */
LVAL xuppercasep(V)
{
    int ch;
    ch = getchcode(xlgachar());
    xllastarg();
    return (ISUPPER(ch) ? s_true : NIL);
}

/* xlowercasep - built-in function 'lower-case-p' */
LVAL xlowercasep(V)
{
    int ch;
    ch = getchcode(xlgachar());
    xllastarg();
    return (ISLOWERA(ch) ? s_true : NIL);
}

/* xbothcasep - built-in function 'both-case-p' */
LVAL xbothcasep(V)
{
    int ch;
    ch = getchcode(xlgachar());
    xllastarg();
    return (ISUPPER(ch) || ISLOWER(ch) ? s_true : NIL);
}

/* xdigitp - built-in function 'digit-char-p' */
LVAL xdigitp(V)
{
    int ch;
    FIXTYPE radix = 10;
    ch = getchcode(xlgachar());
    if (moreargs()) {
        radix = getfixnum(xlgafixnum());
        if (radix < 1 || radix > 36) xlfail("radix out of range");
    }
    xllastarg();

    if (isdigit(ch)) ch = ch - '0';
    else if (ISUPPER(ch)) ch = ch - 'A' + 10;
    else if (ISLOWER(ch)) ch = ch - 'a' + 10;
    else return NIL;

    return (ch < radix ? cvfixnum((FIXTYPE) ch) : NIL);
}

/* xchupcase - built-in function 'char-upcase' */
LVAL xchupcase(V)
{
    LVAL arg;
    int ch;
    arg = xlgachar(); ch = getchcode(arg);
    xllastarg();
    return (ISLOWER(ch) ? cvchar(TOUPPER(ch)) : arg);
}

/* xchdowncase - built-in function 'char-downcase' */
LVAL xchdowncase(V)
{
    LVAL arg;
    int ch;
    arg = xlgachar(); ch = getchcode(arg);
    xllastarg();
    return (ISUPPER(ch) ? cvchar(TOLOWER(ch)) : arg);
}

/* xdigitchar - built-in function 'digit-char' */
LVAL xdigitchar(V)
{
    FIXTYPE n, radix = 10;
    n = getfixnum(xlgafixnum());
    if (moreargs()) {
        radix = getfixnum(xlgafixnum());
        if (radix < 1 || radix > 36) xlfail("radix out of range");
    }
    if (moreargs()) xlgetarg(); /* read and ignore font argument */
    xllastarg();
    return (n >= 0 && n < radix ? cvchar((int) n + (n < 10 ? '0' : 'A' - 10))
                                : NIL);
}

/* xalphanumericp - built-in function 'alphanumericp' */
LVAL xalphanumericp(V)
{
    int ch;
    ch = getchcode(xlgachar());
    xllastarg();
    return (ISUPPER(ch) || ISLOWERA(ch) || isdigit(ch) ? s_true : NIL);
}

/* xalphacharp - built-in function 'alpha-char-p' */
LVAL xalphacharp(V)
{
    int ch;
    ch = getchcode(xlgachar());
    xllastarg();
    return (ISUPPER(ch) || ISLOWERA(ch) ? s_true : NIL);
}

/* chrcompare - compare characters */
LOCAL LVAL chrcompare P2C(int, fcn, int, icase)
{
    int ch1,ch2,icmp;
    LVAL arg;

    /* get the characters */
    arg = xlgachar(); ch1 = getchcode(arg);

    /* convert to lowercase if case insensitive */
    if (icase && ISUPPER(ch1))
	ch1 = TOLOWER(ch1);

    /* handle each remaining argument */
    for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {

	/* get the next argument */
	arg = xlgachar(); ch2 = getchcode(arg);

	/* convert to lowercase if case insensitive */
	if (icase && ISUPPER(ch2))
	    ch2 = TOLOWER(ch2);

	/* compare the characters */
	switch (fcn) {
	case '<':	icmp = (ch1 < ch2); break;
	case 'L':	icmp = (ch1 <= ch2); break;
	case '=':	icmp = (ch1 == ch2); break;
	case '#':	icmp = (ch1 != ch2); break;
	case 'G':	icmp = (ch1 >= ch2); break;
	case '>':	icmp = (ch1 > ch2); break;
	}
    }

    /* return the result */
    return (icmp ? s_true : NIL);
}

/* character comparision functions */
LVAL xchrlss(V) { return (chrcompare('<',FALSE)); } /* char< */
LVAL xchrleq(V) { return (chrcompare('L',FALSE)); } /* char<= */
LVAL xchreql(V) { return (chrcompare('=',FALSE)); } /* char= */
LVAL xchrneq(V) { return (chrcompare('#',FALSE)); } /* char/= */
LVAL xchrgeq(V) { return (chrcompare('G',FALSE)); } /* char>= */
LVAL xchrgtr(V) { return (chrcompare('>',FALSE)); } /* char> */

/* character comparision functions (case insensitive) */
LVAL xchrilss(V) { return (chrcompare('<',TRUE)); } /* char-lessp */
LVAL xchrileq(V) { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
LVAL xchrieql(V) { return (chrcompare('=',TRUE)); } /* char-equalp */
LVAL xchrineq(V) { return (chrcompare('#',TRUE)); } /* char-not-equalp */
LVAL xchrigeq(V) { return (chrcompare('G',TRUE)); } /* char-not-lessp */
LVAL xchrigtr(V) { return (chrcompare('>',TRUE)); } /* char-greaterp */

LVAL xmkstring(V)
{
  int n, i;
  char c = ' ';
  LVAL arg, result;

  arg = xlgafixnum();
  n = getfixnum(arg);
  if (n < 0) xlerror("Not a nonnegative integer", arg);
  
  if (xlgetkeyarg(k_initelem, &arg)) {
    if (! charp(arg)) xlbadtype(arg);
    c = getchcode(arg);
  }
  result = newstring(n);
  for (i = 0; i < n; i++)
    setstringch(result, i, c);
  return(result);
}