main(int argc, char **argv)
{
CONTEXT cntxt;
NODE *expr;
int i;
osinit("XLISP version 1.6, Copyright (c) 1985, by David Betz");
xlbegin(&cntxt,64|8,(NODE *) 1);
if (setjmp(cntxt.c_jmpbuf)) {
printf("fatal initialization error\n");
osfinish();
exit(1);
}
xlinit();
xlend(&cntxt);
xlbegin(&cntxt,64|8,true);
if (setjmp(cntxt.c_jmpbuf) == 0)
xlload("init.lsp",0,0);
if (setjmp(cntxt.c_jmpbuf) == 0)
for (i = 1; i < argc; i++)
if (!xlload(argv[i],1,0))
xlfail("can't load file");
xlsave(&expr,(NODE **)0);
while (1) {
if (i = setjmp(cntxt.c_jmpbuf)) {
if (i == 64)
stdputstr("[ back to the top level ]\n");
((s_evalhook)->n_info.n_xsym.xsy_value = ((NODE *)0));
((s_applyhook)->n_info.n_xsym.xsy_value = ((NODE *)0));
xldebug = 0;
xlflush();
}
if (!xlread(((s_stdin)->n_info.n_xsym.xsy_value),&expr,0))
break;
expr = xleval(expr);
stdprint(expr);
}
xlend(&cntxt);
osfinish ();
exit (0);
}
nyx_rval nyx_eval_expression(const char *expr_string)
{
LVAL expr = NULL;
nyx_expr_string = expr_string;
nyx_expr_len = strlen(nyx_expr_string);
nyx_expr_pos = 0;
nyx_result = NULL;
nyx_parse_error_flag = 0;
xlprot1(expr);
/* setup the error return */
xlbegin(&nyx_cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
if (setjmp(nyx_cntxt.c_jmpbuf))
goto finish;
while(nyx_expr_pos < nyx_expr_len) {
expr = NULL;
/* read an expression */
if (!xlread(getvalue(s_stdin), &expr, FALSE))
break;
#if 0
/* save the input expression (so the user can refer to it
as +, ++, or +++) */
xlrdsave(expr);
#endif
/* evaluate the expression */
nyx_result = xleval(expr);
}
xlflush();
finish:
xlend(&nyx_cntxt);
xlpop(); /* unprotect expr */
/* reset the globals to their initial state */
obarray = nyx_old_obarray;
setvalue(xlenter("S"), NULL);
gc();
return nyx_get_type(nyx_result);
}
/* evmethod - evaluate a method */
LOCAL LVAL evmethod(LVAL obj, LVAL msgcls, LVAL method)
{
LVAL oldenv,oldfenv,cptr,name,val=NULL;
XLCONTEXT cntxt;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
/* create an 'object' stack entry and a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = cons(cons(obj,msgcls),closure_getenv(method));
xlenv = xlframe(xlenv);
xlfenv = getfenv(method);
/* bind the formal parameters */
xlabind(method,xlargc,xlargv);
/* setup the implicit block */
if ((name = getname(method)))
xlbegin(&cntxt,CF_RETURN,name);
/* execute the block */
if (name && _setjmp(cntxt.c_jmpbuf))
val = xlvalue;
else
for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
val = xleval(car(cptr));
/* finish the block context */
if (name)
xlend(&cntxt);
/* restore the environment */
xlenv = oldenv;
xlfenv = oldfenv;
/* restore the stack */
xlpopn(3);
/* return the result value */
return (val);
}
/* evfun - evaluate a function */
LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv)
{
LVAL oldenv,oldfenv,cptr,name,val;
XLCONTEXT cntxt;
/* protect some pointers */
xlstkcheck(4);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
xlprotect(fun); /* (RBD) Otherwise, fun is unprotected */
/* create a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = xlframe(closure_getenv(fun));
xlfenv = getfenv(fun);
/* bind the formal parameters */
xlabind(fun,argc,argv);
/* setup the implicit block */
if (name = getname(fun))
xlbegin(&cntxt,CF_RETURN,name);
/* execute the block */
if (name && setjmp(cntxt.c_jmpbuf))
val = xlvalue;
else
for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
val = xleval(car(cptr));
/* finish the block context */
if (name)
xlend(&cntxt);
/* restore the environment */
xlenv = oldenv;
xlfenv = oldfenv;
/* restore the stack */
xlpopn(4);
/* return the result value */
return (val);
}
static int breakloop(char *hdr, char *cmsg, char *emsg, NODE *arg, int cflag)
{
NODE ***oldstk,*expr,*val;
CONTEXT cntxt;
int type;
xlerrprint(hdr,cmsg,emsg,arg);
xlflush();
if (((s_tracenable)->n_info.n_xsym.xsy_value)) {
val = ((s_tlimit)->n_info.n_xsym.xsy_value);
xlbaktrace(((val) && (val)->n_type == 5) ? (int)((val)->n_info.n_xint.xi_int) : -1);
}
oldstk = xlsave(&expr,(NODE **)0);
xldebug++;
xlbegin(&cntxt,8|16|32,true);
for (type = 0; type == 0; ) {
if (type = setjmp(cntxt.c_jmpbuf))
switch (type) {
case 8:
xlflush();
type = 0;
continue;
case 16:
continue;
case 32:
if (cflag) {
stdputstr("[ continue from break loop ]\n");
continue;
}
else xlabort("this error can't be continued");
}
if (!xlread(((s_stdin)->n_info.n_xsym.xsy_value),&expr,0)) {
type = 16;
break;
}
expr = xleval(expr);
xlprint(((s_stdout)->n_info.n_xsym.xsy_value),expr,1);
xlterpri(((s_stdout)->n_info.n_xsym.xsy_value));
}
xlend(&cntxt);
xldebug--;
xlstack = oldstk;
if (type == 16) {
stdputstr("[ abort to previous level ]\n");
xlsignal(0,(NODE *)0);
}
}
void nyx_get_audio(nyx_audio_callback callback, void *userdata)
{
sample_block_type block;
sound_type snd;
sound_type *snds;
float *buffer;
long bufferlen;
long *totals;
long cnt;
int result = 0;
int num_channels;
int ch, i;
if (nyx_get_type(nyx_result) != nyx_audio)
return;
num_channels = nyx_get_audio_num_channels();
snds = (sound_type *)malloc(num_channels * sizeof(sound_type));
totals = (long *)malloc(num_channels * sizeof(long));
/* setup the error return */
xlbegin(&nyx_cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
if (setjmp(nyx_cntxt.c_jmpbuf))
goto finish;
for(ch=0; ch<num_channels; ch++) {
if (num_channels == 1)
snd = getsound(nyx_result);
else
snd = getsound(getelement(nyx_result, ch));
snds[ch] = snd;
totals[ch] = 0;
}
buffer = NULL;
bufferlen = 0;
while(result==0) {
for(ch=0; ch<num_channels; ch++) {
snd = snds[ch];
cnt = 0;
block = snd->get_next(snd, &cnt);
if (block == zero_block || cnt == 0) {
result = -1;
break;
}
/* copy the data to a temporary buffer and scale it
by the appropriate scale factor */
if (cnt > bufferlen) {
if (buffer)
free(buffer);
buffer = (float *)malloc(cnt * sizeof(float));
bufferlen = cnt;
}
memcpy(buffer, block->samples, cnt * sizeof(float));
for(i=0; i<cnt; i++)
buffer[i] *= snd->scale;
result = callback(buffer, ch,
totals[ch], cnt, userdata);
if (result == 0)
totals[ch] += cnt;
}
}
finish:
if (buffer)
free(buffer);
free(snds);
free(totals);
xlend(&nyx_cntxt);
}
/* xlload - load a file of xlisp expressions */
int xlload(char *fname, int vflag, int pflag)
{
char fullname[STRMAX+1];
char *ptr;
LVAL fptr,expr;
XLCONTEXT cntxt;
FILE *fp;
int sts;
/* protect some pointers */
xlstkcheck(2);
xlsave(fptr);
xlsave(expr);
/* space for copy + extension? */
if (strlen(fname) > STRMAX - 4) goto toolong;
strcpy(fullname,fname);
#ifdef WINDOWS
#ifdef WINGUI
if (strcmp(fullname, "*") == 0) {
if (sfn_valid) {
strcpy(fullname, save_file_name);
} else {
strcpy(fullname, "*.*");
}
}
if (strcmp(fullname, "*.*") == 0) {
char *name = getfilename(NULL, "lsp", "r", "Load file");
if (name) {
strcpy(fullname, name);
strcpy(save_file_name, name);
sfn_valid = TRUE;
} else {
xlpopn(2);
return FALSE;
}
}
#endif
/* replace "/" with "\" so that (current-path) will work */
for (ptr = fullname; *ptr; ptr++) {
if (*ptr == '/') *ptr = '\\';
}
#endif
/* default the extension if there is room */
if (needsextension(fullname)) {
strcat(fullname,".lsp");
}
/* allocate a file node */
fptr = cvfile(NULL);
/* open the file */
if ((fp = osaopen(fullname,"r")) == NULL) {
#ifdef UNIX
if (fname[0] != '/') {
char *paths = getenv("XLISPPATH");
if (!paths || !*paths) {
char msg[512];
sprintf(msg, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the environment.",
"If you are using Nyquist, probably you should cd to the",
"nyquist directory and type:",
" setenv XLISPPATH `pwd`/runtime:`pwd`/lib",
"or set XLISPPATH in your .login or .cshrc file.");
errputstr(msg);
}
/* make sure we got paths, and the list is not empty */
while (paths && *paths) {
char *ptr = fullname;
/* skip over separator */
while (*paths == ':') paths++;
/* scan next directory into fullname */
while (*paths && (*paths != ':')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *paths++;
}
/* add "/" if needed */
if (ptr[-1] != '/') *ptr++ = '/';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef WINDOWS
/* is this a relative path? */
if (fname[0] != '\\' && (strlen(fname) < 2 || fname[1] != ':')) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
get_xlisp_path(paths, paths_max);
/* make sure we got paths, and the list is not empty */
if (!*p) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the Registry.",
"You should follow the installation instructions. Enter an",
"empty string if you really want no search path.");
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add "\" if needed */
if (ptr[-1] != '\\') *ptr++ = '\\';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef MACINTOSH
/* is this a relative path? I don't know how to do this
* correctly, so we'll assume it's relative if there is no
* embedded colon (:)
*/
if (strchr(fname, ':') == NULL) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
int prefs_found = false;
get_xlisp_path(paths, paths_max, &prefs_found);
/* make sure we got paths, and the list is not empty */
if (!*p) {
if (prefs_found) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in XLisp Preferences.",
"You should probably delete XLisp Preferences and let XLisp",
"create a new one for you.");
} else {
sprintf(paths, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLisp Preferences.",
"You should manually locate and load the file runtime:init.lsp",
"Nyquist will create an XLisp Preferences file to automatically",
"find the file next time. You may edit XLisp Preferences to add",
"additional search paths, using a comma as separator.");
}
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add ":" if needed */
if (ptr[-1] != ':') *ptr++ = ':';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
xlpopn(2);
return (FALSE);
}
gotfile:
#ifdef MACINTOSH
/* We found the file ok, call setup_preferences to create
* XLisp Preferences file (this only happens if previous
* attempt to find the file failed
*/
setup_preferences(fullname);
#endif
setfile(fptr,fp);
setvalue(s_loadingfiles, cons(fptr, getvalue(s_loadingfiles)));
setvalue(s_loadingfiles, cons(cvstring(fullname), getvalue(s_loadingfiles)));
/* print the information line */
if (vflag)
{ sprintf(buf,"; loading \"%s\"\n",fullname); stdputstr(buf); }
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR,s_true);
if (setjmp(cntxt.c_jmpbuf))
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* close the file */
osclose(getfile(fptr));
setfile(fptr,NULL);
if (consp(getvalue(s_loadingfiles)) &&
consp(cdr(getvalue(s_loadingfiles))) &&
car(cdr(getvalue(s_loadingfiles))) == fptr) {
setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
}
/* restore the stack */
xlpopn(2);
/* return status */
return (sts);
toolong:
xlcerror("ignore file", "file name too long", NIL);
xlpopn(2);
return FALSE;
}