/* xintchar - convert a character to an integer */
LVAL xintchar(void)
{
LVAL arg;
arg = xlgafixnum();
xllastarg();
return (cvchar((int)getfixnum(arg)));
}
/* 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);
}
}
/* 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
}
}
}
/* 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);
}
/* 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);
}
/* 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);
}
/* 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));
}
/* 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));
}
/* 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]));
}
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);
}
/* 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));
}
/* 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);
}
/* 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);
}
// 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;
}
/* 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);
}