/* 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);
}
syntax highlighted by Code2HTML, v. 0.9.1