/* 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));
}
static NODE *binary(NODE *args, int fcn)
{
long ival,iarg;
float fval,farg;
NODE *arg;
int imode;
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5)) {
ival = ((arg)->n_info.n_xint.xi_int);
imode = 1;
}
else if (((arg) && (arg)->n_type == 9)) {
fval = ((arg)->n_info.n_xfloat.xf_float);
imode = 0;
}
else
xlerror("bad argument type",arg);
if (fcn == '-' && args == (NODE *)0)
if (imode)
ival = -ival;
else
fval = -fval;
while (args) {
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5))
if (imode) iarg = ((arg)->n_info.n_xint.xi_int);
else farg = (float)((arg)->n_info.n_xint.xi_int);
else if (((arg) && (arg)->n_type == 9))
if (imode) { fval = (float)ival; farg = ((arg)->n_info.n_xfloat.xf_float); imode = 0; }
else farg = ((arg)->n_info.n_xfloat.xf_float);
else
xlerror("bad argument type",arg);
if (imode)
switch (fcn) {
case '+': ival += iarg; break;
case '-': ival -= iarg; break;
case '*': ival *= iarg; break;
case '/': checkizero(iarg); ival /= iarg; break;
case '%': checkizero(iarg); ival %= iarg; break;
case 'M': if (iarg > ival) ival = iarg; break;
case 'm': if (iarg < ival) ival = iarg; break;
case '&': ival &= iarg; break;
case '|': ival |= iarg; break;
case '^': ival ^= iarg; break;
default: badiop();
}
else
switch (fcn) {
case '+': fval += farg; break;
case '-': fval -= farg; break;
case '*': fval *= farg; break;
case '/': checkfzero(farg); fval /= farg; break;
case 'M': if (farg > fval) fval = farg; break;
case 'm': if (farg < fval) fval = farg; break;
case 'E': fval = pow(fval,farg); break;
default: badfop();
}
}
return (imode ? cvfixnum(ival) : cvflonum(fval));
}
/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
/* xlputc - put a character to a file or stream */
VOID xlputc P2C(LVAL, fptr, int, ch)
{
LVAL lptr;
FILEP fp;
/* TAA MOD -- delete output to NIL and character counting 1/97 */
/* check for output to an unnamed stream */
if (ntype(fptr) == USTREAM) { /* TAA MOD, was ustreamp() */
lptr = consa(cvchar((unsigned char)ch));
if (gettail(fptr)!=NIL)
rplacd(gettail(fptr),lptr);
else
sethead(fptr,lptr);
settail(fptr,lptr);
}
/* otherwise, check for terminal output or file output */
else {
fp = getfile(fptr);
if (fp == CLOSED) /* TAA MOD -- give error */
xlfail("can't write closed stream");
if (fp == CONSOLE) /* TAA MOD -- for redirecting */
ostputc(ch);
else {
if ((fptr->n_sflags & S_FORWRITING) == 0)
xlerror("can't write read-only file stream", fptr);
if ((fptr->n_sflags & S_WRITING) == 0) {
/* possible direction change*/
if (fptr->n_sflags & S_READING) {
OSSEEKCUR(fp,
(getsavech(fptr)?(setsavech(fptr,'\0'),-1L):0L));
}
fptr->n_sflags |= S_WRITING;
fptr->n_sflags &= ~S_READING;
#ifdef BIGNUMS
if ((fptr->n_sflags & S_BINARY) == 0)
#endif
fptr->n_cpos = 0; /* best guess */
}
#ifdef BIGNUMS
if ((fptr->n_sflags & S_BINARY) == 0) {
#endif
if (ch == '\n') fptr->n_cpos = 0;
else fptr->n_cpos++;
#ifdef BIGNUMS
}
#endif
#ifdef OSAGETC
if (((fptr->n_sflags & S_BINARY) ?
OSPUTC(ch,fp) : OSAPUTC(ch,fp)) == EOF)
/* TAA MOD to check for write to RO file */
xlerror("write failed", fptr);
#else
if (OSPUTC(ch,fp)==EOF) /* TAA MOD to check for write to RO file*/
xlerror("write failed", fptr);
#endif
}
}
}
/* Get a string for use by AppendMenu. */
static char *get_item_string(LVAL item)
{
LVAL title;
if (! menu_item_p(item)) xlerror("not a menu item", item);
title = slot_value(item, s_title);
if (! stringp(title)) xlerror("title is not a string", title);
return((char *) getstring(title));
}
/* xsendmsg - send a message to an object */
LOCAL LVAL xsendmsg(LVAL obj, LVAL cls, LVAL sym)
{
LVAL msg=NULL,msgcls,method,val,p;
/* look for the message in the class or superclasses */
for (msgcls = cls; msgcls; ) {
/* lookup the message in this class */
for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
if ((msg = car(p)) && car(msg) == sym)
goto send_message;
/* look in class's superclass */
msgcls = getivar(msgcls,SUPERCLASS);
}
/* message not found */
xlerror("no method for this message",sym);
send_message:
/* insert the value for 'self' (overwrites message selector) */
*--xlargv = obj;
++xlargc;
/* invoke the method */
if ((method = cdr(msg)) == NULL)
xlerror("bad method",method);
switch (ntype(method)) {
case SUBR:
val = (*getsubr(method))();
break;
case CLOSURE:
if (gettype(method) != s_lambda)
xlerror("bad method",method);
val = evmethod(obj,msgcls,method);
break;
default:
xlerror("bad method",method);
}
/* after creating an object, send it the ":isnew" message */
if (car(msg) == k_new && val) {
xlprot1(val);
xsendmsg(val,getclass(val),k_isnew);
xlpop();
}
/* return the result value */
return (val);
}
NODE *xlevmatch(int type, NODE **pargs)
{
NODE *arg;
arg = xlevarg(pargs);
if (type == 3) {
if (arg && ((arg)->n_type) != 3)
xlerror("bad argument type",arg);
}
else {
if (arg == (NODE *)0 || ((arg)->n_type) != type)
xlerror("bad argument type",arg);
}
return (arg);
}
/* 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 elementseq P1C(LVAL, x)
{
if (! compoundp(x)) xlerror("not a compound data item", x);
x = compounddataseq(x);
if (all_simple(x)) return(x);
else return(elementlist(x));
}
/* 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);
}
}
/* xlgetfname - get a filename */
LVAL xlgetfname(V)
{
LVAL name;
/* get the next argument */
name = xlgetarg();
/* get the filename string */
#ifdef FILETABLE
if (streamp(name) && getfile(name) > CONSOLE)
/* "Steal" name from file stream */
name = cvstring(filetab[getfile(name)].tname);
else
#endif
if (symbolp(name))
name = getpname(name);
else if (!stringp(name))
xlbadtype(name);
if (getslength(name) >= FNAMEMAX)
xlerror("file name too long", name);
/* return the name */
return (name);
}
/* get and check a menu from the argument list */
LVAL xsgetmenu(V)
{
LVAL menu;
menu = xlgaobject();
if (! menu_p(menu)) xlerror("not a menu", menu);
return(menu);
}
LOCAL LVAL getlinalgdata P4C(int, off, int, n, LVAL, arg, int, type)
{
LVAL x;
x = darrayp(arg) ? getdarraydata(arg) : arg;
if (! tvecp(x))
xlbadtype(arg);
if (off < 0 || n < 0 || gettvecsize(x) < off + n)
xlerror("incompatible with access indices", x);
switch (type) {
case IN:
if (gettvectype(x) != CD_INT)
xlbadtype(x);
break;
case RE:
switch(gettvectype(x)) {
case CD_FLOTYPE:
case CD_DOUBLE:
break;
default:
xlbadtype(x);
}
break;
case CX:
switch(gettvectype(x)) {
case CD_CXFLOTYPE:
case CD_DCOMPLEX:
break;
default:
xlbadtype(x);
}
break;
}
return x;
}
/* xlength - return the length of a list or string */
LVAL xlength(void)
{
FIXTYPE n=0;
LVAL arg;
/* get the list or string */
arg = xlgetarg();
xllastarg();
/* find the length of a list */
if (listp(arg))
for (n = 0; consp(arg); n++)
arg = cdr(arg);
/* find the length of a string */
else if (stringp(arg))
n = (FIXTYPE)getslength(arg)-1;
/* find the length of a vector */
else if (vectorp(arg))
n = (FIXTYPE)getsize(arg);
/* otherwise, bad argument type */
else
xlerror("bad argument type",arg);
/* return the length */
return (cvfixnum(n));
}
/* 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));
}
static NODE *predicate(NODE *args, int fcn)
{
float fval;
long ival;
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
if (((arg) && (arg)->n_type == 5)) {
ival = ((arg)->n_info.n_xint.xi_int);
switch (fcn) {
case '-': ival = (ival < 0); break;
case 'Z': ival = (ival == 0); break;
case '+': ival = (ival > 0); break;
case 'E': ival = ((ival & 1) == 0); break;
case 'O': ival = ((ival & 1) != 0); break;
default: badiop();
}
}
else if (((arg) && (arg)->n_type == 9)) {
fval = ((arg)->n_info.n_xfloat.xf_float);
switch (fcn) {
case '-': ival = (fval < 0); break;
case 'Z': ival = (fval == 0); break;
case '+': ival = (fval > 0); break;
default: badfop();
}
}
else
xlerror("bad argument type",arg);
return (ival ? true : (NODE *)0);
}
/* xlopen - open a text or binary file */
LVAL xlopen(int binaryflag)
{
char *name,*mode=NULL;
FILE *fp;
LVAL dir;
/* get the file name and direction */
name = (char *)getstring(xlgetfname());
if (!xlgetkeyarg(k_direction,&dir))
dir = k_input;
/* get the mode */
if (dir == k_input)
mode = "r";
else if (dir == k_output)
mode = "w";
else
xlerror("bad direction",dir);
/* try to open the file */
if (binaryflag) {
fp = osbopen(name,mode);
} else {
fp = osaopen(name,mode);
}
return (fp ? cvfile(fp) : NIL);
}
VOID standard_hardware_clobber P1C(LVAL, object)
{
LVAL addr, oblist;
if (! objectp(object)) xlerror("not an object", object);
addr = slot_value(object, s_hardware_address);
oblist = getvalue(s_hardware_objects);
if (! listp(oblist)) xlerror("not a list", oblist);
setvalue(s_hardware_objects, xlcallsubr2(xdelete, addr, oblist));
set_slot_value(object, s_hardware_address, NIL);
send_callback_message(object, sk_clobber);
}
LOCAL VOID set_hardware_address P3C(CPTR, ptr, LVAL, object, int *, type)
{
LVAL t, p, last, result, oblistsym, newoblist;
if (! objectp(object)) xlerror("not an object", object);
oblistsym = s_hardware_objects;
if (! consp(getvalue(oblistsym))) setvalue(oblistsym, NIL);
xlstkcheck(4);
xlsave(t);
xlsave(p);
xlsave(result);
xlsave(newoblist);
t = cvfixnum((FIXTYPE) time_stamp);
p = cvfixnum((FIXTYPE) ptr);
result = last = consa(object);
result = cons(p, result);
result = cons(t, result);
newoblist = cons(result, getvalue(oblistsym));
setvalue(oblistsym, newoblist);
set_slot_value(object, s_hardware_address, result);
for (;*type != NONE; type++, last = cdr(last)) {
t = cvfixnum((FIXTYPE) *type);
t = consa(t);
rplacd(last, t);
}
xlpopn(4);
}
static VOID set_internal_transformation P3C(int, vars, LVAL, m, LVAL, b)
{
int i, j, k, rows, cols;
LVAL data;
if (vars <= 0) return;
if (vars > maxvars) {
maxvars = 0;
StFree(transformdata);
StFree(transform);
StFree(inbasis);
transformdata = (double *) StCalloc(vars * vars, sizeof(double));
transform = (double **) StCalloc(vars, sizeof(double *));
for (i = 0; i < vars; i++) transform[i] = transformdata + vars * i;
inbasis = (int *) StCalloc(vars, sizeof(double));
maxvars = vars;
}
if (! matrixp(m)) xlerror("not a matrix", m);
rows = numrows(m);
cols = numcols(m);
if (rows > vars) rows = vars;
if (cols > vars) cols = vars;
if (rows != cols) xlerror("bad transformation matrix", m);
/* fill in upper left corner of transform from m; rest is identity */
data = getdarraydata(m);
for (i = 0, k = 0; i < rows; i++) {
for (j = 0; j < cols; j++, k++)
transform[i][j] = makefloat(gettvecelement(data, k));
for (j = cols; j < vars; j++)
transform[i][j] = (i == j) ? 1.0 : 0.0;
}
for (i = rows; i < vars; i++)
for (j = 0; j < vars; j++)
transform[i][j] = (i == j) ? 1.0 : 0.0;
/* figure out basis elements using b and size of m */
if (b != NIL) {
if (! seqp(b)) xlerror("not a sequence", b);
if (seqlen(b) != rows) xlerror("wrong length for basis", b);
for (i = 0; i < rows; i++)
inbasis[i] = (getnextelement(&b, i) != NIL) ? TRUE : FALSE;
}
else for (i = 0; i < rows; i++) inbasis[i] = TRUE;
for (i = rows; i < vars; i++) inbasis[i] = FALSE;
}
/* get and check a menu item from the argument stack */
LVAL xsgetmenuitem(V)
{
LVAL item;
item = xlgaobject();
if (! menu_item_p(item)) xlerror("not a menu item", item);
return(item);
}
/* xlgetc - get a character from a file or stream */
int xlgetc P1C(LVAL, fptr)
{
LVAL lptr,cptr=NULL;
FILEP fp;
int ch;
/* check for input from nil */
if (fptr == NIL)
ch = EOF;
/* otherwise, check for input from a stream */
else if (ustreamp(fptr)) {
if ((lptr = gethead(fptr)) == NIL)
ch = EOF;
else {
if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
xlfail("bad stream");
sethead(fptr,lptr = cdr(lptr));
if (lptr == NIL)
settail(fptr,NIL);
ch = getchcode(cptr);
}
}
/* otherwise, check for a buffered character */
else if ((ch = getsavech(fptr)) != 0)
setsavech(fptr,'\0');
/* otherwise, check for terminal input or file input */
else {
fp = getfile(fptr);
if (fp == CLOSED) /* TAA MOD -- give error */
xlfail("can't read closed stream");
else if (fp == CONSOLE)
/* TAA MOD -- revamped for redirecting */
ch = ostgetc();
else {
if ((fptr->n_sflags & S_FORREADING) == 0)
xlerror("can't read write-only file stream", fptr);
if ((fptr->n_sflags & S_READING) == 0) {
/* possible direction change*/
if (fptr->n_sflags & S_WRITING) {
OSSEEKCUR(fp,0L);
}
fptr->n_sflags |= S_READING;
fptr->n_sflags &= ~S_WRITING;
}
#ifdef OSAGETC
ch = (fptr->n_sflags & S_BINARY) ? OSGETC(fp) : OSAGETC(fp);
#else
ch = OSGETC(fp);
#endif
}
}
/* return the character */
return (ch);
}
PointState decode_point_state P1C(LVAL, state)
{
if (state == s_invisible) return(pointInvisible);
else if (state == s_normal) return(pointNormal);
else if (state == s_hilited) return(pointHilited);
else if (state == s_selected) return(pointSelected);
else xlerror("unknown point state", state);
return pointNormal; /* not reached */
}
LOCAL LVAL get_plot_stream()
{
LVAL stream;
stream = getvalue(s_plot_output);
if (! streamp(stream) && ! ustreamp(stream)) xlerror("not a stream", stream);
return(stream);
}
/* append list of items to the menu */
static VOID append_items P2C(LVAL, menu, LVAL, new_items)
{
LVAL next, item, item_list;
/* Check all items are menu items and not installed */
for (next = new_items; consp(next); next = cdr(next)) {
item = car(next);
if (! menu_item_p(item)) xlerror("not a menu item", item);
if (item_installed_p(item)) xlerror("item already installed", item);
}
/* add items to the item list and set items menus to menu */
for (next = new_items; consp(next); next = cdr(next)) {
item = car(next);
item_list = rplac_end(slot_value(menu, s_items), item);
set_slot_value(menu, s_items,item_list);
set_slot_value(item, s_menu, menu);
}
if (StMObAllocated(menu)) StMObAppendItems(menu, new_items);
}
/* xsubseq - return a subsequence */
LVAL xsubseq(void)
{
unsigned char *srcp,*dstp;
int start,end,len;
LVAL src,dst;
/* get string and starting and ending positions */
src = xlgastring();
/* get the starting position */
dst = xlgafixnum(); start = (int)getfixnum(dst);
if (start < 0 || start > getslength(src) - 1)
xlerror("string index out of bounds",dst);
/* get the ending position */
if (moreargs()) {
dst = xlgafixnum(); end = (int)getfixnum(dst);
if (end < 0 || end > getslength(src) - 1)
xlerror("string index out of bounds",dst);
}
else
end = getslength(src) - 1;
xllastarg();
/* setup the source pointer */
srcp = getstring(src) + start;
len = end - start;
/* make a destination string and setup the pointer */
dst = new_string(len+1);
dstp = getstring(dst);
/* copy the source to the destination */
while (--len >= 0)
*dstp++ = *srcp++;
*dstp = '\0';
/* return the substring */
return (dst);
}
/* pname - parse a symbol/package name */
LOCAL int pname(LVAL fptr,int *pescflag)
{
int mode,ch,i;
LVAL type;
/* initialize */
*pescflag = FALSE;
mode = NORMAL;
i = 0;
/* accumulate the symbol name */
while (mode != DONE) {
/* handle normal mode */
while (mode == NORMAL)
if ((ch = xlgetc(fptr)) == EOF)
mode = DONE;
else if ((type = tentry(ch)) == k_sescape) {
i = storech(buf,i,checkeof(fptr));
*pescflag = TRUE;
}
else if (type == k_mescape) {
*pescflag = TRUE;
mode = ESCAPE;
}
else if (type == k_const
|| (consp(type) && car(type) == k_nmacro))
i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
else
mode = DONE;
/* handle multiple escape mode */
while (mode == ESCAPE)
if ((ch = xlgetc(fptr)) == EOF)
badeof(fptr);
else if ((type = tentry(ch)) == k_sescape)
i = storech(buf,i,checkeof(fptr));
else if (type == k_mescape)
mode = NORMAL;
else
i = storech(buf,i,ch);
}
buf[i] = 0;
/* check for a zero length name */
if (i == 0)
xlerror("zero length name", s_unbound);
/* unget the last character and return it */
xlungetc(fptr,ch);
return (ch);
}
/* return value of a number coerced to a FLOTYPE */
FLOTYPE makefloat P1C(LVAL, x)
{
switch (ntype(x)) {
case FIXNUM: return ((FLOTYPE) getfixnum(x));
case FLONUM: return getflonum(x);
#ifdef BIGNUMS
case BIGNUM: return cvtbigflonum(x);
case RATIO: return cvtratioflonum(x);
#endif
}
xlerror("not a real number", x);
return 0.0; /* never reached */
}
/* xerror - special form 'error' */
LVAL xerror(void)
{
LVAL emsg,arg;
/* get the error message and the argument */
emsg = xlgastring();
arg = (moreargs() ? xlgetarg() : s_unbound);
xllastarg();
/* signal the error */
xlerror((char *) getstring(emsg),arg);
return NIL; /* won't ever happen */
}
NODE *xlgetfile(NODE **pargs)
{
NODE *arg;
if (arg = xlarg(pargs)) {
if (((arg) && (arg)->n_type == 8)) {
if (arg->n_info.n_xfptr.xf_fp == 0)
xlfail("file not open");
}
else if (!((arg) && (arg)->n_type == 3))
xlerror("bad argument type",arg);
}
return (arg);
}
