示例#1
0
/* xintchar - convert a character to an integer */
LVAL xintchar(void)
{
    LVAL arg;
    arg = xlgafixnum();
    xllastarg();
    return (cvchar((int)getfixnum(arg)));
}
示例#2
0
/* 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);
    }
}
示例#3
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
        }
    }
}
示例#4
0
/* xdigitchar - built-in function 'digit-char' */
LVAL xdigitchar(void)
{
    LVAL arg;
    int n;
    arg = xlgafixnum(); n = getfixnum(arg);
    xllastarg();
    return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
}
示例#5
0
/* xchdowncase - built-in function 'char-downcase' */
LVAL xchdowncase(void)
{
    LVAL arg;
    int ch;
    arg = xlgachar(); ch = getchcode(arg);
    xllastarg();
    return (isupper(ch) ? cvchar(tolower(ch)) : arg);
}
示例#6
0
/* xcodechar - built-in function 'code-char' */
LVAL xcodechar(void)
{
    LVAL arg;
    int ch;
    arg = xlgafixnum(); ch = getfixnum(arg);
    xllastarg();
    return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
}
示例#7
0
/* xrdchar - read a character from a file */
LVAL xrdchar(void)
{
    LVAL fptr;
    int ch;

    /* get file pointer */
    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
    xllastarg();

    /* get character and check for eof */
    return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
}
示例#8
0
/* callmacro - call a read macro */
LVAL callmacro(LVAL fptr, int ch)
{
    LVAL *newfp;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(cdr(getelement(getvalue(s_rtable),ch)));
    pusharg(cvfixnum((FIXTYPE)2));
    pusharg(fptr);
    pusharg(cvchar(ch));
    xlfp = newfp;
    return (xlapply(2));
}
示例#9
0
/* xchar - extract a character from a string */
LVAL xchar(void)
{
    LVAL str,num;
    int n;

    /* get the string and the index */
    str = xlgastring();
    num = xlgafixnum();
    xllastarg();

    /* range check the index */
    if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
        xlerror("index out of range",num);

    /* return the character */
    return (cvchar(getstring(str)[n]));
}
示例#10
0
VOID StGWObDoKey P4C(LVAL, object, int, key, int, shift, int, opt)
{
  LVAL argv[5], ch, olddenv;
  
  olddenv = xldenv;
  xldbind(s_in_callback, s_true);
  xlsave1(ch);
  ch = cvchar(key);
  argv[0] = object;
  argv[1] = sk_do_key;
  argv[2] = ch;
  argv[3] = shift ? s_true : NIL;
  argv[4] = opt ? s_true : NIL;
  xscallsubrvec(xmsend, 5, argv);
  xlpop();
  xlunbind(olddenv);
}
示例#11
0
/* 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));
}
示例#12
0
文件: xlio.c 项目: jhbadger/xlispstat
/* xlungetc - unget a character */
VOID xlungetc P2C(LVAL, fptr, int, ch)
{
    LVAL lptr;
    
    /* check for ungetc from nil, or ungetc of EOF */
    if (fptr == NIL || ch == EOF)
	;
	
    /* otherwise, check for ungetc to a stream */
    else if (ustreamp(fptr)) {
	    lptr = cons(cvchar(ch),gethead(fptr));
	    if (gethead(fptr) == NIL)
		settail(fptr,lptr);
	    sethead(fptr,lptr);
    }

    /* otherwise, it must be a file */
    else
	setsavech(fptr,ch);
}
示例#13
0
/* xlungetc - unget a character */
void xlungetc(LVAL fptr, int ch)
{
    LVAL lptr;
    
    /* check for ungetc from nil */
    if (fptr == NIL || ch == EOF)
        ;
        
    /* otherwise, check for ungetc to a stream */
    else if (ustreamp(fptr)) {
        if (ch != EOF) {
            lptr = cons(cvchar(ch),gethead(fptr));
            if (gethead(fptr) == NIL)
                settail(fptr,lptr);
            sethead(fptr,lptr);
        }
    }
    
    /* otherwise, it must be a file */
    else
        setsavech(fptr,ch);
}
示例#14
0
// Copy a node (recursively if appropriate)
LOCAL LVAL nyx_dup_value(LVAL val)
{
   LVAL nval = val;

   // Protect old and new values
   xlprot1(val);
   xlprot1(nval);

   // Copy the node
   if (val != NIL) {
      switch (ntype(val))
      {
         case FIXNUM:
            nval = cvfixnum(getfixnum(val));
         break;

         case FLONUM:
            nval = cvflonum(getflonum(val));
         break;

         case CHAR:
            nval = cvchar(getchcode(val));
         break;

         case STRING:
            nval = cvstring((char *) getstring(val));
         break;

         case VECTOR:
         {
            int len = getsize(val);
            int i;

            nval = newvector(len);
            nval->n_type = ntype(val);

            for (i = 0; i < len; i++) {
               if (getelement(val, i) == val) {
                  setelement(nval, i, val);
               }
               else {
                  setelement(nval, i, nyx_dup_value(getelement(val, i)));
               }
            }
         }
         break;

         case CONS:
            nval = nyx_dup_value(cdr(val));
            nval = cons(nyx_dup_value(car(val)), nval);
         break;

         case SUBR:
         case FSUBR:
            nval = cvsubr(getsubr(val), ntype(val), getoffset(val));
         break;

         // Symbols should never be copied since their addresses are cached
         // all over the place.
         case SYMBOL:
            nval = val;
         break;

         // Streams are not copied (although USTREAM could be) and reference
         // the original value.
         case USTREAM:
         case STREAM:
            nval = val;
         break;

         // Externals aren't copied because I'm not entirely certain they can be.
         case EXTERN:
            nval = val;
         break;

         // For all other types, just allow them to reference the original
         // value.  Probably not the right thing to do, but easier.
         case OBJECT:
         case CLOSURE:
         default:
            nval = val;
         break;
      }
   }

   xlpop();
   xlpop();

   return nval;
}
示例#15
0
/* rmhash - read macro for '#' */
LVAL rmhash(void)
{
    LVAL fptr,mch,val;
    int escflag,ch;

    /* protect some pointers */
    xlsave1(val);

    /* get the file and macro character */
    fptr = xlgetfile();
    mch = xlgachar();
    xllastarg();

    /* make the return value */
    val = consa(NIL);

    /* check the next character */
    switch (ch = xlgetc(fptr)) {
    case '\'':
                rplaca(val,pquote(fptr,s_function));
                break;
    case '(':
                rplaca(val,pvector(fptr));
                break;
    case 'b':
    case 'B':
                rplaca(val,pnumber(fptr,2));
                break;
    case 'o':
    case 'O':
                rplaca(val,pnumber(fptr,8));
                break;
    case 'x':
    case 'X':
                    rplaca(val,pnumber(fptr,16));
                break;
    case '\\':
                xlungetc(fptr,ch);
                pname(fptr,&escflag);
                ch = buf[0];
                if (strlen(buf) > 1) {
                    upcase((char *) buf);
                    if (strcmp(buf,"NEWLINE") == 0)
                        ch = '\n';
                    else if (strcmp(buf,"SPACE") == 0)
                        ch = ' ';
                    else if (strcmp(buf,"TAB") == 0)
                        ch = '\t';
                    else
                        xlerror("unknown character name",cvstring(buf));
                }
                rplaca(val,cvchar(ch));
                break;
    case ':':
                rplaca(val,punintern(fptr));
                break;
    case '|':
                    pcomment(fptr);
                val = NIL;
                break;
    default:
                xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
    }

    /* restore the stack */
    xlpop();

    /* return the value */
    return (val);
}