/* clisnew - initialize a new class */
LVAL clisnew(void)
{
LVAL self,ivars,cvars,super;
int n;
/* get self, the ivars, cvars and superclass */
self = xlgaobject();
ivars = xlgalist();
cvars = (moreargs() ? xlgalist() : NIL);
super = (moreargs() ? xlgaobject() : object);
xllastarg();
/* store the instance and class variable lists and the superclass */
setivar(self,IVARS,ivars);
setivar(self,CVARS,cvars);
setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
setivar(self,SUPERCLASS,super);
/* compute the instance variable count */
n = listlength(ivars);
setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
n += getivcnt(super,IVARTOTAL);
setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
/* return the new class object */
return (self);
}
/* 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);
}
/* 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);
}
/* 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);
}
/* xwrfloat - write a float to a file */
LVAL xwrfloat(void)
{
LVAL val, fptr;
union {
char b[8];
float f;
double d;
} v;
int n = 4;
int i;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
/* get the float and file pointer and optional byte count */
val = xlgaflonum();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n != 4 && n != 8) {
xlerror("must be 4 or 8 bytes", count);
}
}
xllastarg();
#ifdef XL_BIG_ENDIAN
/* flip the bytes */
index = n - 1 - index;
incr = -incr;
#endif
/* build output v.b */
if (n == 4) v.f = (float) getflonum(val);
else v.d = getflonum(val);
/* put bytes to the file */
for (i = 0; i < n; i++) {
xlputc(fptr, v.b[index]);
index += incr;
}
/* return the flonum */
return val;
}
/* 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);
}
LVAL xsanycomplex(V)
{
while (moreargs())
if (anycomplex(xlgetarg()))
return s_true;
return NIL;
}
/* xgensym - generate a symbol */
LVAL xgensym(void)
{
char sym[STRMAX+11]; /* enough space for prefix and number */
LVAL x;
/* get the prefix or number */
if (moreargs()) {
x = xlgetarg();
switch (ntype(x)) {
case SYMBOL:
x = getpname(x);
case STRING:
strncpy(gsprefix, (char *) getstring(x),STRMAX);
gsprefix[STRMAX] = '\0';
break;
case FIXNUM:
gsnumber = getfixnum(x);
break;
default:
xlerror("bad argument type",x);
}
}
xllastarg();
/* create the pname of the new symbol */
sprintf(sym,"%s%d",gsprefix,gsnumber++);
/* make a symbol with this print name */
return (xlmakesym(sym));
}
/* 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;
}
LVAL xssample(V)
{
LVAL x, result, temp, elem;
int n, N, replace, i, j;
x = xlgaseq();
n = getfixnum(xlgafixnum());
N = seqlen(x);
replace = (moreargs()) ? (xlgetarg() != NIL) : FALSE;
xllastarg();
if (! replace && n > N) n = N;
xlstkcheck(4);
xlprotect(x);
xlsave(result);
xlsave(elem);
xlsave(temp);
x = (listp(x)) ? coerce_to_tvec(x, s_true) : copyvector(x);
result = NIL;
if (N > 0 && n > 0) {
for (i = 0; i < n; i++) {
j = (replace) ? osrand(N) : i + osrand(N - i);
elem = gettvecelement(x, j);
result = cons(elem, result);
if (! replace) { /* swap elements i and j */
temp = gettvecelement(x, i);
settvecelement(x, i, elem);
settvecelement(x, j, temp);
}
}
}
xlpopn(4);
return(result);
}
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));
}
/* handle simple imperative messages with no arguments */
static LVAL simple_menu_message P1C(int, which)
{
LVAL menu;
LVAL arg = NIL;
int set = FALSE;
menu = xlgaobject();
if (which == 'E') {
if (moreargs()) {
set = TRUE;
arg = (xlgetarg() != NIL) ? s_true : NIL;
}
}
xllastarg();
switch (which) {
case 'A': StMObAllocate(menu); break;
case 'D': StMObDispose(menu); break;
case 'E': if (set) {
set_slot_value(menu, s_enabled, arg);
StMObEnable(menu, (arg != NIL));
}
return(slot_value(menu, s_enabled));
case 'I': StMObInstall(menu); break;
case 'R': StMObRemove(menu); break;
case 'U': update_menu(menu); break;
default: xlfail("unknown message");
}
return(NIL);
}
LVAL xsaxpy(V)
{
LVAL result, next, tx, a, x, y;
int i, j, m, n, start, end, lower;
double val;
a = getdarraydata(xlgamatrix());
x = xlgaseq();
y = xlgaseq();
lower = (moreargs() && xlgetarg() != NIL) ? TRUE : FALSE;
n = seqlen(x);
m = seqlen(y);
if (lower && m != n)
xlfail("dimensions do not match");
xlsave1(result);
result = mklist(m, NIL);
for (i = 0, start = 0, next = result;
i < m;
i++, start += n, next = cdr(next)) {
val = makefloat(getnextelement(&y, i));
end = (lower) ? i +1 : n;
for (j = 0, tx = x; j < end; j++) {
val += makefloat(getnextelement(&tx, j))
* makefloat(gettvecelement(a, start + j));
}
rplaca(next, cvflonum((FLOTYPE) val));
}
xlpop();
return(result);
}
LVAL xsmake_rotation(V)
{
LVAL x, y, dx, dy, val;
double alpha=0.0;
int n, use_alpha = FALSE;
x = xlgetarg();
y = xlgetarg();
if (moreargs()) {
use_alpha = TRUE;
alpha = makefloat(xlgetarg());
}
xllastarg();
xlstkcheck(3);
xlsave(dx);
xlsave(dy);
xlsave(val);
dx = coerce_to_tvec(x, s_c_double);
dy = coerce_to_tvec(y, s_c_double);
n = gettvecsize(dx);
if (gettvecsize(dy) != n)
xlfail("sequences not the same length");
val = mktvec(n * n, s_c_double);
make_rotation(n, REDAT(val), REDAT(dx), REDAT(dy), use_alpha, alpha);
val = linalg2genmat(val, n, n, FALSE);
xlpopn(3);
return val;
}
LVAL xschol_decomp(V)
{
LVAL a, da, val;
int n;
double maxoffl, maxadd;
a = xlgadarray();
maxoffl = moreargs() ? makefloat(xlgetarg()) : 0.0;
xllastarg();
checksquarematrix(a);
n = numrows(a);
xlstkcheck(2);
xlsave(da);
xlsave(val);
da = gen2linalg(a, n, n, s_c_double, FALSE);
choldecomp(REDAT(da), n, maxoffl, &maxadd);
val = consa(cvflonum((FLOTYPE) maxadd));
val = cons(linalg2genmat(da, n, n, FALSE), val);
xlpopn(2);
return val;
}
LVAL iview_transformation(V)
{
IVIEW_WINDOW w;
LVAL m = NULL, object;
int set = FALSE;
int vars;
object = xlgaobject();
w = (IVIEW_WINDOW) get_iview_address(object);
if (moreargs()) {
set = TRUE;
m = xlgetarg();
}
vars = IViewNumVariables(w);
if (set) {
if (m == NIL) IViewSetIdentityTransformation(w);
else {
set_internal_transformation(vars, m, NIL);
IViewSetTransformation(w, transform);
}
check_redraw(object, TRUE, TRUE);
}
else m = (IViewIsTransformed(w))
? make_transformation(IViewTransformation(w), vars) : NIL;
return(m);
}
LVAL xsfft(V)
{
LVAL data, result, x, work;
int n, isign;
data = xlgaseq();
isign = (moreargs() && xlgetarg() != NIL) ? -1.0 : 1.0;
xllastarg();
/* check and convert the data */
n = seqlen(data);
if (n <= 0)
xlfail("not enough data");
xlstkcheck(2);
xlsave(x);
xlsave(work);
x = gen2linalg(data, n, 1, s_c_dcomplex, FALSE);
work = mktvec(4 * n + 15, s_c_double);
cfft(n, REDAT(x), REDAT(work), isign);
result = listp(x) ? coerce_to_list(x) : coerce_to_tvec(x, s_true);
xlpopn(2);
return result;
}
/* xnconc - destructively append lists */
LVAL xnconc(void)
{
LVAL next,last=NULL,val;
/* initialize */
val = NIL;
/* concatenate each argument */
if (moreargs()) {
while (xlargc > 1) {
/* ignore everything except lists */
if ((next = nextarg()) && consp(next)) {
/* concatenate this list to the result list */
if (val) rplacd(last,next);
else val = next;
/* find the end of the list */
while (consp(cdr(next)))
next = cdr(next);
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* return the list */
return (val);
}
/* xappend - built-in function append */
LVAL xappend(void)
{
LVAL list,last=NULL,next,val;
/* protect some pointers */
xlsave1(val);
/* initialize */
val = NIL;
/* append each argument */
if (moreargs()) {
while (xlargc > 1) {
/* append each element of this list to the result list */
for (list = nextarg(); consp(list); list = cdr(list)) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xread - read an expression */
LVAL xread(void)
{
LVAL fptr,eof,rflag,val;
/* get file pointer and eof value */
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
eof = (moreargs() ? xlgetarg() : NIL);
rflag = (moreargs() ? xlgetarg() : NIL);
xllastarg();
/* read an expression */
if (!xlread(fptr,&val,rflag != NIL))
val = eof;
/* return the expression */
return (val);
}
static LVAL item_ivar P1C(int, which)
{
LVAL item;
item = xlgaobject();
if (moreargs()) set_item_ivar(which, item, xlgetarg());
return(get_item_ivar(which, item));
}
/* 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;
}
/* :DELETE-ITEMS Method */
LVAL xsdelete_items(V)
{
LVAL menu;
menu = xlgaobject();
while (moreargs())
delete_menu_item(menu, xlgaobject());
return(NIL);
}
/* xrdfloat - read a float from a file */
LVAL xrdfloat(void)
{
LVAL fptr;
union {
char b[8];
float f;
double d;
} rslt;
int n = 4;
int i;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
/* get file pointer */
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
/* get byte count */
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n != 4 && n != 8) {
xlerror("must be 4 or 8 bytes", count);
}
}
xllastarg();
#ifdef XL_BIG_ENDIAN
/* flip the bytes */
index = n - 1 - index;
incr = -incr;
#endif
for (i = 0; i < n; i++) {
int ch = xlgetc(fptr);
if (ch == EOF) return NIL;
rslt.b[index] = ch;
index += incr;
}
/* return result */
return cvflonum(n == 4 ? rslt.f : rslt.d);
}
/* positive count means write big-endian */
LVAL xwrint(void)
{
LVAL val, fptr;
unsigned char b[4];
long i;
int n = 4;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
int v;
/* get the int and file pointer and optional byte count */
val = xlgafixnum();
v = getfixnum(val);
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
index = n - 1;
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n > 4) {
xlerror("4-byte limit", count);
}
}
xllastarg();
/* build output b as little-endian */
for (i = 0; i < n; i++) {
b[i] = (unsigned char) v;
v = v >> 8;
}
/* put bytes to the file */
while (n) {
n--;
xlputc(fptr, b[index]);
index += incr;
}
/* return the integer */
return val;
}
LVAL iview_spin_angle(V)
{
LVAL object;
object = xlgaobject();
if (moreargs()) set_angle(object, makefloat(xlgetarg()));
xllastarg();
return(slot_value(object, s_rotation_angle));
}
/* MAKE-SUBR addr &optional mulvalp */
LVAL xmakesubr()
{
LVAL val;
LVAL (*fun)(void) = (LVAL (*)(void)) getnpaddr(xlganatptr());
int mv = moreargs() ? (null(xlgetarg()) ? FALSE : TRUE) : FALSE;
xllastarg();
val = cvsubr(fun, SUBR, 0);
setmulvalp(val, mv);
return val;
}
LVAL iview_spin_depth_cuing(V)
{
LVAL object;
object = xlgaobject();
if (moreargs())
set_cuing(object, (xlgetarg() != NIL) ? TRUE : FALSE);
xllastarg();
return((is_cuing(object)) ? s_true : NIL);
}
/* xpkchar - peek at a character from a file */
LVAL xpkchar(void)
{
LVAL flag,fptr;
int ch;
/* peek flag and get file pointer */
flag = (moreargs() ? xlgetarg() : NIL);
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
xllastarg();
/* skip leading white space and get a character */
if (flag)
while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
xlgetc(fptr);
else
ch = xlpeek(fptr);
/* return the character */
return (ch == EOF ? NIL : cvchar(ch));
}
LVAL iview_spin_showing_axes(V)
{
LVAL object;
object = xlgaobject();
if (moreargs())
set_showing_axes(object, (xlgetarg() != NIL) ? TRUE : FALSE);
xllastarg();
return((is_showing_axes(object)) ? s_true : NIL);
}
