示例#1
0
/* 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));
}
示例#2
0
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));
}
示例#3
0
/* 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;
}
示例#4
0
文件: xlio.c 项目: jhbadger/xlispstat
/* 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
        }
    }
}
示例#5
0
/* 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));
}
示例#6
0
文件: xlobj.c 项目: MindFy/audacity
/* 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);
}
示例#7
0
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);
}
示例#8
0
/* 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);
}
示例#9
0
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));
}
示例#10
0
/* 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);
  }
}
示例#11
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);
}
示例#12
0
/* 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);
}
示例#13
0
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;
}
示例#14
0
/* 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));
}
示例#15
0
/* 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));
}
示例#16
0
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);
}
示例#17
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);
}
示例#18
0
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);
}
示例#19
0
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);
}
示例#20
0
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;
}
示例#21
0
/* 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);
}
示例#22
0
文件: xlio.c 项目: jhbadger/xlispstat
/* 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);
}
示例#23
0
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 */
}
示例#24
0
文件: term.c 项目: jhbadger/xlispstat
LOCAL LVAL get_plot_stream()
{
  LVAL stream;

  stream = getvalue(s_plot_output);
  if (! streamp(stream) && ! ustreamp(stream)) xlerror("not a stream", stream);

  return(stream);
}
示例#25
0
/* 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);
}
示例#26
0
/* 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);
}
示例#27
0
/* 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);
}
示例#28
0
/* 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 */
}
示例#29
0
/* 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 */
}
示例#30
0
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);
}