/* xlapply - apply a function to a list of arguments */
NODE *xlapply(NODE *fun,NODE *args)
{
NODE *env,*val;
val = 0; //BUG: uninitialized variable is used if xlfail returns
/* check for a null function */
if (fun == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun))
val = (*getsubr(fun))(args);
else if (consp(fun)) {
if (consp(car(fun))) {
env = cdr(fun);
fun = car(fun);
}
else
env = xlenv;
if (car(fun) != s_lambda)
xlfail("bad function type");
val = evfun(fun,args,env);
}
else
xlfail("bad function");
/* return the result value */
return (val);
}
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));
}
/******************************************************************************
* Prim_PCLOSE - close a pipe opened by Prim_POPEN().
* (code stolen from xlfio.c:xclose())
*
* syntax: (pclose <stream>)
* <stream> is a stream created by popen.
* returns T if the command executed successfully, otherwise,
* returns the exit status of the opened command.
*
* Added to XLISP by Niels Mayer
******************************************************************************/
LVAL Prim_PCLOSE()
{
extern LVAL true;
LVAL fptr;
int result;
/* get file pointer */
fptr = xlgastream();
xllastarg();
/* make sure the file exists */
if (getfile(fptr) == NULL)
xlfail("file not open");
/* close the pipe */
result = pclose(getfile(fptr));
if (result == -1)
xlfail("<stream> has not been opened with popen");
setfile(fptr,NULL);
/* return T if success (exit status 0), else return exit status */
return (result ? cvfixnum(result) : true);
}
/* 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);
}
/* 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);
}
void snd_fail(char *msg)
{
char *bigger = (char *) malloc(strlen(msg) + 16);
if (!bigger) xlfail("no memory");
strcpy(bigger, "(snd)");
strcat(bigger, msg);
xlfail(bigger);
// NOTE: there is a memory leak here
}
/* plist - parse a list */
LOCAL LVAL plist(LVAL fptr)
{
LVAL val,expr,lastnptr,nptr;
/* protect some pointers */
xlstkcheck(2);
xlsave(val);
xlsave(expr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL; nextch(fptr) != ')'; )
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
/* check for a dotted tail */
if (expr == s_dot) {
/* make sure there's a node */
if (lastnptr == NIL)
xlfail("invalid dotted pair");
/* parse the expression after the dot */
if (!xlread(fptr,&expr,TRUE))
badeof(fptr);
rplacd(lastnptr,expr);
/* make sure its followed by a close paren */
if (nextch(fptr) != ')')
xlfail("invalid dotted pair");
}
/* otherwise, handle a normal list element */
else {
nptr = consa(expr);
if (lastnptr == NIL)
val = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
}
break;
}
/* skip the closing paren */
xlgetc(fptr);
/* restore the stack */
xlpopn(2);
/* return successfully */
return (val);
}
/* 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);
}
/* add items to a macintosh internal menu */
void StMObAppendItems(LVAL menu, LVAL items)
{
LVAL item;
char *s;
int i, flags, id;
HMENU theMenu;
if (StMObAllocated(menu)) {
theMenu = get_menu_address(menu);
id = get_menu_id(menu);
i = llength(slot_value(menu, s_items)) - llength(items);
if (i < 0) xlfail("append list should not exceed item list");
for (; consp(items); items = cdr(items), i++) {
item = car(items);
s = get_item_string(item);
if (s[0] == '-') AppendMenu((HMENU) theMenu, MF_SEPARATOR, 0, NULL);
else {
flags = MF_STRING;
if (slot_value(item, s_mark) != NIL) flags |= MF_CHECKED;
if (slot_value(item, s_enabled) == NIL) flags |= MF_GRAYED;
AppendMenu((HMENU) theMenu, flags, MAKEITEMINDEX(id, i), s);
}
}
}
}
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;
}
sound_type snd_make_slider(int index, time_type t0, rate_type sr, time_type d)
{
register slider_susp_type susp;
/* sr specified as input parameter */
/* t0 specified as input parameter */
sample_type scale_factor = 1.0F;
if (index < 0 || index >= SLIDERS_MAX) {
xlfail("slider index out of range");
}
falloc_generic(susp, slider_susp_node, "snd_make_slider");
susp->susp.fetch = slider__fetch;
susp->index = index;
susp->terminate_cnt = round((d) * sr);
/* initialize susp state */
susp->susp.free = slider_free;
susp->susp.sr = sr;
susp->susp.t0 = t0;
susp->susp.mark = NULL;
susp->susp.print_tree = slider_print_tree;
susp->susp.name = "slider";
susp->susp.log_stop_cnt = UNKNOWN;
susp->susp.current = 0;
return sound_create((snd_susp_type)susp, t0, sr, scale_factor);
}
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;
}
/* xtype - return type of a thing */
LVAL xtype()
{
LVAL arg;
if (!(arg = xlgetarg()))
return (NIL);
switch (ntype(arg)) {
case SUBR: return (a_subr);
case FSUBR: return (a_fsubr);
case CONS: return (a_cons);
case SYMBOL: return (a_symbol);
case FIXNUM: return (a_fixnum);
case FLONUM: return (a_flonum);
case STRING: return (a_string);
case OBJECT: return (a_object);
case STREAM: return (a_stream);
case VECTOR: return (a_vector);
case CLOSURE: return (a_closure);
case CHAR: return (a_char);
case USTREAM: return (a_ustream);
case STRUCT: return (getelement(arg,0));
default: xlfail("bad node type");
}
}
/* 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 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 iview_spin_allocate(V)
{
LVAL object;
int vars, i, show, ascent, height;
IVIEW_WINDOW w;
StGWWinInfo *gwinfo;
object = xlgaobject();
show = xsboolkey(sk_show, TRUE);
gwinfo = StGWObWinInfo(object);
get_iview_ivars(object, &vars);
if (vars < 3) xlfail("too few variables");
w = IViewNew(object);
initialize_iview(w, object);
for (i = 0; i < vars; i++)
IViewSetScaledRange(w, i, -sqrt((double) vars), sqrt((double) vars));
set_content_variables(object, 0, 1, 2);
IViewSetIdentityTransformation(w);
set_rotation_type(object, Rolling);
set_angle(object, ALPHA);
ascent = StGWTextAscent(gwinfo);
height = (ascent > SPIN_CONTROL_SIZE) ? 2 * ascent : SPIN_CONTROL_HEIGHT;
StGrSetMargin(gwinfo, 0, 0, 0, height);
/* use StShowWindow to show (map) window but NOT send :resize or :redraw */
if (show) StShowWindow(w);
return(object);
}
/* newvector - allocate and initialize a new vector node */
NODE *newvector(int size)
{
NODE ***oldstk,*vect __HEAPIFY;
int bsize;
/* establish a new stack frame */
oldstk = xlsave1(&vect);
/* allocate a vector node and set the size to zero (in case of gc) */
vect = newnode(VECT);
vect->n_vsize = 0;
/* allocate memory for the vector */
bsize = size * sizeof(NODE *);
vect->n_vsize = size;
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
findmem();
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
xlfail("insufficient vector space");
}
total += (long) bsize;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new vector */
return (vect);
}
/* xtype - return type of a thing */
LVAL xtype(void)
{
LVAL arg;
if (!(arg = xlgetarg()))
return (NIL);
switch (ntype(arg)) {
case SUBR: return (a_subr);
case FSUBR: return (a_fsubr);
case CONS: return (a_cons);
case SYMBOL: return (a_symbol);
case FIXNUM: return (a_fixnum);
case FLONUM: return (a_flonum);
case STRING: return (a_string);
case OBJECT: return (a_object);
case STREAM: return (a_stream);
case VECTOR: return (a_vector);
case CLOSURE: return (a_closure);
case CHAR: return (a_char);
case USTREAM: return (a_ustream);
case EXTERN: return (exttype(arg));
default: xlfail("bad node type");
return NIL; /* never happens */
}
}
/******************************************************************************
* Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr
*
* syntax: (system <command line>)
* <command line> is a string to be sent to the subshell (sh).
*
* Returns T if the command executed succesfully, otherwise returns the
* integer shell exit status for the command.
*
* Added to XLISP by Niels Mayer
******************************************************************************/
LVAL Prim_SYSTEM()
{
extern LVAL true;
extern int sys_nerr;
extern char *sys_errlist[];
extern int errno;
LVAL command;
int result;
char temptext[1024];
/* get shell command */
command = xlgastring();
xllastarg();
/* run the process */
result = system((char *) getstring(command));
if (result == -1) { /* if a system error has occured */
if (errno < sys_nerr)
(void) sprintf(temptext, "Error in system(3S): %s\n", sys_errlist[errno]);
else
(void) strcpy(temptext, "Error in system(3S): unknown error\n");
xlfail(temptext);
}
/* return T if success (exit status 0), else return exit status */
return (result ? cvfixnum(result) : true);
}
LVAL snd_fft(sound_type s, long len, long step /* more parameters may belong here */)
{
long i, maxlen, skip, fillptr;
float *samples;
LVAL result;
if (len < 1) xlfail("len < 1");
if (!s->extra) { /* this is the first call, so fix up s */
/* note: any storage required by fft must be allocated here in a contiguous
* block of memory who's size is given by the first long in the block.
* Here, there are 4 more longs after the size, and then room for len floats
* (assumes that floats and longs take equal space).
*
* The reason for this storage restriction is that when a sound is freed, the
* block of memory pointed to by extra is also freed. There is no function
* call that might free a more complex structure (this could be added in sound.c
* however if it's really necessary).
*/
falloc_generic_n(s->extra, long, len + OFFSET, "snd_fft");
s->extra[0] = sizeof(long) * (len + OFFSET);
s->CNT = s->INDEX = s->FILLCNT = 0;
s->TERMCNT = -1;
maxlen = len;
} else {
/* 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));
}
/* xlputc - put a character to a file or stream */
void xlputc(LVAL fptr, int ch)
{
LVAL lptr;
FILE *fp;
/* count the character */
++xlfsize;
/* check for output to nil */
if (fptr == NIL)
;
/* otherwise, check for output to an unnamed stream */
else if (ustreamp(fptr)) {
lptr = consa(cvchar(ch));
if (gettail(fptr))
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)
xlfail("file not open");
else if (fp == stdout || fp == STDERR)
ostputc(ch);
else
osaputc(ch,fp);
}
}
/* xlpeek - peek at a character from a file or stream */
int xlpeek(LVAL fptr)
{
LVAL lptr, cptr=NULL;
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");
ch = getchcode(cptr);
}
}
/* otherwise, get the next file character and save it */
else {
ch = xlgetc(fptr);
setsavech(fptr,ch);
}
/* return the character */
return (ch);
}
/* 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
}
}
}
CPTR GETDIALOGADDRESS P1C(LVAL, object)
{
LVAL addr = slot_value(object, s_hardware_address);
if (addr == NIL) return(NULL);
if (! valid_dialog_address(addr))
xlfail("not a valid dialog address - try reallocating the object");
return((CPTR) getfixnum(car(cdr(addr))));
}
CPTR GETIVIEWWINDOWADDRESS P1C(LVAL, object)
{
LVAL addr = slot_value(object, s_hardware_address);
if (addr == NIL) return(NULL);
else if (! valid_iview_window_address(addr))
xlfail("not a valid graph window address - try reallocating the object");
return((CPTR) getfixnum(car(cdr(addr))));
}
CPTR get_display_window_address P1C(LVAL, object)
{
LVAL addr;
addr = slot_value(object, s_hardware_address);
if (! valid_display_window_address(addr))
xlfail("not a valid display window address - try reallocating the object");
return((CPTR) getfixnum(car(cdr(addr))));
}
CPTR get_apple_menu_address P1C(LVAL, object)
{
LVAL addr;
addr = slot_value(object, s_hardware_address);
if (! valid_apple_menu_address(addr))
xlfail("not a valid apple menu address - try reallocating the object");
return((CPTR) getfixnum(car(cdr(addr))));
}
