/* evform - evaluate a form */
LOCAL NODE *evform(NODE *expr)
{
NODE ***oldstk,*fun __HEAPIFY,*args __HEAPIFY,*env,*val,*type;
val = 0; //BUG: uninitialized variable is used if xlfail returns
/* create a stack frame */
oldstk = xlsave2(&fun,&args);
/* get the function and the argument list */
fun = car(expr);
args = cdr(expr);
/* evaluate the first expression */
if ((fun = xleval(fun)) == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun) || fsubrp(fun)) {
if (subrp(fun))
args = xlevlist(args);
val = (*getsubr(fun))(args);
}
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if ((type = car(fun)) == s_lambda) {
args = xlevlist(args);
val = evfun(fun,args,env);
}
else if (type == s_macro) {
args = evfun(fun,args,env);
val = xleval(args);
}
else
xlfail("bad function type");
}
else if (objectp(fun))
val = xlsend(fun,args);
else
xlfail("bad function");
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* evpushargs - evaluate and push a list of arguments */
LOCAL int evpushargs(LVAL fun, LVAL args)
{
LVAL *newfp;
int argc;
/* protect the argument list */
xlprot1(args);
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL); /* will be argc */
/* evaluate and push each argument */
for (argc = 0; consp(args); args = cdr(args), ++argc)
pusharg(xleval(car(args)));
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* restore the stack */
xlpop();
/* return the number of arguments */
return (argc);
}
NODE *xlevarg(NODE **pargs)
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,(NODE **)0);
val = xlarg(pargs);
val = xleval(val);
xlstack = oldstk;
return (val);
}
void fromobject__fetch(register fromobject_susp_type susp, snd_list_type snd_list)
{
int cnt = 0; /* how many samples computed */
int togo;
int n;
sample_block_type out;
register sample_block_values_type out_ptr;
register sample_block_values_type out_ptr_reg;
register boolean done_reg;
register LVAL src_reg;
falloc_sample_block(out, "fromobject__fetch");
out_ptr = out->samples;
snd_list->block = out;
while (cnt < max_sample_block_len) { /* outer loop */
/* first compute how many samples to generate in inner loop: */
/* don't overflow the output sample block: */
togo = max_sample_block_len - cnt;
if (susp->done) {
togo = 0; /* indicate termination */
break; /* we're done */
}
n = togo;
done_reg = susp->done;
src_reg = susp->src;
out_ptr_reg = out_ptr;
if (n) do { /* the inner sample computation loop */
LVAL rslt = xleval(cons(s_send, cons(src_reg,
consa(s_next))));
if (floatp(rslt)) {
*out_ptr_reg++ = (sample_type) getflonum(rslt);
} else {
done_reg = true;
/* adjust togo to what it should have been */
break;
};
} while (--n); /* inner loop */
togo -= n;
susp->done = done_reg;
out_ptr += togo;
cnt += togo;
} /* outer loop */
/* test for termination */
if (togo == 0 && cnt == 0) {
snd_list_terminate(snd_list);
} else {
snd_list->block_len = cnt;
susp->susp.current += cnt;
}
} /* fromobject__fetch */
/* xeval - the built-in function 'eval' */
LVAL xeval(void)
{
LVAL expr;
/* get the expression to evaluate */
expr = xlgetarg();
xllastarg();
/* evaluate the expression */
return (xleval(expr));
}
double sound_max(LVAL snd_expr, long n)
{
LVAL s_as_lval;
sound_type s = NULL;
long blocklen;
sample_block_values_type sbufp;
register double maximum = 0;
s_as_lval = xleval(snd_expr);
/* BE CAREFUL - DO NOT ALLOW GC TO RUN WHILE LVAL IS UNPROTECTED */
if (exttypep(s_as_lval, a_sound)) {
/* if snd_expr was simply a symbol, then s now points to
a shared sound_node. If we read samples from it, then
the sound bound to the symbol will be destroyed, so
copy it first. If snd_expr was a real expression that
computed a new value, then the next garbage collection
will reclaim the sound_node. We need to make the new
sound reachable by the garbage collector to that any
lisp data reachable from the sound do not get collected.
To make the sound reachable, we need to allocate a node,
and the GC might run, so we need to protect the OLD s
but then make it unreachable.
We will let the GC collect the sound in the end.
*/
xlprot1(s_as_lval);
s = sound_copy(getsound(s_as_lval));
s_as_lval = cvsound(s); /* destroys only ref. to original */
/* printf("sound_max: copy is %x, lval %x\n", s, s_as_lval); */
while (n > 0) {
long togo, j;
sample_block_type sampblock =
sound_get_next(s, &blocklen);
if (sampblock == zero_block || blocklen == 0) {
break;
}
togo = MIN(blocklen, n);
sbufp = sampblock->samples;
for (j = 0; j < togo; j++) {
register double samp = *sbufp++;
if (samp > maximum) maximum = samp;
else if (-samp > maximum) maximum = -samp;
}
n -= togo;
}
xlpop();
} else {
xlerror("sound_max: expression did not return a sound",
s_as_lval);
}
return maximum * s->scale;
}
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);
}
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);
}
}
/* 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);
}
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);
}
void xltest(NODE **pfcn, int *ptresult, NODE **pargs)
{
NODE *arg;
if (!((*pargs) && (*pargs)->n_type == 3)) {
*pfcn = ((s_eql)->n_info.n_xsym.xsy_value);
*ptresult = 1;
return;
}
arg = ((*pargs)->n_info.n_xlist.xl_car);
if (arg == k_test)
*ptresult = 1;
else if (arg == k_tnot)
*ptresult = 0;
else
xlfail("expecting :test or :test-not");
*pargs = ((*pargs)->n_info.n_xlist.xl_cdr);
if (!((*pargs) && (*pargs)->n_type == 3))
xlfail("no value for keyword argument");
*pfcn = ((*pargs)->n_info.n_xlist.xl_car);
if (((*pfcn) && (*pfcn)->n_type == 4))
*pfcn = xleval(*pfcn);
*pargs = ((*pargs)->n_info.n_xlist.xl_cdr);
}
nyx_rval nyx_eval_expression(const char *expr_string)
{
LVAL expr = NULL;
#if defined(NYX_MEMORY_STATS) && NYX_MEMORY_STATS
printf("\nnyx_eval_expression before\n");
xmem();
#endif
nyx_result = NULL;
nyx_result_type = nyx_error;
// Check argument
if (!expr_string || !strlen(expr_string)) {
return nyx_get_type(nyx_result);
}
nyx_expr_string = expr_string;
nyx_expr_len = strlen(nyx_expr_string);
nyx_expr_pos = 0;
// Protect the expression from being garbage collected
xlprot1(expr);
// Setup a new context
xlbegin(&nyx_cntxt, CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL|CF_ERROR, s_true);
// Set the context jump destination
if (setjmp(nyx_cntxt.c_jmpbuf)) {
// If the script is cancelled or some other condition occurs that causes
// the script to exit and return to this level, then we don't need to
// restore the previous context.
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);
}
// This will unwind the xlisp context and restore internals to a point just
// before we issued our xlbegin() above. This is important since the internal
// xlisp stacks will contain pointers to invalid objects otherwise.
//
// Also note that execution will jump back up to the statement following the
// setjmp() above.
xljump(&nyx_cntxt, CF_TOPLEVEL, NIL);
// Never reached
finish:
xlflush();
xlpop(); // unprotect expr
gc();
#if defined(NYX_MEMORY_STATS) && NYX_MEMORY_STATS
printf("\nnyx_eval_expression after\n");
xmem();
#endif
return nyx_get_type(nyx_result);
}
double sound_save(
LVAL snd_expr,
long n,
unsigned char *filename,
long format,
long mode,
long bits,
long swap,
double *sr,
long *nchans,
double *duration,
LVAL play)
{
LVAL result;
char *buf;
long ntotal;
double max_sample;
snd_node snd;
snd_node player;
long flags;
snd.device = SND_DEVICE_FILE;
snd.write_flag = SND_WRITE;
strcpy(snd.u.file.filename, (char *) filename);
snd.u.file.file = -1; /* this is a marker that snd is unopened */
snd.u.file.header = format;
snd.format.mode = mode;
snd.format.bits = bits;
snd.u.file.swap = swap;
player.device = SND_DEVICE_AUDIO;
player.write_flag = SND_WRITE;
player.u.audio.devicename[0] = '\0';
player.u.audio.descriptor = NULL;
player.u.audio.protocol = SND_COMPUTEAHEAD;
player.u.audio.latency = 1.0;
player.u.audio.granularity = 0.0;
if ((buf = (char *) malloc(max_sample_block_len * MAX_SND_CHANNELS *
sizeof(float))) == NULL) {
xlabort("snd_save -- couldn't allocate memory");
}
result = xleval(snd_expr);
/* BE CAREFUL - DO NOT ALLOW GC TO RUN WHILE RESULT IS UNPROTECTED */
if (vectorp(result)) {
/* make sure all elements are of type a_sound */
long i = getsize(result);
*nchans = snd.format.channels = i;
while (i > 0) {
i--;
if (!exttypep(getelement(result, i), a_sound)) {
xlerror("sound_save: array has non-sound element",
result);
}
}
/* assume all are the same: */
*sr = snd.format.srate = getsound(getelement(result, 0))->sr;
/* note: if filename is "", then don't write file; therefore,
* write the file if (filename[0])
*/
if (filename[0] && snd_open(&snd, &flags) != SND_SUCCESS) {
xlabort("snd_save -- could not open sound file");
}
play = prepare_audio(play, &snd, &player);
max_sample = sound_save_array(result, n, &snd,
buf, &ntotal, (play == NIL ? NULL : &player));
*duration = ntotal / *sr;
if (filename[0]) snd_close(&snd);
if (play != NIL) finish_audio(&player);
} else if (exttypep(result, a_sound)) {
*nchans = snd.format.channels = 1;
*sr = snd.format.srate = (getsound(result))->sr;
if (filename[0] && snd_open(&snd, &flags) != SND_SUCCESS) {
xlabort("snd_save -- could not open sound file");
}
play = prepare_audio(play, &snd, &player);
max_sample = sound_save_sound(result, n, &snd,
buf, &ntotal, (play == NIL ? NULL : &player));
*duration = ntotal / *sr;
if (filename[0]) snd_close(&snd);
if (play != NIL) finish_audio(&player);
} else {
xlerror("sound_save: expression did not return a sound",
result);
max_sample = 0.0;
}
free(buf);
return max_sample;
}
double sound_overwrite(
LVAL snd_expr,
long n,
unsigned char *filename,
long byte_offset,
long header,
long mode,
long bits,
long swap,
double sr,
long nchans,
double *duration)
{
LVAL result;
char *buf;
char error[140];
long ntotal;
double max_sample;
snd_node snd;
long flags;
snd.device = SND_DEVICE_FILE;
snd.write_flag = SND_OVERWRITE;
strcpy(snd.u.file.filename, (char *) filename);
snd.u.file.header = header;
snd.u.file.byte_offset = byte_offset;
snd.format.channels = nchans;
snd.format.mode = mode;
snd.format.bits = bits;
snd.u.file.swap = swap;
snd.format.srate = sr;
if ((buf = (char *) malloc(max_sample_block_len * MAX_SND_CHANNELS *
sizeof(float))) == NULL) {
xlabort("snd_overwrite: couldn't allocate memory");
}
if (snd_open(&snd, &flags) != SND_SUCCESS) {
sprintf(error,
"snd_overwrite: cannot open file %s and seek to %d",
filename, (int)byte_offset);
free(buf);
xlabort(error);
}
result = xleval(snd_expr);
/* BE CAREFUL - DO NOT ALLOW GC TO RUN WHILE RESULT IS UNPROTECTED */
if (vectorp(result)) {
/* make sure all elements are of type a_sound */
long i = getsize(result);
if (nchans != i) {
sprintf(error, "%s%d%s%d%s",
"snd_overwrite: number of channels in sound (",
(int)i,
") does not match\n number of channels in file (",
(int)nchans,
")");
free(buf);
snd_close(&snd);
xlabort(error);
}
while (i > 0) {
i--;
if (!exttypep(getelement(result, i), a_sound)) {
free(buf);
snd_close(&snd);
xlerror("sound_save: array has non-sound element",
result);
}
}
/* assume all are the same: */
if (sr != getsound(getelement(result, 0))->sr) {
sprintf(error, "%s%g%s%g%s",
"snd_overwrite: sample rate in sound (",
getsound(getelement(result, 0))->sr,
") does not match\n sample rate in file (",
sr,
")");
free(buf);
snd_close(&snd);
xlabort(error);
}
max_sample = sound_save_array(result, n, &snd, buf, &ntotal, NULL);
*duration = ntotal / sr;
} else if (exttypep(result, a_sound)) {
if (nchans != 1) {
sprintf(error, "%s%s%d%s",
"snd_overwrite: number of channels in sound (1",
") does not match\n number of channels in file (",
(int)nchans,
")");
free(buf);
snd_close(&snd);
xlabort(error);
}
if (sr != getsound(result)->sr) {
sprintf(error, "%s%g%s%g%s",
"snd_overwrite: sample rate in sound (",
getsound(result)->sr,
") does not match\n sample rate in file (",
sr,
")");
free(buf);
snd_close(&snd);
xlabort(error);
}
max_sample = sound_save_sound(result, n, &snd, buf, &ntotal, NULL);
*duration = ntotal / sr;
} else {
free(buf);
snd_close(&snd);
xlerror("sound_save: expression did not return a sound",
result);
max_sample = 0.0;
}
free(buf);
snd_close(&snd);
return max_sample;
}
/* evform - evaluate a form */
LOCAL LVAL evform(LVAL form)
{
LVAL fun,args,val,type;
LVAL tracing=NIL;
LVAL *argv;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
LVAL funname;
int argc;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
(*profile_count_ptr)++; /* increment profile counter */
/* get the function and the argument list */
fun = car(form);
args = cdr(form);
funname = fun;
/* get the functional value of symbols */
if (symbolp(fun)) {
if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
tracing = fun;
fun = xlgetfunction(fun);
}
/* check for nil */
if (null(fun))
xlerror("bad function",NIL);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
argv = xlargv;
argc = xlargc;
xlargc = evpushargs(fun,args);
xlargv = xlfp + 3;
trenter(tracing,xlargc,xlargv);
val = (*getsubr(fun))();
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case FSUBR:
argv = xlargv;
argc = xlargc;
xlargc = pushargs(fun,args);
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if ((type = car(fun)) == s_lambda)
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
/* do profiling */
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
if (gettype(fun) == s_lambda) {
argc = evpushargs(fun,args);
argv = xlfp + 3;
trenter(tracing,argc,argv);
val = evfun(fun,argc,argv);
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
}
else {
macroexpand(fun,args,&fun);
val = xleval(fun);
}
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
break;
default:
xlerror("bad function",fun);
}
/* restore the stack */
xlpopn(2);
/* return the result value */
return (val);
}
}
}
/* multiseq_convert -- eval closure and convert to adds */
/**/
void multiseq_convert(multiseq_type ms)
{
LVAL result, new;
sound_type snd;
time_type now = ms->t0 + ms->horizon;
int i;
long size;
xlsave1(result);
result = xleval(cons(ms->closure, consa(cvflonum(now))));
if (exttypep(result, a_sound)) {
snd = sound_copy(getsound(result));
result = newvector(ms->nchans);
setelement(result, 0, cvsound(snd));
for (i = 1; i < ms->nchans; i++) {
setelement(result, i, cvsound(sound_zero(now, ms->sr)));
}
} else if (vectorp(result)) {
if (getsize(result) > ms->nchans) {
xlerror("too few channels", result);
} else if (getsize(result) < ms->nchans) {
new = newvector(ms->nchans);
for (i = 1; i < getsize(result); i++) {
setelement(new, i, getelement(result, i));
}
void trigger_fetch(trigger_susp_type susp, snd_list_type snd_list)
{
int cnt = 0; /* how many samples computed */
int togo;
int n;
sample_block_type out;
register sample_block_values_type out_ptr;
register sample_block_values_type out_ptr_reg;
register sample_block_values_type input_ptr_reg;
falloc_sample_block(out, "trigger_fetch");
out_ptr = out->samples;
snd_list->block = out;
while (cnt < max_sample_block_len) { /* outer loop */
/* first compute how many samples to generate in inner loop: */
/* don't overflow the output sample block */
togo = max_sample_block_len - cnt;
/* don't run past the input sample block: */
susp_check_term_samples(s1, s1_ptr, s1_cnt);
togo = min(togo, susp->s1_cnt);
/* don't run past terminate time */
if (susp->terminate_cnt != UNKNOWN &&
susp->terminate_cnt <= susp->susp.current + cnt + togo) {
togo = susp->terminate_cnt - (susp->susp.current + cnt);
if (togo == 0) break;
}
n = togo;
input_ptr_reg = susp->s1_ptr;
out_ptr_reg = out_ptr;
if (n) do { /* the inner sample computation loop */
sample_type s = *input_ptr_reg++;
if (susp->previous <= 0 && s > 0) {
trigger_susp_type new_trigger;
sound_type new_trigger_snd;
LVAL result;
long delay; /* sample delay to s2 */
time_type now;
susp->previous = s; /* don't retrigger */
/**** close off block ****/
togo = togo - n;
susp->s1_ptr += togo;
susp_took(s1_cnt, togo);
cnt += togo;
snd_list->block_len = cnt;
susp->susp.current += cnt;
now = susp->susp.t0 + susp->susp.current / susp->susp.sr;
/**** eval closure and add result ****/
D nyquist_printf("trigger_fetch: about to eval closure at %g, "
"susp->susp.t0 %g, susp.current %d:\n",
now, susp->susp.t0, (int)susp->susp.current);
xlsave1(result);
result = xleval(cons(susp->closure, consa(cvflonum(now))));
if (exttypep(result, a_sound)) {
susp->s2 = sound_copy(getsound(result));
D nyquist_printf("trigger: copied result from closure is %p\n",
susp->s2);
} else xlerror("closure did not return a (monophonic) sound",
result);
D nyquist_printf("in trigger: after evaluation; "
"%p returned from evform\n",
susp->s2);
result = NIL;
/**** cloan this trigger to become s1 ****/
falloc_generic(new_trigger, trigger_susp_node,
"new_trigger");
memcpy(new_trigger, susp, sizeof(trigger_susp_node));
/* don't copy s2 -- it should only be referenced by add */
new_trigger->s2 = NULL;
new_trigger_snd = sound_create((snd_susp_type) new_trigger,
now, susp->susp.sr, 1.0F);
susp->s1 = new_trigger_snd;
/* add will have to ask new_trigger for samples, new_trigger
* will continue reading samples from s1 (the original input)
*/
susp->s1_cnt = 0;
susp->s1_ptr = NULL;
/**** convert to add ****/
susp->susp.mark = add_mark;
/* logical stop will be recomputed by add: */
susp->susp.log_stop_cnt = UNKNOWN;
susp->susp.print_tree = add_print_tree;
/* assume sample rates are the same */
if (susp->s1->sr != susp->s2->sr)
xlfail("in trigger: sample rates must match");
/* take care of scale factor, if any */
if (susp->s2->scale != 1.0) {
// stdputstr("normalizing next sound in a seq\n");
susp->s2 = snd_make_normalize(susp->s2);
}
/* figure out which add fetch routine to use */
delay = ROUND((susp->s2->t0 - now) * susp->s1->sr);
if (delay > 0) { /* fill hole between s1 and s2 */
D stdputstr("using add_s1_nn_fetch\n");
susp->susp.fetch = add_s1_nn_fetch;
susp->susp.name = "trigger:add_s1_nn_fetch";
} else {
susp->susp.fetch = add_s1_s2_nn_fetch;
susp->susp.name = "trigger:add_s1_s2_nn_fetch";
}
D stdputstr("in trigger: calling add's fetch\n");
/* fetch will get called later ..
(*(susp->susp.fetch))(susp, snd_list); */
D stdputstr("in trigger: returned from add's fetch\n");
xlpop();
susp->closure = NULL; /* allow garbage collection now */
/**** calculation tree modified, time to exit ****/
/* but if cnt == 0, then we haven't computed any samples */
/* call on new fetch routine to get some samples */
if (cnt == 0) {
ffree_sample_block(out, "trigger-pre-adder"); // because adder will reallocate
(*susp->susp.fetch)(susp, snd_list);
}
return;
} else {
susp->previous = s;
/* output zero until ready to add in closure */
*out_ptr_reg++ = 0;
}
} while (--n); /* inner loop */
/* using input_ptr_reg is a bad idea on RS/6000: */
susp->s1_ptr += togo;
out_ptr += togo;
susp_took(s1_cnt, togo);
cnt += togo;
} /* outer loop */
if (togo == 0 && cnt == 0) {
snd_list_terminate(snd_list);
} else {
snd_list->block_len = cnt;
susp->susp.current += cnt;
}
} /* trigger_fetch */
/* 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;
}
double sound_save(
LVAL snd_expr,
long n,
unsigned char *filename,
long format,
long mode,
long bits,
long swap,
double *sr,
long *nchans,
double *duration,
LVAL play)
{
LVAL result;
float *buf;
long ntotal;
double max_sample;
SNDFILE *sndfile = NULL;
SF_INFO sf_info;
PaStream *audio_stream = NULL;
if (SAFE_NYQUIST) play = FALSE;
gc();
memset(&sf_info, 0, sizeof(sf_info));
sf_info.format = lookup_format(format, mode, bits, swap);
result = xleval(snd_expr);
/* BE CAREFUL - DO NOT ALLOW GC TO RUN WHILE RESULT IS UNPROTECTED */
if (vectorp(result)) {
/* make sure all elements are of type a_sound */
long i = getsize(result);
*nchans = sf_info.channels = i;
while (i > 0) {
i--;
if (!exttypep(getelement(result, i), a_sound)) {
xlerror("sound_save: array has non-sound element",
result);
}
}
/* assume all are the same: */
*sr = sf_info.samplerate = ROUND(getsound(getelement(result, 0))->sr);
/* note: if filename is "", then don't write file; therefore,
* write the file if (filename[0])
*/
if (filename[0]) {
sndfile = NULL;
if (ok_to_open((char *) filename, "wb"))
sndfile = sf_open((char *) filename, SFM_WRITE, &sf_info);
if (sndfile) {
/* use proper scale factor: 8000 vs 7FFF */
sf_command(sndfile, SFC_SET_CLIPPING, NULL, SF_TRUE);
}
}
if (play)
play = prepare_audio(play, &sf_info, &audio_stream);
if ((buf = (float *) malloc(max_sample_block_len * sf_info.channels *
sizeof(float))) == NULL) {
xlabort("snd_save -- couldn't allocate memory");
}
max_sample = sound_save_array(result, n, &sf_info, sndfile,
buf, &ntotal, audio_stream);
*duration = ntotal / *sr;
if (sndfile) sf_close(sndfile);
if (play != NIL) finish_audio(audio_stream);
} else if (exttypep(result, a_sound)) {
*nchans = sf_info.channels = 1;
sf_info.samplerate = ROUND((getsound(result))->sr);
*sr = sf_info.samplerate;
if (filename[0]) {
sndfile = NULL;
if (ok_to_open((char *) filename, "wb")) {
sndfile = sf_open((char *) filename, SFM_WRITE, &sf_info);
if (sndfile) {
/* use proper scale factor: 8000 vs 7FFF */
sf_command(sndfile, SFC_SET_CLIPPING, NULL, SF_TRUE);
} else {
char error[240];
sprintf(error, "snd_save -- %s", sf_error_number(sf_error(sndfile)));
xlabort(error);
}
} else {
xlabort("snd_save -- write not permitted by -W option");
}
}
if (play)
play = prepare_audio(play, &sf_info, &audio_stream);
if ((buf = (float *) malloc(max_sample_block_len *
sizeof(float))) == NULL) {
xlabort("snd_save -- couldn't allocate memory");
}
max_sample = sound_save_sound(result, n, &sf_info, sndfile,
buf, &ntotal, audio_stream);
*duration = ntotal / *sr;
if (sndfile) sf_close(sndfile);
if (play != NIL) finish_audio(audio_stream);
} else {
xlerror("sound_save: expression did not return a sound",
result);
max_sample = 0.0;
}
free(buf);
return max_sample;
}
double sound_overwrite(
LVAL snd_expr,
long n,
unsigned char *filename,
double offset_secs,
long format,
long mode,
long bits,
long swap,
double *duration)
{
LVAL result; // the SOUND to be evaluated
SF_INFO sf_info; // info about the sound file
double max_sample; // return value
long ntotal; // how many samples were overwritten
/*
long flags;
*/
// first check if sound file exists, do not create new file
FILE *file = NULL;
if (ok_to_open((char *) filename, "rb"))
file = fopen((char *) filename, "rb");
// if not then fail
if (!file) {
*duration = 0;
return 0.0;
} else {
fclose(file);
}
memset(&sf_info, 0, sizeof(sf_info));
sf_info.format = lookup_format(format, mode, bits, swap);
result = xleval(snd_expr);
/* BE CAREFUL - DO NOT ALLOW GC TO RUN WHILE RESULT IS UNPROTECTED */
if (vectorp(result)) {
SNDFILE *sndfile; // opened sound file
float *buf; // buffer for samples read in from sound file
/* make sure all elements are of type a_sound */
long i = getsize(result);
long channels = i;
while (i > 0) {
i--;
if (!exttypep(getelement(result, i), a_sound)) {
xlerror("sound_save: array has non-sound element",
result);
}
}
sndfile = open_for_write(filename, SFM_RDWR, format, &sf_info, channels,
ROUND(getsound(getelement(result, 0))->sr),
offset_secs, &buf);
max_sample = sound_save_array(result, n, &sf_info, sndfile,
buf, &ntotal, NULL);
*duration = ntotal / (double) sf_info.samplerate;
free(buf);
sf_close(sndfile);
} else if (exttypep(result, a_sound)) {
SNDFILE *sndfile; // opened sound file
float *buf; // buffer for samples read in from sound file
sndfile = open_for_write(filename, SFM_RDWR, format, &sf_info, 1,
ROUND(getsound(result)->sr),
offset_secs, &buf);
max_sample = sound_save_sound(result, n, &sf_info, sndfile, buf,
&ntotal, NULL);
*duration = ntotal / (double) sf_info.samplerate;
free(buf);
sf_close(sndfile);
} else {
xlerror("sound_save: expression did not return a sound",
result);
max_sample = 0.0;
}
return max_sample;
}
void ifft__fetch(register ifft_susp_type susp, snd_list_type snd_list)
{
int cnt = 0; /* how many samples computed */
int togo;
int n;
sample_block_type out;
register sample_block_values_type out_ptr;
register sample_block_values_type out_ptr_reg;
register long index_reg;
register sample_type * outbuf_reg;
falloc_sample_block(out, "ifft__fetch");
out_ptr = out->samples;
snd_list->block = out;
while (cnt < max_sample_block_len) { /* outer loop */
/* first compute how many samples to generate in inner loop: */
/* don't overflow the output sample block: */
togo = max_sample_block_len - cnt;
if (susp->src == NULL) {
out: togo = 0; /* indicate termination */
break; /* we're done */
}
if (susp->index >= susp->stepsize) {
long i;
long m, n;
LVAL elem;
susp->index = 0;
susp->array =
xleval(cons(s_send, cons(susp->src, consa(s_next))));
if (susp->array == NULL) {
susp->src = NULL;
goto out;
} else if (!vectorp(susp->array)) {
xlerror("array expected", susp->array);
} else if (susp->samples == NULL) {
/* assume arrays are all the same size as first one;
now that we know the size, we just have to do this
first allocation.
*/
susp->length = getsize(susp->array);
if (susp->length < 1)
xlerror("array has no elements", susp->array);
if (susp->window && (susp->window_len != susp->length))
xlerror("window size and spectrum size differ",
susp->array);
/* tricky non-power of 2 detector: only if this is a
* power of 2 will the highest 1 bit be cleared when
* we subtract 1 ...
*/
if (susp->length & (susp->length - 1))
xlfail("spectrum size must be a power of 2");
susp->samples = (sample_type *) calloc(susp->length,
sizeof(sample_type));
susp->outbuf = (sample_type *) calloc(susp->length,
sizeof(sample_type));
} else if (getsize(susp->array) != susp->length) {
xlerror("arrays must all be the same length", susp->array);
}
/* at this point, we have a new array to put samples */
/* the incoming array format is [DC, R1, I1, R2, I2, ... RN]
* where RN is the real coef at the Nyquist frequency
* but susp->samples should be organized as [DC, RN, R1, I1, ...]
*/
n = susp->length;
/* get the DC (real) coef */
elem = getelement(susp->array, 0);
MUST_BE_FLONUM(elem)
susp->samples[0] = (sample_type) getflonum(elem);
/* get the Nyquist (real) coef */
elem = getelement(susp->array, n - 1);
MUST_BE_FLONUM(elem);
susp->samples[1] = (sample_type) getflonum(elem);
/* get the remaining coef */
for (i = 1; i < n - 1; i++) {
elem = getelement(susp->array, i);
MUST_BE_FLONUM(elem)
susp->samples[i + 1] = (sample_type) getflonum(elem);
}
susp->array = NULL; /* free the array */
/* here is where the IFFT and windowing should take place */
//fftnf(1, &n, susp->samples, susp->samples + n, -1, 1.0);
m = round(log(n) / M_LN2);
if (!fftInit(m)) riffts(susp->samples, m, 1);
else xlfail("FFT initialization error");
if (susp->window) {
n = susp->length;
for (i = 0; i < n; i++) {
susp->samples[i] *= susp->window[i];
}
}
/* shift the outbuf */
n = susp->length - susp->stepsize;
for (i = 0; i < n; i++) {
susp->outbuf[i] = susp->outbuf[i + susp->stepsize];
}
/* clear end of outbuf */
for (i = n; i < susp->length; i++) {
susp->outbuf[i] = 0;
}
/* add in the ifft result */
n = susp->length;
for (i = 0; i < n; i++) {
susp->outbuf[i] += susp->samples[i];
}
}
togo = min(togo, susp->stepsize - susp->index);
n = togo;
index_reg = susp->index;
outbuf_reg = susp->outbuf;
out_ptr_reg = out_ptr;
if (n) do { /* the inner sample computation loop */
*out_ptr_reg++ = outbuf_reg[index_reg++];;
} while (--n); /* inner loop */
susp->index = index_reg;
susp->outbuf = outbuf_reg;
out_ptr += togo;
cnt += togo;
} /* outer loop */
/* test for termination */
if (togo == 0 && cnt == 0) {
snd_list_terminate(snd_list);
} else {
snd_list->block_len = cnt;
susp->susp.current += cnt;
}
} /* ifft__fetch */
