LOCAL int stringcmp P2C(LVAL, arg1, LVAL, arg2) /* compare two strings for equal */
/* Written by TAA. Compares strings */
/* with embedded nulls */
{
char *s1 = getstring(arg1), *s2 = getstring(arg2);
unsigned l = getslength(arg1);
if (l != getslength(arg2)) return FALSE;
while (l-- > 0) if (*s1++ != *s2++) return FALSE;
return TRUE;
}
/* xlength - return the length of a list or string */
LVAL xlength(void)
{
FIXTYPE n=0;
LVAL arg;
/* get the list or string */
arg = xlgetarg();
xllastarg();
/* find the length of a list */
if (listp(arg))
for (n = 0; consp(arg); n++)
arg = cdr(arg);
/* find the length of a string */
else if (stringp(arg))
n = (FIXTYPE)getslength(arg)-1;
/* find the length of a vector */
else if (vectorp(arg))
n = (FIXTYPE)getsize(arg);
/* otherwise, bad argument type */
else
xlerror("bad argument type",arg);
/* return the length */
return (cvfixnum(n));
}
/* 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);
}
/* 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));
}
/* 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;
}
/* 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);
}
/* xlgetfname - get a filename */
LVAL xlgetfname(V)
{
LVAL name;
/* get the next argument */
name = xlgetarg();
/* get the filename string */
#ifdef FILETABLE
if (streamp(name) && getfile(name) > CONSOLE)
/* "Steal" name from file stream */
name = cvstring(filetab[getfile(name)].tname);
else
#endif
if (symbolp(name))
name = getpname(name);
else if (!stringp(name))
xlbadtype(name);
if (getslength(name) >= FNAMEMAX)
xlerror("file name too long", name);
/* return the name */
return (name);
}
/* cvstring - convert a string to a string node */
LVAL cvstring(char *str)
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = strlen(str) + 1;
val->n_string = stralloc(getslength(val));
strcpy((char *) getstring(val),str);
xlpop();
return (val);
}
/* new_string - allocate and initialize a new string */
LVAL new_string(int size)
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = size;
val->n_string = stralloc(getslength(val));
strcpy((char *) getstring(val),"");
xlpop();
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);
}
/* xmkstrinput - make a string input stream */
LVAL xmkstrinput(void)
{
int start,end,len,i;
unsigned char *str;
LVAL string,val;
/* protect the return value */
xlsave1(val);
/* get the string and length */
string = xlgastring();
str = getstring(string);
len = getslength(string) - 1;
/* get the starting offset */
if (moreargs()) {
val = xlgafixnum();
start = (int)getfixnum(val);
}
else start = 0;
/* get the ending offset */
if (moreargs()) {
val = xlgafixnum();
end = (int)getfixnum(val);
}
else end = len;
xllastarg();
/* check the bounds */
if (start < 0 || start > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
if (end < 0 || end > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
/* make the stream */
val = newustream();
/* copy the substring into the stream */
for (i = start; i < end; ++i)
xlputc(val,str[i]);
/* restore the stack */
xlpop();
/* return the new stream */
return (val);
}
/* 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]));
}
/* 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);
}
/* dmazzoni: was LOCAL void sweep(void) */
void sweep(void)
{
SEGMENT *seg;
LVAL p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0L;
/* add all unmarked nodes */
for (seg = segs; seg; seg = seg->sg_next) {
if (seg == fixseg) /* don't sweep the fixnum segment */
continue;
else if (seg == charseg) /* don't sweep the character segment */
continue;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; --n >= 0; ++p) {
#ifdef DEBUG_MEM
if (xldmem_trace &&
ntype(p) == EXTERN &&
xldmem_trace == getinst(p)) {
printf("sweep: EXTERN node %lx is %smarked, points to %lx\n",
p, (p->n_flags & MARK ? "" : "un"), getinst(p));
}
#endif
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STRING:
if (getstring(p) != NULL) {
total -= (long)getslength(p);
free(getstring(p));
}
break;
case STREAM:
if (getfile(p))
osclose(getfile(p));
break;
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
if (p->n_vsize) {
total -= (long) (p->n_vsize * sizeof(LVAL));
free((void *) p->n_vdata);
}
break;
case EXTERN:
/* printf("GC about to free %x\n", p);
* fflush(stdout);
*/
if (getdesc(p)) { (*(getdesc(p)->free_meth))(getinst(p));
}
break;
}
p->n_type = FREE_NODE;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree += 1L;
}
else
p->n_flags &= ~MARK;
}
}
}