mirror of
https://github.com/cookiengineer/audacity
synced 2025-05-08 15:52:53 +02:00
562 lines
15 KiB
C
562 lines
15 KiB
C
/* xlstr - xlisp string and character built-in functions */
|
|
/* Copyright (c) 1985, by David Michael Betz
|
|
All Rights Reserved
|
|
Permission is granted for unrestricted non-commercial use */
|
|
|
|
/* CHANGE LOG
|
|
* --------------------------------------------------------------------
|
|
* 28Apr03 dm eliminate some compiler warnings
|
|
*/
|
|
|
|
#include "string.h"
|
|
#include "xlisp.h"
|
|
|
|
/* local definitions */
|
|
#define fix(n) cvfixnum((FIXTYPE)(n))
|
|
#define TLEFT 1
|
|
#define TRIGHT 2
|
|
|
|
/* external variables */
|
|
extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
|
|
extern LVAL s_true;
|
|
extern char buf[];
|
|
|
|
/* forward declarations */
|
|
FORWARD LOCAL LVAL strcompare(int fcn, int icase);
|
|
FORWARD LOCAL LVAL chrcompare(int fcn, int icase);
|
|
FORWARD LOCAL LVAL changecase(int fcn, int destructive);
|
|
FORWARD LOCAL LVAL trim(int fcn);
|
|
FORWARD LOCAL void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend);
|
|
FORWARD LOCAL int inbag(int ch, LVAL bag);
|
|
|
|
/* string comparision functions */
|
|
LVAL xstrlss(void) { return (strcompare('<',FALSE)); } /* string< */
|
|
LVAL xstrleq(void) { return (strcompare('L',FALSE)); } /* string<= */
|
|
LVAL xstreql(void) { return (strcompare('=',FALSE)); } /* string= */
|
|
LVAL xstrneq(void) { return (strcompare('#',FALSE)); } /* string/= */
|
|
LVAL xstrgeq(void) { return (strcompare('G',FALSE)); } /* string>= */
|
|
LVAL xstrgtr(void) { return (strcompare('>',FALSE)); } /* string> */
|
|
|
|
/* string comparison functions (not case sensitive) */
|
|
LVAL xstrilss(void) { return (strcompare('<',TRUE)); } /* string-lessp */
|
|
LVAL xstrileq(void) { return (strcompare('L',TRUE)); } /* string-not-greaterp */
|
|
LVAL xstrieql(void) { return (strcompare('=',TRUE)); } /* string-equal */
|
|
LVAL xstrineq(void) { return (strcompare('#',TRUE)); } /* string-not-equal */
|
|
LVAL xstrigeq(void) { return (strcompare('G',TRUE)); } /* string-not-lessp */
|
|
LVAL xstrigtr(void) { return (strcompare('>',TRUE)); } /* string-greaterp */
|
|
|
|
/* strcompare - compare strings */
|
|
LOCAL LVAL strcompare(int fcn, int icase)
|
|
{
|
|
int start1,end1,start2,end2,ch1,ch2;
|
|
unsigned char *p1,*p2;
|
|
LVAL str1,str2;
|
|
|
|
/* get the strings */
|
|
str1 = xlgastring();
|
|
str2 = xlgastring();
|
|
|
|
/* get the substring specifiers */
|
|
getbounds(str1,k_1start,k_1end,&start1,&end1);
|
|
getbounds(str2,k_2start,k_2end,&start2,&end2);
|
|
|
|
/* setup the string pointers */
|
|
p1 = &getstring(str1)[start1];
|
|
p2 = &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; /* Normally shouldn't happen */
|
|
}
|
|
|
|
/* case conversion functions */
|
|
LVAL xupcase(void) { return (changecase('U',FALSE)); }
|
|
LVAL xdowncase(void) { return (changecase('D',FALSE)); }
|
|
|
|
/* destructive case conversion functions */
|
|
LVAL xnupcase(void) { return (changecase('U',TRUE)); }
|
|
LVAL xndowncase(void) { return (changecase('D',TRUE)); }
|
|
|
|
/* changecase - change case */
|
|
LOCAL LVAL changecase(int fcn, int destructive)
|
|
{
|
|
unsigned char *srcp,*dstp;
|
|
int start,end,len,ch,i;
|
|
LVAL src,dst;
|
|
|
|
/* get the string */
|
|
src = xlgastring();
|
|
|
|
/* get the substring specifiers */
|
|
getbounds(src,k_start,k_end,&start,&end);
|
|
len = getslength(src) - 1;
|
|
|
|
/* make a destination string */
|
|
dst = (destructive ? src : new_string(len+1));
|
|
|
|
/* 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;
|
|
}
|
|
*dstp++ = ch;
|
|
}
|
|
*dstp = '\0';
|
|
|
|
/* return the new string */
|
|
return (dst);
|
|
}
|
|
|
|
/* search for string within a string */
|
|
LVAL xstrsearch(void)
|
|
{
|
|
int start,end,pat_len,str_len;
|
|
unsigned char *pat,*str,*patptr,*strptr,*patend;
|
|
LVAL str1,str2;
|
|
|
|
/* get the strings */
|
|
str1 = xlgastring(); /* the pat */
|
|
str2 = xlgastring(); /* the string */
|
|
|
|
/* get the substring specifiers */
|
|
getbounds(str2, k_start, k_end, &start, &end);
|
|
|
|
/* setup the string pointers */
|
|
pat = getstring(str1);
|
|
str = &getstring(str2)[start];
|
|
|
|
pat_len = getslength(str1) - 1;
|
|
str_len = end - start;
|
|
patend = pat + pat_len;
|
|
for (; pat_len <= str_len; str_len--) {
|
|
patptr = pat;
|
|
strptr = str;
|
|
/* two outcomes: (1) no match, goto step (2) match, return */
|
|
while (patptr < patend) {
|
|
if (*patptr++ != *strptr++) goto step;
|
|
}
|
|
/* compute match index */
|
|
return cvfixnum(str - getstring(str2));
|
|
step:
|
|
str++;
|
|
}
|
|
/* no match */
|
|
return NIL;
|
|
}
|
|
|
|
|
|
/* trim functions */
|
|
LVAL xtrim(void) { return (trim(TLEFT|TRIGHT)); }
|
|
LVAL xlefttrim(void) { return (trim(TLEFT)); }
|
|
LVAL xrighttrim(void) { return (trim(TRIGHT)); }
|
|
|
|
/* trim - trim character from a string */
|
|
LOCAL LVAL trim(int fcn)
|
|
{
|
|
unsigned char *leftp,*rightp,*dstp;
|
|
LVAL bag,src,dst;
|
|
|
|
/* get the bag and the string */
|
|
bag = xlgastring();
|
|
src = xlgastring();
|
|
xllastarg();
|
|
|
|
/* setup the string pointers */
|
|
leftp = getstring(src);
|
|
rightp = leftp + getslength(src) - 2;
|
|
|
|
/* 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 = new_string((int)(rightp-leftp+2));
|
|
dstp = getstring(dst);
|
|
|
|
/* copy the source to the destination */
|
|
while (leftp <= rightp)
|
|
*dstp++ = *leftp++;
|
|
*dstp = '\0';
|
|
|
|
/* return the new string */
|
|
return (dst);
|
|
}
|
|
|
|
/* getbounds - get the start and end bounds of a string */
|
|
LOCAL void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend)
|
|
{
|
|
LVAL arg;
|
|
int len;
|
|
|
|
/* get the length of the string */
|
|
len = getslength(str) - 1;
|
|
|
|
/* get the starting index */
|
|
if (xlgkfixnum(skey,&arg)) {
|
|
*pstart = (int)getfixnum(arg);
|
|
if (*pstart < 0 || *pstart > len)
|
|
xlerror("string index out of bounds",arg);
|
|
}
|
|
else
|
|
*pstart = 0;
|
|
|
|
/* get the ending index */
|
|
if (xlgkfixnum(ekey,&arg)) {
|
|
*pend = (int)getfixnum(arg);
|
|
if (*pend < 0 || *pend > 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));
|
|
}
|
|
|
|
/* inbag - test if a character is in a bag */
|
|
LOCAL int inbag(int ch, LVAL bag)
|
|
{
|
|
unsigned char *p;
|
|
for (p = getstring(bag); *p != '\0'; ++p)
|
|
if (*p == ch)
|
|
return (TRUE);
|
|
return (FALSE);
|
|
}
|
|
|
|
/* xstrcat - concatenate a bunch of strings */
|
|
LVAL xstrcat(void)
|
|
{
|
|
LVAL *saveargv,tmp,val;
|
|
unsigned char *str;
|
|
int saveargc,len;
|
|
|
|
/* save the argument list */
|
|
saveargv = xlargv;
|
|
saveargc = xlargc;
|
|
|
|
/* find the length of the new string */
|
|
for (len = 0; moreargs(); ) {
|
|
tmp = xlgastring();
|
|
len += (int)getslength(tmp) - 1;
|
|
}
|
|
|
|
/* create the result string */
|
|
val = new_string(len+1);
|
|
str = getstring(val);
|
|
|
|
/* restore the argument list */
|
|
xlargv = saveargv;
|
|
xlargc = saveargc;
|
|
|
|
/* combine the strings */
|
|
for (*str = '\0'; moreargs(); ) {
|
|
tmp = nextarg();
|
|
strcat((char *) str, (char *) getstring(tmp));
|
|
}
|
|
|
|
/* return the new string */
|
|
return (val);
|
|
}
|
|
|
|
/* xsubseq - return a subsequence */
|
|
LVAL xsubseq(void)
|
|
{
|
|
unsigned char *srcp,*dstp;
|
|
int start,end,len;
|
|
LVAL src,dst;
|
|
|
|
/* get string and starting and ending positions */
|
|
src = xlgastring();
|
|
|
|
/* get the starting position */
|
|
dst = xlgafixnum(); start = (int)getfixnum(dst);
|
|
if (start < 0 || start > getslength(src) - 1)
|
|
xlerror("string index out of bounds",dst);
|
|
|
|
/* get the ending position */
|
|
if (moreargs()) {
|
|
dst = xlgafixnum(); end = (int)getfixnum(dst);
|
|
if (end < 0 || end > getslength(src) - 1)
|
|
xlerror("string index out of bounds",dst);
|
|
}
|
|
else
|
|
end = getslength(src) - 1;
|
|
xllastarg();
|
|
|
|
/* setup the source pointer */
|
|
srcp = getstring(src) + start;
|
|
len = end - start;
|
|
|
|
/* make a destination string and setup the pointer */
|
|
dst = new_string(len+1);
|
|
dstp = getstring(dst);
|
|
|
|
/* copy the source to the destination */
|
|
while (--len >= 0)
|
|
*dstp++ = *srcp++;
|
|
*dstp = '\0';
|
|
|
|
/* return the substring */
|
|
return (dst);
|
|
}
|
|
|
|
/* xstring - return a string consisting of a single character */
|
|
LVAL xstring(void)
|
|
{
|
|
LVAL arg;
|
|
|
|
/* get the argument */
|
|
arg = xlgetarg();
|
|
xllastarg();
|
|
|
|
/* make sure its not NIL */
|
|
if (null(arg))
|
|
xlbadtype(arg);
|
|
|
|
/* check the argument type */
|
|
switch (ntype(arg)) {
|
|
case STRING:
|
|
return (arg);
|
|
case SYMBOL:
|
|
return (getpname(arg));
|
|
case CHAR:
|
|
buf[0] = (int)getchcode(arg);
|
|
buf[1] = '\0';
|
|
return (cvstring(buf));
|
|
case FIXNUM:
|
|
buf[0] = getfixnum(arg);
|
|
buf[1] = '\0';
|
|
return (cvstring(buf));
|
|
default:
|
|
xlbadtype(arg);
|
|
return NIL; /* never happens */
|
|
}
|
|
}
|
|
|
|
/* xchar - extract a character from a string */
|
|
LVAL xchar(void)
|
|
{
|
|
LVAL str,num;
|
|
int n;
|
|
|
|
/* get the string and the index */
|
|
str = xlgastring();
|
|
num = xlgafixnum();
|
|
xllastarg();
|
|
|
|
/* range check the index */
|
|
if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
|
|
xlerror("index out of range",num);
|
|
|
|
/* return the character */
|
|
return (cvchar(getstring(str)[n]));
|
|
}
|
|
|
|
/* xcharint - convert an integer to a character */
|
|
LVAL xcharint(void)
|
|
{
|
|
LVAL arg;
|
|
arg = xlgachar();
|
|
xllastarg();
|
|
return (cvfixnum((FIXTYPE)getchcode(arg)));
|
|
}
|
|
|
|
/* xintchar - convert a character to an integer */
|
|
LVAL xintchar(void)
|
|
{
|
|
LVAL arg;
|
|
arg = xlgafixnum();
|
|
xllastarg();
|
|
return (cvchar((int)getfixnum(arg)));
|
|
}
|
|
|
|
/* xuppercasep - built-in function 'upper-case-p' */
|
|
LVAL xuppercasep(void)
|
|
{
|
|
int ch;
|
|
ch = getchcode(xlgachar());
|
|
xllastarg();
|
|
return (isupper(ch) ? s_true : NIL);
|
|
}
|
|
|
|
/* xlowercasep - built-in function 'lower-case-p' */
|
|
LVAL xlowercasep(void)
|
|
{
|
|
int ch;
|
|
ch = getchcode(xlgachar());
|
|
xllastarg();
|
|
return (islower(ch) ? s_true : NIL);
|
|
}
|
|
|
|
/* xbothcasep - built-in function 'both-case-p' */
|
|
LVAL xbothcasep(void)
|
|
{
|
|
int ch;
|
|
ch = getchcode(xlgachar());
|
|
xllastarg();
|
|
return (isupper(ch) || islower(ch) ? s_true : NIL);
|
|
}
|
|
|
|
/* xdigitp - built-in function 'digit-char-p' */
|
|
LVAL xdigitp(void)
|
|
{
|
|
int ch;
|
|
ch = getchcode(xlgachar());
|
|
xllastarg();
|
|
return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
|
|
}
|
|
|
|
/* xcharcode - built-in function 'char-code' */
|
|
LVAL xcharcode(void)
|
|
{
|
|
int ch;
|
|
ch = getchcode(xlgachar());
|
|
xllastarg();
|
|
return (cvfixnum((FIXTYPE)ch));
|
|
}
|
|
|
|
/* xcodechar - built-in function 'code-char' */
|
|
LVAL xcodechar(void)
|
|
{
|
|
LVAL arg;
|
|
int ch;
|
|
arg = xlgafixnum(); ch = getfixnum(arg);
|
|
xllastarg();
|
|
return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
|
|
}
|
|
|
|
/* xchupcase - built-in function 'char-upcase' */
|
|
LVAL xchupcase(void)
|
|
{
|
|
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(void)
|
|
{
|
|
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(void)
|
|
{
|
|
LVAL arg;
|
|
int n;
|
|
arg = xlgafixnum(); n = getfixnum(arg);
|
|
xllastarg();
|
|
return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
|
|
}
|
|
|
|
/* xalphanumericp - built-in function 'alphanumericp' */
|
|
LVAL xalphanumericp(void)
|
|
{
|
|
int ch;
|
|
ch = getchcode(xlgachar());
|
|
xllastarg();
|
|
return (isupper(ch) || islower(ch) || isdigit(ch) ? s_true : NIL);
|
|
}
|
|
|
|
/* character comparision functions */
|
|
LVAL xchrlss(void) { return (chrcompare('<',FALSE)); } /* char< */
|
|
LVAL xchrleq(void) { return (chrcompare('L',FALSE)); } /* char<= */
|
|
LVAL xchreql(void) { return (chrcompare('=',FALSE)); } /* char= */
|
|
LVAL xchrneq(void) { return (chrcompare('#',FALSE)); } /* char/= */
|
|
LVAL xchrgeq(void) { return (chrcompare('G',FALSE)); } /* char>= */
|
|
LVAL xchrgtr(void) { return (chrcompare('>',FALSE)); } /* char> */
|
|
|
|
/* character comparision functions (case insensitive) */
|
|
LVAL xchrilss(void) { return (chrcompare('<',TRUE)); } /* char-lessp */
|
|
LVAL xchrileq(void) { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
|
|
LVAL xchrieql(void) { return (chrcompare('=',TRUE)); } /* char-equal */
|
|
LVAL xchrineq(void) { return (chrcompare('#',TRUE)); } /* char-not-equal */
|
|
LVAL xchrigeq(void) { return (chrcompare('G',TRUE)); } /* char-not-lessp */
|
|
LVAL xchrigtr(void) { return (chrcompare('>',TRUE)); } /* char-greaterp */
|
|
|
|
/* chrcompare - compare characters */
|
|
LOCAL LVAL chrcompare(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);
|
|
}
|
|
|