/* 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;
}
/* 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 */
}
/* xcerror - special form 'cerror' */
LVAL xcerror(void)
{
LVAL cmsg,emsg,arg;
/* get the correction message, the error message, and the argument */
cmsg = xlgastring();
emsg = xlgastring();
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* signal the error */
xlcerror((char *) getstring(cmsg), (char *) getstring(emsg),arg);
/* return nil */
return (NIL);
}
LVAL xssystem()
{
char *cmd;
int status;
LVAL stream = NIL;
FILE *p;
int ch;
cmd = (char *) getstring(xlgastring());
if (moreargs()) {
stream = xlgetarg();
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
}
if (stream == NIL) {
status = system(cmd);
if (status == 127) xlfail("shell could not execute command");
}
else {
if ((p = popen(cmd, "r")) == NULL)
xlfail("could not execute command");
while ((ch = getc(p)) != EOF) xlputc(stream, ch);
status = pclose(p);
}
return(cvfixnum((FIXTYPE) status));
}
LVAL xlc_snd_save(void)
{
LVAL arg1 = xlgetarg();
long arg2 = getfixnum(xlgafixnum());
unsigned char * arg3 = getstring(xlgastring());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
long arg7 = getfixnum(xlgafixnum());
double arg8 = 0.0;
long arg9 = 0;
double arg10 = 0.0;
LVAL arg11 = xlgetarg();
double result;
xllastarg();
result = sound_save(arg1, arg2, arg3, arg4, arg5, arg6, arg7, &arg8, &arg9, &arg10, arg11);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg8); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg9); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg10);
}
return cvflonum(result);
}
/* 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);
}
/* 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);
}
/******************************************************************************
* Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr
*
* syntax: (system <command line>)
* <command line> is a string to be sent to the subshell (sh).
*
* Returns T if the command executed succesfully, otherwise returns the
* integer shell exit status for the command.
*
* Added to XLISP by Niels Mayer
******************************************************************************/
LVAL Prim_SYSTEM()
{
extern LVAL true;
extern int sys_nerr;
extern char *sys_errlist[];
extern int errno;
LVAL command;
int result;
char temptext[1024];
/* get shell command */
command = xlgastring();
xllastarg();
/* run the process */
result = system((char *) getstring(command));
if (result == -1) { /* if a system error has occured */
if (errno < sys_nerr)
(void) sprintf(temptext, "Error in system(3S): %s\n", sys_errlist[errno]);
else
(void) strcpy(temptext, "Error in system(3S): unknown error\n");
xlfail(temptext);
}
/* return T if success (exit status 0), else return exit status */
return (result ? cvfixnum(result) : true);
}
/* Added by Ning Hu May.2001
xsetdir - set current directory of the process */
LVAL xsetdir() {
TCHAR ssCurDir[MAX_PATH], szCurDir[MAX_PATH];
int verbose = TRUE;
strcpy(ssCurDir, getstring(xlgastring()));
if (moreargs()) {
verbose = (xlgetarg() != NIL);
}
xllastarg();
if (ok_to_open(ssCurDir, "r")) {
if (SetCurrentDirectory(ssCurDir)) {
if (GetCurrentDirectory(
sizeof(szCurDir)/sizeof(TCHAR), szCurDir)) {
return cvstring(szCurDir);
/* create the result string
stdputstr("Current Directory: ");
stdputstr(szCurDir);
stdputstr("\n"); */
}
}
}
if (verbose) stdputstr("Directory Setting Error\n");
/* return nil on error*/
return NIL;
}
/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
/* xfind_in_xlisp_path -- search XLISPPATH for file, return full path */
LVAL xfind_in_xlisp_path()
{
LVAL string = xlgastring();
const char *path = (const char *) getstring(string);
xllastarg();
path = find_in_xlisp_path(path);
return (path ? cvstring(path) : NULL);
}
/* xsystem - execute a system command */
LVAL xsystem()
{
if (moreargs()) {
unsigned char *cmd;
cmd = (unsigned char *)getstring(xlgastring());
fprintf(stderr, "Will not execute system command: %s\n", cmd);
}
return s_true;
}
/* SHLIB-OPEN path */
LVAL xshlibopen()
{
char *name;
void *handle;
name = getstring(xlgastring());
xllastarg();
if ((handle = dlopen(name, RTLD_NOW)) == NULL)
shlib_error();
return newnatptr(handle, NIL);
}
/* makesymbol - make a new symbol */
LOCAL LVAL makesymbol(int iflag)
{
LVAL pname;
/* get the print name of the symbol to intern */
pname = xlgastring();
xllastarg();
/* make the symbol */
return (iflag ? xlenter((char *) getstring(pname))
: xlmakesym((char *) getstring(pname)));
}
/* xerror - special form 'error' */
LVAL xerror(void)
{
LVAL emsg,arg;
/* get the error message and the argument */
emsg = xlgastring();
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* signal the error */
xlerror((char *) getstring(emsg),arg);
return NIL; /* won't ever happen */
}
LVAL xsopen_resfile()
{
char *name;
int fn;
name = (char *) getstring(xlgastring());
xllastarg();
CtoPstr(name);
fn = OpenResFile(name);
PtoCstr(name);
return((fn >= 0) ? cvfixnum((FIXTYPE) fn) : NIL);
}
/* :ISNEW Method */
LVAL xsitem_isnew(V)
{
LVAL item, title, value;
item = xlgaobject();
title = xlgastring();
set_item_ivar('T', item, title);
object_isnew(item);
if (xlgetkeyarg(sk_enabled, &value)) set_item_ivar('E', item, value);
else set_item_ivar('E', item, s_true);
return(NIL); /* to keep compilers happy - L. Tierney */
}
LVAL xsmenu_title(V)
{
LVAL menu, title;
menu = xlgaobject();
if (moreargs()) {
title = xlgastring();
if (strlen(getstring(title)) == 0)
xlerror("title is too short", title);
if (StMObAllocated(menu))
xlfail("can't change title of an allocated menu");
set_slot_value(menu, s_title, title);
}
return(slot_value(menu, s_title));
}
/* 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);
}
/* xbreak - special form 'break' */
LVAL xbreak(void)
{
LVAL emsg,arg;
/* get the error message */
emsg = (moreargs() ? xlgastring() : NIL);
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* enter the break loop */
xlbreak((emsg ? (char *) getstring(emsg) : "**BREAK**"),arg);
/* return nil */
return (NIL);
}
/* 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);
}
/* :ISNEW Method */
LVAL xsmenu_isnew(V)
{
LVAL menu, title;
menu = xlgaobject();
title = xlgastring();
xllastarg();
if (strlen(getstring(title)) == 0) xlerror("title is too short", title);
object_isnew(menu);
set_slot_value(menu, s_title, title);
set_slot_value(menu, s_enabled, s_true);
return(menu);
}
/* SHLIB-SYMADDR lib name &optional error */
LVAL xshlibsymaddr()
{
void *val;
LVAL lib = xlganatptr();
void *handle = getnpaddr(lib);
char *name = getstring(xlgastring());
int err = moreargs() ? null(xlgetarg()) : TRUE;
xllastarg();
if ((val = dlsym(handle, name)) == NULL) {
if (err)
shlib_error();
else
return NIL;
}
return newnatptr(val, lib);
}
/* 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]));
}
LVAL xswindow_title(V)
{
IVIEW_WINDOW w;
LVAL object, title;
char *str;
object = xlgaobject();
w = (IVIEW_WINDOW) GETWINDOWADDRESS(object);
if (moreargs()) {
title = xlgastring();
set_slot_value(object, s_title, title);
if (! IVIEW_WINDOW_NULL(w)) {
str = (char *) getstring(title);
StWSetTitle(w, str);
}
}
return(slot_value(object, s_title));
}
/******************************************************************************
* (FSCANF-FLONUM <stream> <scanf-format>)
* This routine calls fscanf(3s) on a <stream> that was previously openend
* via open or popen. It will not work on an USTREAM.
* <scanf-format> is a format string containing a single conversion
* directive that will result in an FLONUM valued conversion.
* %e %f or %g are valid conversion specifiers for this routine.
*
* WARNING: specifying a <scanf-format> that will result in the conversion
* of a result larger than sizeof(float) will result in corrupted memory and
* core dumps.
*
* This routine will return a FLONUM if fscanf() returns 1 (i.e. if
* the one expected conversion has succeeded. It will return NIL if the
* conversion wasn't successful, or if EOF was reached.
******************************************************************************/
LVAL Prim_FSCANF_FLONUM()
{
LVAL lval_stream;
char* fmt;
FILE * fp;
float result;
lval_stream = xlgastream();
if (getfile(lval_stream) == NULL)
xlerror("File not opened.", lval_stream);
fmt = (char *) getstring(xlgastring());
xllastarg();
/* if scanf returns result <1 then an error or eof occured. */
if (fscanf(getfile(lval_stream), fmt, &result) < 1)
return (NIL);
else
return (cvflonum((FLOTYPE) result));
}
/******************************************************************************
* (FSCANF-FIXNUM <stream> <scanf-format>)
* This routine calls fscanf(3s) on a <stream> that was previously openend
* via open or popen. It will not work on an USTREAM.
* <scanf-format> is a format string containing a single conversion
* directive that will result in an integer valued conversion.
* %d, %u, %o, %x, %ld, %lu, %lo and %lx style conversions
* are acceptable for this routine.
* WARNING: specifying a <scanf-format> that will result in the conversion
* of a result larger than sizeof(long) will result in corrupted memory and
* core dumps.
*
* This routine will return an FIXNUM if fscanf() returns 1 (i.e. if
* the one expected conversion has succeeded. It will return NIL if the
* conversion wasn't successful, or if EOF was reached.
******************************************************************************/
LVAL Prim_FSCANF_FIXNUM()
{
LVAL lval_stream;
char* fmt;
long result;
lval_stream = xlgastream();
if (getfile(lval_stream) == NULL)
xlerror("File not opened.", lval_stream);
fmt = (char *) getstring(xlgastring());
xllastarg();
result = 0L; /* clear it out hibits incase short is written */
/* if scanf returns result <1 then an error or eof occured. */
if (fscanf(getfile(lval_stream), fmt, &result) < 1)
return (NIL);
else
return (cvfixnum((FIXTYPE) result));
}
LVAL xlc_snd_read(void)
{
unsigned char * arg1 = getstring(xlgastring());
double arg2 = testarg2(xlgaanynum());
double arg3 = testarg2(xlgaanynum());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
long arg7 = getfixnum(xlgafixnum());
long arg8 = getfixnum(xlgafixnum());
double arg9 = testarg2(xlgaanynum());
double arg10 = testarg2(xlgaanynum());
long arg11 = 0;
long arg12 = 0;
LVAL result;
xllastarg();
xlprot1(result);
result = snd_make_read(arg1, arg2, arg3, &arg4, &arg5, &arg6, &arg7, &arg8, &arg9, &arg10, &arg11, &arg12);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg4); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg5); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg6); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg7); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg8); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg9); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg10); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg11); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg12);
}
xlpop();
return (result);
}
LVAL Native_Bugs()
{
LVAL pXModule;
char *sName;
pXModule = xlgastring();
sName = (char *) getstring(pXModule);
if (strcmp(sName, "talk") == 0)
TALK_BUGS = TALK_BUGS ? FALSE : TRUE;
else if (strcmp(sName, "nancy") == 0)
NANCY_BUGS = NANCY_BUGS ? FALSE : TRUE;
else if (strcmp(sName, "shell") == 0)
SHELL_BUGS = SHELL_BUGS ? FALSE : TRUE;
return(true);
} /* Native_Bugs */
/* xsetdir -- set current directory of the process */
LVAL xsetdir()
{
char *dir = (char *)getstring(xlgastring());
int result;
LVAL cwd = NULL;
xllastarg();
result = chdir(dir);
if (result) {
perror("SETDIR");
}
dir = getcwd(NULL, 1000);
if (dir) {
cwd = cvstring(dir);
free(dir);
}
return cwd;
}