自学教程：C++ xlfail函数代码示例

/* 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))));}