LVAL xsbaselowess(V) { LVAL x, y, ys, rw, res; double *dx, *dy, *dys, *drw, *dres; int n, nsteps, error; double f, delta; x = xlgetarg(); y = xlgetarg(); n = getfixnum(xlgafixnum()); f = makefloat(xlgetarg()); nsteps = getfixnum(xlgafixnum()); delta = makefloat(xlgetarg()); ys = xlgetarg(); rw = xlgetarg(); res = xlgetarg(); xllastarg(); dx = getlinalgdvec(0, n, x); dy = getlinalgdvec(0, n, y); dys = getlinalgdvec(0, n, ys); drw = getlinalgdvec(0, n, rw); dres = getlinalgdvec(0, n, res); error = lowess(dx, dy, n, f, nsteps, delta, dys, drw, dres); return error ? s_true : NIL; }
LVAL iview_hist_mark_points_in_rect(V) { int i, n, in_rect; PointState point_state; IVIEW_WINDOW w; int left, top, width, height; LVAL object, hdata; gethistargs(&w, &object, &hdata); left = getfixnum(xlgafixnum()); top = getfixnum(xlgafixnum()); width = getfixnum(xlgafixnum()); height = getfixnum(xlgafixnum()); if (IVIEW_WINDOW_NULL(w)) return(NIL); n = IViewNumPoints(w); for (i = 0; i < n; i++) { point_state = IViewPointState(w, i); if (! IViewPointMasked(w, i) && point_state != pointInvisible) { in_rect = sect_point_rect(hdata, i, left, top, width, height); IViewSetPointMark(w, i, in_rect); } } return(NIL); }
LVAL xsbasespline(V) { LVAL x, y, xs, ys, work; double *dx, *dy, *dxs, *dys, *dwork; int n, ns, error; n = getfixnum(xlgafixnum()); x = xlgetarg(); y = xlgetarg(); ns = getfixnum(xlgafixnum()); xs = xlgetarg(); ys = xlgetarg(); work = xlgetarg(); xllastarg(); dx = getlinalgdvec(0, n, x); dy = getlinalgdvec(0, n, y); dxs = getlinalgdvec(0, ns, xs); dys = getlinalgdvec(0, ns, ys); dwork = getlinalgdvec(0, 2 * n, work); error = fit_spline(n, dx, dy, ns, dxs, dys, dwork); return error ? s_true : NIL; }
/* find length of a compound item's data sequence */ int compounddatalen P1C(LVAL, x) { switch (ntype(x)) { case OBJECT: { LVAL n = send_message(x, sk_data_length); if (! fixp(n) || getfixnum(n) < 0) xlerror("bad length", n); return((int) getfixnum(n)); } case CONS: return(llength(x)); case DARRAY: x = getdarraydata(x); if (stringp(x)) xlbadtype(x); /* fall through */ case VECTOR: case TVEC: return(gettvecsize(x)); case SYMBOL: if (null(x)) return(0); default: xlbadtype(x); return(0); } }
VOID initialize_graph_window P1C(LVAL, object) { LVAL internals, value; int v, width, height, size; StGWWinInfo *gwinfo; ColorCode bc,dc; /* added JKL */ internals = newadata(StGWWinInfoSize(), 1, FALSE); set_slot_value(object, s_internals, consa(internals)); StGWInitWinInfo(object); gwinfo = StGWObWinInfo(object); if (gwinfo == NULL) return; StGWSetObject(gwinfo, object); if (slot_value(object, s_black_on_white) == NIL) { bc = StGWBackColor(gwinfo); /* this seems better for color */ dc = StGWDrawColor(gwinfo); /* machines - 0 and 1 are not */ StGWSetDrawColor(gwinfo, bc); /* the default draw and back */ StGWSetBackColor(gwinfo, dc); /* colors on the Amiga JKL */ } StGetScreenSize(&width, &height); size = (width > height) ? width : height; if ((value = slot_value(object, s_has_h_scroll)) != NIL) { v = (fixp(value)) ? getfixnum(value) : size; StGWSetHasHscroll(gwinfo, TRUE, v); } if ((value = slot_value(object, s_has_v_scroll)) != NIL) { v = (fixp(value)) ? getfixnum(value) : size; StGWSetHasVscroll(gwinfo, TRUE, v); } }
/* eql - internal eql function */ int eql P2C(LVAL, arg1, LVAL, arg2) { /* compare the arguments */ if (arg1 == arg2) return (TRUE); else if (arg1 != NIL) { switch (ntype(arg1)) { case FIXNUM: return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE); #ifdef BIGNUMS case RATIO: return (ratiop(arg2) ? compareratio(arg1, arg2) : FALSE); case BIGNUM: return (bignump(arg2) ? comparebignum(arg1, arg2) == 0 : FALSE); #endif case FLONUM: return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE); case COMPLEX: return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE); default: return (FALSE); } } else return (FALSE); }
LVAL xseispackrs(V) { int nm, n, matz, ierr; LVAL a, w, z, fv1, fv2; double *da, *dw, *dz, *dfv1, *dfv2; nm = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); a = xlgetarg(); w = xlgetarg(); matz = getfixnum(xlgafixnum()); z = xlgetarg(); fv1 = xlgetarg(); fv2 = xlgetarg(); xllastarg(); checkldim(nm, n); da = getlinalgdvec(0, nm * n, a); dw = getlinalgdvec(0, n, w); dz = (matz != 0) ? getlinalgdvec(0, nm * n, z) : NULL; dfv1 = getlinalgdvec(0, n, fv1); dfv2 = getlinalgdvec(0, n, fv2); eispack_rs(nm, n, da, dw, matz, dz, dfv1, dfv2, &ierr); return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr); }
/* 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)); }
LVAL xseispackch(V) { int nm, n, matz, ierr; LVAL ar, ai, w, zr, zi, fv1, fv2, fm1; double *dar, *dai, *dw, *dzr, *dzi, *dfv1, *dfv2, *dfm1; nm = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); ar = xlgetarg(); ai = xlgetarg(); w = xlgetarg(); matz = getfixnum(xlgafixnum()); zr = xlgetarg(); zi = xlgetarg(); fv1 = xlgetarg(); fv2 = xlgetarg(); fm1 = xlgetarg(); xllastarg(); checkldim(nm, n); dar = getlinalgdvec(0, nm * n, ar); dai = getlinalgdvec(0, nm * n, ai); dw = getlinalgdvec(0, n, w); dzr = (matz != 0) ? getlinalgdvec(0, nm * n, zr) : NULL; dzi = (matz != 0) ? getlinalgdvec(0, nm * n, zi) : NULL; dfv1 = getlinalgdvec(0, n, fv1); dfv2 = getlinalgdvec(0, n, fv2); dfm1 = getlinalgdvec(0, 2 * n, fm1); eispack_ch(nm, n, dar, dai, dw, matz, dzr, dzi, dfv1, dfv2, dfm1, &ierr); return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr); }
LVAL xslpzgesl(V) { LVAL a, ipvt, b; dcomplex *da, *db; int lda, offa, n, *dipvt, job, i, ilda; a = xlgetarg(); offa = getfixnum(xlgafixnum()); lda = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); ipvt = xlgetarg(); b = xlgetarg(); job = getfixnum(xlgafixnum()); xllastarg(); checkldim(lda, n); da = getlinalgzvec(offa, lda * n, a); dipvt = getlinalgivec(0, n, ipvt); db = getlinalgzvec(0, n, b); for (i = 0, ilda = 0; i < n; i++, ilda += lda) if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0) xlfail("matrix is (numerically) singular"); linpack_zgesl(da, lda, n, dipvt, db, job); return NIL; }
LVAL xslpzgedi(V) { LVAL a, ipvt, det, work; dcomplex *da, *ddet, *dwork; int lda, offa, n, *dipvt, job, i, ilda; a = xlgetarg(); offa = getfixnum(xlgafixnum()); lda = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); ipvt = xlgetarg(); det = xlgetarg(); work = xlgetarg(); job = getfixnum(xlgafixnum()); xllastarg(); checkldim(lda, n); da = getlinalgzvec(offa, lda * n, a); dipvt = getlinalgivec(0, n, ipvt); ddet = (job / 10 != 0) ? getlinalgzvec(0, 2, det) : NULL; dwork = getlinalgzvec(0, n, work); if (job % 10 != 0) for (i = 0, ilda = 0; i < n; i++, ilda += lda) if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0) xlfail("matrix is (numerically) singular"); linpack_zgedi(da, lda, n, dipvt, ddet, dwork, job); return NIL; }
LVAL xsbasekernelsmooth(V) { LVAL x, y, xs, ys, targ; int n, ns, error, ktype; double *dx, *dy, *dxs, *dys, width; n = getfixnum(xlgafixnum()); x = xlgetarg(); y = xlgetarg(); ns = getfixnum(xlgafixnum()); xs = xlgetarg(); ys = xlgetarg(); width = makefloat(xlgetarg()); targ = xlgasymbol(); xllastarg(); dx = getlinalgdvec(0, n, x); dy = null(y) ? NULL : getlinalgdvec(0, n, y); dxs = getlinalgdvec(0, ns, xs); dys = getlinalgdvec(0, ns, ys); switch (getstring(getpname(targ))[0]) { case 'U': ktype = 'U'; break; case 'T': ktype = 'T'; break; case 'G': ktype = 'G'; break; default: ktype = 'B'; break; } error = kernel_smooth(dx, dy, n, width, NULL, NULL, dxs, dys, ns, ktype); return error ? s_true : NIL; }
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); }
/* tiebreaker routine */ LOCAL int tiebreak P2C(LVAL *, px, LVAL *, py) { int ix = getfixnum(px[1]); int iy = getfixnum(py[1]); if (ix < iy) return(-1); else return(1); }
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */ LVAL xshlibinit() { LVAL subr, val, sym; xlshlib_modinfo_t *info = getnpaddr(xlganatptr()); FUNDEF *p = info->funs; FIXCONSTDEF *pfix = info->fixconsts; FLOCONSTDEF *pflo = info->floconsts; STRCONSTDEF *pstr = info->strconsts; struct version_info defversion; defversion.current = moreargs()?getfixnum(xlgafixnum()):-1; defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current; xllastarg(); if (! check_version(&defsysversion, &(info->sysversion))) xlfail("shared library not compatible with current system"); if (defversion.current >= 0 && ! check_version(&defversion, &(info->modversion))) xlfail("module not compatible with requested version"); xlsave1(val); val = NIL; if (p != NULL) for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) { subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0); setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE); val = cons(subr, val); if (p->fd_name != NULL) { sym = xlenter(p->fd_name); setfunction(sym, subr); } } if (pfix != NULL) for (; pfix->name != NULL; pfix++) { sym = xlenter(pfix->name); defconstant(sym, cvfixnum(pfix->val)); } if (pflo != NULL) for (; pflo->name != NULL; pflo++) { sym = xlenter(pflo->name); defconstant(sym, cvflonum(pflo->val)); } if (pstr != NULL) for (; pstr->name != NULL; pstr++) { sym = xlenter(pstr->name); defconstant(sym, cvstring(pstr->val)); } if (info->sysversion.current >= MAKEVERSION(0,1)) { ULONGCONSTDEF *pulong = info->ulongconsts; if (pulong != NULL) for (; pulong->name != NULL; pulong++) { sym = xlenter(pulong->name); defconstant(sym, ulong2lisp(pulong->val)); } } xlpop(); return xlnreverse(val); }
LVAL xlc_snd_fetch_array(void) { sound_type arg1 = getsound(xlgasound()); long arg2 = getfixnum(xlgafixnum()); long arg3 = getfixnum(xlgafixnum()); LVAL result; xllastarg(); result = snd_fetch_array(arg1, arg2, arg3); return (result); }
void nyx_get_label(unsigned int index, double *start_time, double *end_time, const char **label) { LVAL s = nyx_result; LVAL label_expr; LVAL t0_expr; LVAL t1_expr; LVAL str_expr; if (nyx_get_type(nyx_result) != nyx_labels) { return; } while (index) { index--; s = cdr(s); if (s == NULL) { // index was larger than number of labels return; } } /* We either have (t0 "label") or (t0 t1 "label") */ label_expr = car(s); t0_expr = car(label_expr); t1_expr = car(cdr(label_expr)); if (stringp(t1_expr)) { str_expr = t1_expr; t1_expr = t0_expr; } else { str_expr = car(cdr(cdr(label_expr))); } if (floatp(t0_expr)) { *start_time = getflonum(t0_expr); } else if (fixp(t0_expr)) { *start_time = (double)getfixnum(t0_expr); } if (floatp(t1_expr)) { *end_time = getflonum(t1_expr); } else if (fixp(t1_expr)) { *end_time = (double)getfixnum(t1_expr); } *label = (const char *)getstring(str_expr); }
LVAL xlc_snd_fft(void) { sound_type arg1 = getsound(xlgasound()); long arg2 = getfixnum(xlgafixnum()); long arg3 = getfixnum(xlgafixnum()); LVAL arg4 = xlgetarg(); LVAL result; xllastarg(); result = snd_fft(arg1, arg2, arg3, arg4); return (result); }
LVAL xlc_snd_avg(void) { sound_type arg1 = getsound(xlgasound()); long arg2 = getfixnum(xlgafixnum()); long arg3 = getfixnum(xlgafixnum()); long arg4 = getfixnum(xlgafixnum()); sound_type result; xllastarg(); result = snd_avg(arg1, arg2, arg3, arg4); return cvsound(result); }
LVAL xlc_seq_insert_macctrl(void) { seq_type arg1 = getseq(xlgaseq()); long arg2 = getfixnum(xlgafixnum()); long arg3 = getfixnum(xlgafixnum()); long arg4 = getfixnum(xlgafixnum()); long arg5 = getfixnum(xlgafixnum()); long arg6 = getfixnum(xlgafixnum()); xllastarg(); insert_macctrl(arg1, arg2, arg3, arg4, arg5, arg6); return NIL; }
LVAL xlc_snd_phasevocoder(void) { sound_type arg1 = getsound(xlgasound()); sound_type arg2 = getsound(xlgasound()); long arg3 = getfixnum(xlgafixnum()); long arg4 = getfixnum(xlgafixnum()); long arg5 = getfixnum(xlgafixnum()); sound_type result; xllastarg(); result = snd_phasevocoder(arg1, arg2, arg3, arg4, arg5); return cvsound(result); }
LVAL xssweepinplace(V) { int rows, cols, k; double *a, tol; rows = getfixnum(xlgafixnum()); cols = getfixnum(xlgafixnum()); getsweepdata(rows * cols, &a); k = getfixnum(xlgafixnum()); tol = makefloat(xlgetarg()); return sweepinplace(rows, cols, a, k, tol) ? s_true : NIL; }
LVAL xsgen2linalg(V) { LVAL x, type; int m, n, trans; x = xlgetarg(); m = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); type = xlgetarg(); trans = moreargs() ? ! null(xlgetarg()) : FALSE; xllastarg(); return gen2linalg(x, m, n, type, trans); }
LVAL iview_std_mark_points_in_rect(V) { IVIEW_WINDOW w; int left, top, width, height; w = (IVIEW_WINDOW) get_iview_address(xlgaobject()); left = getfixnum(xlgafixnum()); top = getfixnum(xlgafixnum()); width = getfixnum(xlgafixnum()); height = getfixnum(xlgafixnum()); xllastarg(); IViewStdMarkPointsInRect(w, left, top, width, height); return(NIL); }
LVAL xstransposeinto(V) { LVAL x, y; int m, n; x = xlgetarg(); m = getfixnum(xlgafixnum()); n = getfixnum(xlgafixnum()); y = xlgetarg(); xllastarg(); transposeinto(x, m, n, y); return y; }
/* 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); }
/* xintchar - convert a character to an integer */ LVAL xintchar(void) { LVAL arg; arg = xlgafixnum(); xllastarg(); return (cvchar((int)getfixnum(arg))); }
int nyx_get_int() { if (nyx_get_type(nyx_result) != nyx_int) return -1; return getfixnum(nyx_result); }
/* getivcnt - get the number of instance variables for a class */ LOCAL int getivcnt(LVAL cls, int ivar) { LVAL cnt; if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt)) xlfail("bad value for instance variable count"); return ((int)getfixnum(cnt)); }
/* xpoke - poke a value into memory */ LVAL xpoke(void) { LVAL val; int *adr; /* get the address and the new value */ val = xlgafixnum(); adr = (int *)getfixnum(val); val = xlgafixnum(); xllastarg(); /* store the new value */ *adr = (int)getfixnum(val); /* return the new value */ return (val); }