/* 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);
}
/* xdigitp - built-in function 'digit-char-p' */
LVAL xdigitp(void)
{
int ch;
ch = getchcode(xlgachar());
xllastarg();
return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
}
/* xalphanumericp - built-in function 'alphanumericp' */
LVAL xalphanumericp(void)
{
int ch;
ch = getchcode(xlgachar());
xllastarg();
return (isupper(ch) || islower(ch) || isdigit(ch) ? s_true : NIL);
}
/* xcharcode - built-in function 'char-code' */
LVAL xcharcode(void)
{
int ch;
ch = getchcode(xlgachar());
xllastarg();
return (cvfixnum((FIXTYPE)ch));
}
/* xbothcasep - built-in function 'both-case-p' */
LVAL xbothcasep(void)
{
int ch;
ch = getchcode(xlgachar());
xllastarg();
return (isupper(ch) || islower(ch) ? s_true : NIL);
}
/* xcharint - convert an integer to a character */
LVAL xcharint(void)
{
LVAL arg;
arg = xlgachar();
xllastarg();
return (cvfixnum((FIXTYPE)getchcode(arg)));
}
/* xstring - return a string consisting of a single character */
LVAL xstring(void)
{
LVAL arg;
/* get the argument */
arg = xlgetarg();
xllastarg();
/* make sure its not NIL */
if (null(arg))
xlbadtype(arg);
/* check the argument type */
switch (ntype(arg)) {
case STRING:
return (arg);
case SYMBOL:
return (getpname(arg));
case CHAR:
buf[0] = (int)getchcode(arg);
buf[1] = '\0';
return (cvstring(buf));
case FIXNUM:
buf[0] = getfixnum(arg);
buf[1] = '\0';
return (cvstring(buf));
default:
xlbadtype(arg);
return NIL; /* never happens */
}
}
/* 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);
}
/* 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);
}
/* xwrchar - write a character to a file */
LVAL xwrchar(void)
{
LVAL fptr,chr;
/* get the character and file pointer */
chr = xlgachar();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
xllastarg();
/* put character to the file */
xlputc(fptr,getchcode(chr));
/* return the character */
return (chr);
}
/* chrcompare - compare characters */
LOCAL LVAL chrcompare(int fcn, int icase)
{
int ch1,ch2,icmp;
LVAL arg;
/* get the characters */
arg = xlgachar(); ch1 = getchcode(arg);
/* convert to lowercase if case insensitive */
if (icase && isupper(ch1))
ch1 = tolower(ch1);
/* handle each remaining argument */
for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
/* get the next argument */
arg = xlgachar(); ch2 = getchcode(arg);
/* convert to lowercase if case insensitive */
if (icase && isupper(ch2))
ch2 = tolower(ch2);
/* compare the characters */
switch (fcn) {
case '<': icmp = (ch1 < ch2); break;
case 'L': icmp = (ch1 <= ch2); break;
case '=': icmp = (ch1 == ch2); break;
case '#': icmp = (ch1 != ch2); break;
case 'G': icmp = (ch1 >= ch2); break;
case '>': icmp = (ch1 > ch2); break;
}
}
/* return the result */
return (icmp ? s_true : NIL);
}
/* xlgetc - get a character from a file or stream */
int xlgetc(LVAL fptr)
{
LVAL lptr, cptr=NULL;
FILE *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)))
setsavech(fptr,'\0');
/* otherwise, check for terminal input or file input */
else {
fp = getfile(fptr);
if (fp == stdin || fp == STDERR)
ch = ostgetc();
else
ch = osagetc(fp);
#ifdef DEBUG_INPUT
if (read_by_xlisp && ch != -1) {
putc(ch, read_by_xlisp);
}
#endif
}
/* return the character */
return (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;
}
/* xlprint - print an xlisp value */
void xlprint(LVAL fptr, LVAL vptr, int flag)
{
LVAL nptr,next;
int n,i;
/* print nil */
if (vptr == NIL) {
putsymbol(fptr,"NIL",flag);
return;
}
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putsubr(fptr,"Subr",vptr);
break;
case FSUBR:
putsubr(fptr,"FSubr",vptr);
break;
case CONS:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NIL; nptr = next) {
xlprint(fptr,car(nptr),flag);
if (next = cdr(nptr))
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYMBOL:
putsymbol(fptr,(char *) getstring(getpname(vptr)),flag);
break;
case FIXNUM:
putfixnum(fptr,getfixnum(vptr));
break;
case FLONUM:
putflonum(fptr,getflonum(vptr));
break;
case CHAR:
putchcode(fptr,getchcode(vptr),flag);
break;
case STRING:
if (flag)
putqstring(fptr,vptr);
else
putstring(fptr,vptr);
break;
case STREAM:
putatm(fptr,"File-Stream",vptr);
break;
case USTREAM:
putatm(fptr,"Unnamed-Stream",vptr);
break;
case OBJECT:
putatm(fptr,"Object",vptr);
break;
case VECTOR:
xlputc(fptr,'#');
xlputc(fptr,'(');
for (i = 0, n = getsize(vptr); n-- > 0; ) {
xlprint(fptr,getelement(vptr,i++),flag);
if (n) xlputc(fptr,' ');
}
xlputc(fptr,')');
break;
case CLOSURE:
putclosure(fptr,vptr);
break;
case EXTERN:
if (getdesc(vptr)) {
(*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
}
break;
case FREE_NODE:
putatm(fptr,"Free",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}
