/* cons - construct a new cons node */
LVAL cons(LVAL x, LVAL y)
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
xlstkcheck(2);
xlprotect(x);
xlprotect(y);
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
xlpop();
xlpop();
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
--nfree;
/* initialize the new node */
nnode->n_type = CONS;
rplaca(nnode,x);
rplacd(nnode,y);
/* return the new node */
return (nnode);
}
pascal OSErr AEOpenFiles(AppleEvent *theAppleEvent, AppleEvent *theReply,
long Refcon)
{
AEDescList docList;
AEKeyword keywd;
DescType returnedType;
Size actualSize;
long itemsInList;
FSSpec theSpec;
CInfoPBRec pb;
Str255 name;
short i;
if (AEGetParamDesc(theAppleEvent, keyDirectObject, typeAEList, &docList) !=
noErr) return;
if (AECountItems (&docList, &itemsInList) != noErr) return;
SetSelection (TEXTREC->teLength, TEXTREC->teLength);
for (i = 1; i <= itemsInList; i++) {
AEGetNthPtr (&docList, i, typeFSS, &keywd, &returnedType,
(Ptr) &theSpec, sizeof(theSpec), &actualSize);
GetFullPath(&theSpec, name);
P2CStr(name); // was: pstrterm(name);
if (xlload ((char *)name + 1, 1, 0) == 0) xlabort ("load error");
}
macputs ("> ");
PrepareForInput ();
}
LVAL prepare_audio(LVAL play, snd_type snd, snd_type player)
{
long flags;
if (play == NIL) return NIL;
player->format = snd->format;
player->u.audio.devicename[0] = 0;
player->u.audio.interfacename[0] = 0;
if (snd_open(player, &flags) != SND_SUCCESS) {
xlabort("snd_save -- could not open audio output");
}
/* make sure player and snd are compatible -- if not, set player to NULL
* and print a warning message
*/
if (player->format.channels == snd->format.channels &&
player->format.mode == snd->format.mode &&
player->format.bits == snd->format.bits) {
/* ok so far, check out the sample rate */
if (player->format.srate != snd->format.srate) {
char msg[100];
sprintf(msg, "%s(%g)%s(%g).\n",
"Warning: file sample rate ", snd->format.srate,
" differs from audio playback sample rate ",
player->format.srate);
stdputstr(msg);
}
} else {
stdputstr("File format not supported by audio output.\n");
return NIL;
}
return play;
}
LOCAL void report_exit(char *msg, int i)
{
sprintf(buf, "env stack index: %d, cons_count %ld, Function: ", i, cons_count);
errputstr(buf);
stdprint(fpstack[i][1]);
xlabort(msg);
}
/* findandjump - find a target context frame and jump to it */
LOCAL void findandjump(int mask, const char *error)
{
XLCONTEXT *cptr;
/* find a block context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & mask)
xljump(cptr,mask,NIL);
xlabort(error);
}
void pop_xlenv(void)
{
char s[10];
if (envstack_top <= 0) {
sprintf(s, ", %d! ", envstack_top);
stdputstr(s);
xlabort("envstack underflow!");
} else envstack_top--;
/* sprintf(s, "%d> ", envstack_top);
stdputstr(s); */
}
void push_xlenv(void)
{
char s[10];
/* sprintf(s, "<%d ", envstack_top);
stdputstr(s); */
if (envstack_top >= envstack_max) {
xlabort("envstack overflow");
} else {
fpstack[envstack_top] = xlfp;
envstack[envstack_top++] = xlenv;
}
}
VOID stchck(V) {
int dummy;
int stackleft = STACKREPORT(dummy);
if (stackleft < (stackwarn ? MARGLO : marghi)) {
stackwarn = TRUE;
if (stackleft>MARGLO)
xlcerror("use full stack",
"system stack is low, bytes left", cvfixnum(stackleft));
else {
xlabort("system stack overflow");
}
}
}
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);
}
}
cvtfn_type find_cvt_to_fn(snd_type snd, char *buf)
{
cvtfn_type cvtfn;
/* find the conversion function */
if (snd->format.bits == 8) cvtfn = cvt_to_8[snd->format.mode];
else if (snd->format.bits == 16) cvtfn = cvt_to_16[snd->format.mode];
else if (snd->format.bits == 24) cvtfn = cvt_to_24[snd->format.mode];
else if (snd->format.bits == 32) cvtfn = cvt_to_32[snd->format.mode];
else cvtfn = cvt_to_unknown;
if (cvtfn == cvt_to_unknown) {
char error[50];
sprintf(error, "Cannot write %d-bit samples in mode %s",
(int)snd->format.bits, snd_mode_to_string(snd->format.mode));
free(buf);
snd_close(snd);
xlabort(error);
}
return cvtfn;
}
/* newnode - allocate a new node */
LVAL newnode(int type)
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
nfree -= 1L;
/* initialize the new node */
nnode->n_type = type;
rplacd(nnode,NIL);
/* return the new node */
return (nnode);
}
/* newnode - allocate a new node */
LOCAL NODE *newnode(int type)
{
NODE *nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
nfree -= 1;
/* initialize the new node */
memset(&nnode->n_info, 0, sizeof(nnode->n_info)); //matth
nnode->n_type = type;
//rplacd(nnode,NIL); matth
/* return the new node */
return (nnode);
}
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;
}
sound_type snd_make_convolve(sound_type x_snd, sound_type h_snd)
{
register convolve_susp_type susp;
rate_type sr = x_snd->sr;
time_type t0 = x_snd->t0;
sample_type scale_factor = 1.0F;
time_type t0_min = t0;
table_type table;
double log_len;
falloc_generic(susp, convolve_susp_node, "snd_make_convolve");
table = sound_to_table(h_snd);
susp->h_len = table->length;
log_len = log(table->length) / M_LN2; /* compute log-base-2(length) */
susp->M = (int) log_len;
if (susp->M != log_len) susp->M++; /* round up */
susp->N = 1 << susp->M; /* size of data blocks */
susp->M++; /* M = log2(2 * N) */
susp->H = (sample_type *) calloc(2 * susp->N, sizeof(susp->H[0]));
if (!susp->H) {
xlabort("memory allocation failure in convolve");
}
memcpy(susp->H, table->samples, sizeof(susp->H[0]) * susp->N);
table_unref(table); /* don't need table now */
/* remaining N samples are already zero-filled */
if (fftInit(susp->M)) {
free(susp->H);
xlabort("fft initialization error in convolve");
}
rffts(susp->H, susp->M, 1);
susp->X = (sample_type *) calloc(2 * susp->N, sizeof(susp->X[0]));
susp->R = (sample_type *) calloc(2 * susp->N, sizeof(susp->R[0]));
if (!susp->X || !susp->R) {
free(susp->H);
if (susp->X) free(susp->X);
if (susp->R) free(susp->R);
xlabort("memory allocation failed in convolve");
}
susp->R_current = susp->R + susp->N;
susp->susp.fetch = &convolve_s_fetch;
susp->terminate_cnt = UNKNOWN;
/* handle unequal start times, if any */
if (t0 < x_snd->t0) sound_prepend_zeros(x_snd, t0);
/* minimum start time over all inputs: */
t0_min = min(x_snd->t0, t0);
/* how many samples to toss before t0: */
susp->susp.toss_cnt = (long) ((t0 - t0_min) * sr + 0.5);
if (susp->susp.toss_cnt > 0) {
susp->susp.keep_fetch = susp->susp.fetch;
susp->susp.fetch = convolve_toss_fetch;
}
/* initialize susp state */
susp->susp.free = convolve_free;
susp->susp.sr = sr;
susp->susp.t0 = t0;
susp->susp.mark = convolve_mark;
susp->susp.print_tree = convolve_print_tree;
susp->susp.name = "convolve";
susp->logically_stopped = false;
susp->susp.log_stop_cnt = logical_stop_cnt_cvt(x_snd);
susp->susp.current = 0;
susp->x_snd = x_snd;
susp->x_snd_cnt = 0;
return sound_create((snd_susp_type)susp, t0, sr, scale_factor);
}
/*
* if the format is RAW, then fill in sf_info according to
* sound sample rate and channels. Otherwise, open the file
* and see if the sample rate and channele match.
*/
SNDFILE *open_for_write(unsigned char *filename, long direction,
long format, SF_INFO *sf_info, int channels,
long srate, double offset, float **buf)
/* channels and srate are based on the sound we're writing to the file */
{
SNDFILE *sndfile;
sf_count_t frames; // frame count passed into sf_seek
char error[140]; // error messages are formatted here
sf_count_t rslt; // frame count returned from sf_seek
if (format == SND_HEAD_RAW) {
sf_info->channels = channels;
sf_info->samplerate = srate;
} else {
sf_info->format = 0;
}
sndfile = NULL;
if (ok_to_open((char *) filename, "w"))
sndfile = sf_open((const char *) filename, direction, sf_info);
if (!sndfile) {
snprintf(error, sizeof(error), "snd_overwrite: cannot open file %s", filename);
xlabort(error);
}
/* use proper scale factor: 8000 vs 7FFF */
sf_command(sndfile, SFC_SET_CLIPPING, NULL, SF_TRUE);
frames = round(offset * sf_info->samplerate);
rslt = sf_seek(sndfile, frames, SEEK_SET);
if (rslt < 0) {
snprintf(error, sizeof(error), "snd_overwrite: cannot seek to frame %lld of %s",
frames, filename);
xlabort(error);
}
if (sf_info->channels != channels) {
snprintf(error, sizeof(error), "%s%d%s%d%s",
"snd_overwrite: number of channels in sound (",
channels,
") does not match\n number of channels in file (",
sf_info->channels, ")");
sf_close(sndfile);
xlabort(error);
}
if (sf_info->samplerate != srate) {
snprintf(error, sizeof(error), "%s%ld%s%d%s",
"snd_overwrite: sample rate in sound (",
srate,
") does not match\n sample rate in file (",
sf_info->samplerate,
")");
sf_close(sndfile);
xlabort(error);
}
if ((*buf = (float *) malloc(max_sample_block_len * channels *
sizeof(float))) == NULL) {
xlabort("snd_overwrite: couldn't allocate memory");
}
return sndfile;
}
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;
}
