projects / unix-history / blob
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
BSD 3 development
[unix-history] / usr / src / cmd / lisp / io.c
#include "global.h"
#include <stdio.h>
#include <ctype.h>
#include "chars.h"
struct readtable {
char ctable[132];
} initread = {
/* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */
VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR,
/* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */
VCHAR, VSEP, VSEP, VSEP, VSEP, VSEP, VERR, VERR,
/* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */
VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR,
/* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */
VERR, VERR, VERR, VSEP, VERR, VERR, VERR, VERR,
/* sp ! " # $ % & ' */
VSEP, VCHAR, VDQ, VCHAR, VCHAR, VCHAR, VCHAR, VSQ,
/* ( ) * + , - . / */
VLPARA, VRPARA, VCHAR, VSIGN, VCHAR, VSIGN, VPERD, VCHAR,
/* 0 1 2 3 4 5 6 7 */
VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM,
/* 8 9 : ; < = > ? */
VNUM, VNUM, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* @ A B C D E F G */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* H I J K L M N O */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* P Q R S T U V W */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* X Y Z [ \ ] ^ _ */
VCHAR, VCHAR, VCHAR, VLBRCK, VESC, VRBRCK, VCHAR, VCHAR,
/* ` a b c d e f g */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* h i j k l m n o */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* p q r s t u v w */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR,
/* x y z { | } ~ del */
VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VEOF,
/* unused unused Xesc Xdqc */
0, 0, '\\', '"'
};
char *ctable = initread.ctable;
lispval atomval; /* external varaible containing atom returned
from internal atom reading routine */
lispval protect();
lispval unprotect();
lispval readrx(); lispval readr(); lispval readry();
int keywait;
static int dbqflag;
static int macflag;
static int splflag;
static int mantisfl = 0;
lispval lastrtab; /* external variable designating current reader
table */
static char baddot1[]=
"Bad reader construction: (. <something>)\nShould be (nil . <something>)\n";
static char baddot2[]=
"Bad reader construction: (<something> .)\n\
Should be (<something> . <something>), assumed to be (<something>)";
static char baddot3[]=
"Bad reader construction: (<something> . <something> not followed by )";
#include "chkrtab.h"
/* readr ****************************************************************/
/* returns a s-expression read in from the port specified as the first */
/* argument. Handles superbrackets, reader macros. */
lispval
readr(useport)
FILE *useport;
{
register lispval handy = Vreadtable->clb;
chkrtab(handy);
rbktf = FALSE;
rdrport = (FILE *) useport;
if(useport==stdin)
keywait = TRUE;
handy = readrx(Iratom());
if(useport==stdin)
keywait = FALSE;
return(handy);
}
/* readrx **************************************************************/
/* returns a s-expression beginning with the syntax code of an atom */
/* passed in the first */
/* argument. Does the actual work for readr, including list, dotted */
/* pair, and quoted atom detection */
lispval
readrx(code)
register int code;
{
register lispval work;
register lispval *current;
register struct argent *result;
register struct argent *lbot, *np;
int inlbkt = FALSE;
lispval errorh();
top:
switch(code)
{
case TLBKT:
inlbkt = TRUE;
case TLPARA:
result = np;
current = (lispval *)np;
np++->val = nil; /*protect(nil);*/
for(EVER) {
switch(code = Iratom())
{
case TRPARA:
if(rbktf && inlbkt)
rbktf = FALSE;
return(result->val);
default:
atomval = readrx(code);
case TSCA:
np++->val=atomval;
*current = work = newdot();
work->car = atomval;
np--;
current = (lispval *) &(work->cdr);
break;
case TSPL:
macrox(); /* input and output in atomval */
*current = atomval;
while(*current!=nil) {
if(TYPE(*current)!=DTPR)
errorh(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current);
current=(lispval *)&((*current)->cdr);
}
break;
case TPERD:
if(result->val==nil) {
work = result->val=newdot();
current = (lispval *) &(work->cdr);
fprintf(stderr,baddot1);
}
code = Iratom();
if(code==TRPARA) {
return(errorh(Vermisc,baddot2,nil,TRUE,58,result->val));
}
*current = readrx(code);
if((code = Iratom())!=TRPARA) {
errorh(Vermisc,baddot3,nil,TRUE,59,result->val,atomval);
}
if(rbktf && inlbkt)
rbktf = FALSE;
return(result->val);
case TEOF:
clearerr(rdrport);
error("Premature end of file.", FALSE);
}
if(rbktf) {
if(inlbkt)
rbktf = FALSE;
return(result->val);
}
}
case TSCA:
return(atomval);
case TEOF:
return(eofa);
case TMAC:
macrox();
return(atomval);
case TSPL:
macrox();
if((work = atomval)!=nil) {
if(TYPE(work)==DTPR && work->cdr==nil)
return(work->car);
else
errorh(Vermisc,
"Improper value returned from splicing macro at top-level",nil,FALSE,9,work);
}
code = Iratom();
goto top;
/* return(readrx(Iratom())); */
case TSQ:
result = np;
protect(newdot());
(work = result->val)->car = quota;
work = work->cdr = newdot();
work->car = readrx(Iratom());
return(result->val);
default:
return(error("Readlist error",FALSE));
}
}
macrox()
{
lispval Lapply();
snpand(0);
lbot = np;
protect(Iget(atomval,macro));
protect(nil);
atomval = Lapply();
return;
}
/* ratomr ***************************************************************/
/* this routine returns a pointer to an atom read in from the port given*/
/* by the first argument */
lispval
ratomr(useport)
register FILE *useport;
{
rdrport = useport;
switch(Iratom())
{
case TEOF:
return(eofa);
case TSQ:
case TRPARA:
case TLPARA:
case TLBKT:
case TPERD:
strbuf[1]=0;
return(getatom());
default:
return(atomval);
}
}
Iratom()
{
register FILE *useport = rdrport;
register char c, marker, *name;
extern lispval finatom(), calcnum(), getnum();
char positv = TRUE;
int code;
int strflag = FALSE;
name = strbuf;
again: c = getc(useport) & 0177;
*name = c;
switch(ctable[c] & 0377) {
default: goto again;
case VNUM:
case VSIGN: *name++ = c;
atomval = (getnum(name));
return(TSCA);
case VESC:
dbqflag = TRUE;
*name++ = getc(useport) & 0177;
atomval = (finatom(name));
return(TSCA);
case VCHAR:
*name++ = c;
atomval = (finatom(name));
return(TSCA);
case VLPARA: return(TLPARA);
case VRPARA: return(TRPARA);
case VPERD: c = peekc(useport);
if(VNUM!=ctable[c])
return(TPERD);
*name++ = '.';
mantisfl = 1;
atomval = (getnum(name));
return(TSCA);
case VLBRCK: return(TLBKT);
case VRBRCK: rbktf = TRUE;
return(TRPARA);
case VEOF: /*printf("returning eof atom\n");*/
return(TEOF);
case VSQ: return(TSQ);
case VSD: strflag = TRUE;
case VDQ: name = strbuf;
marker = c;
while ((c = getc(useport)) != marker) {
if(VESC==ctable[c]) c = getc(useport);
*name++ = c;
if (name >= endstrb)
error("ATOM TOO LONG",FALSE);
if (feof(useport)) {
clearerr(useport);
error("EOF ecountered while reading atom", FALSE);
}
}
*name = NULL_CHAR;
if(strflag)
atomval = (lispval) inewstr(strbuf);
else
atomval = (getatom(name));
return(TSCA);
case VERR: if (c == '\0') goto same; /* null pname */
fprintf(stderr,"%c (%o): ",c,(int) c);
error("ILLEGAL CHARACTER IN ATOM",TRUE);
case VSPL:
code = TSPL;
goto same;
case VMAC:
code = TMAC;
goto same;
case VSCA:
code = TSCA;
same:
strbuf[0] = c;
strbuf[1] = 0;
atomval = (getatom());
return(code);
}
}
#define push(); if(name==endstrb) error("Int too long",FALSE); else *name++=c;
#define next() (stats = ctable[c=getc(useport) & 0177])
lispval
getnum(name)
register char *name;
{
register char c;
register lispval result;
register FILE *useport=rdrport;
char stats;
double realno;
extern lispval finatom(), calcnum(), newdoub(), dopow();
if(mantisfl) {
mantisfl = 0;
next();
goto mantissa;
}
while(VNUM==next()) {
push(); /* recognize [0-9]*, in "ex" parlance */
}
if(stats==VPERD) {
push(); /* continue */
} else if(stats & SEPMASK) {
ungetc(c,useport);
return(calcnum(strbuf,name,ibase->clb->i));
} else if(c=='^') {
push();
return(dopow(name,ibase->clb->i));
} else if(c=='_') {
push();
return(dopow(name,2));
} else{
ungetc(c,useport);
return(finatom(name));
}
/* at this point we have [0-9]*\. , which might
be a decimal int or the leading part of a
float */
if(next()!=VNUM) {
if(c=='e' || c=='E' || c=='d' ||c=='D')
goto expt;
else if(c=='^') {
push();
return(dopow(name,ibase->clb->i));
} else if(c=='_') {
push();
return(dopow(name,2));
} else {
/* Here we have 1.x where x not num, not sep */
/* Here we have decimal int. NOT FORTRAN! */
ungetc(c,useport);
return(calcnum(strbuf,name-1,10));
}
}
mantissa:
do {
push();
} while (VNUM==next());
/* Here we have [0-9]*\.[0-9]* */
if(stats & SEPMASK)
goto last;
else if(c!='e' && c!='E' && c!='d' && c!='D') {
ungetc(c,useport);
goto verylast;
}
expt: push();
next();
if(c=='+' || c =='-') {
push();
next();
}
while (VNUM==stats) {
push();
next();
}
last: ungetc(c,useport);
if(! (stats & SEPMASK) )
return(finatom(name));
verylast:
*name=0;
sscanf(strbuf,"%F",&realno);
(result = newdoub())->r = realno;
return(result);
}
lispval
dopow(part2,base)
lispval base;
char *part2;
{
register char *name = part2;
register char c;
register FILE *useport = rdrport;
register int power;
register struct argent *lbot, *np;
char stats;
char *end1 = part2 - 1; lispval Ltimes();
while(VNUM==next()) {
push();
}
if(c!='.') {
ungetc(c,useport);
}
if(c!='.' && !(stats & SEPMASK)) {
return(finatom(name));
}
lbot = np;
np++->val = inewint(base);
/* calculate "mantissa"*/
if(*end1=='.')
np++->val = calcnum(strbuf,end1-1,10);
else
np++->val = calcnum(strbuf,end1,ibase->clb->i);
/* calculate exponent */
if(c=='.')
power = calcnum(part2,name,10)->i;
else
power = calcnum(part2,name,ibase->clb->i)->i;
while(power-- > 0)
lbot[1].val = Ltimes();
return(lbot[1].val);
}
lispval
calcnum(strbuf,name,base)
char *name;
char *strbuf;
{
register char *p;
register lispval result, temp;
int negflag = 0;
temp = rdrsdot; /* initialize sdot cell */
temp->CDR = nil;
temp->i = 0;
p = strbuf;
if(*p=='+') p++;
else if(*p=='-') {negflag = 1; p++;}
*name = 0;
if(p>=name) return(getatom());
for(;p < name; p++)
dmlad(temp,base,*p-'0');
if(negflag)
dmlad(temp,-1,0);
if(temp->CDR==0) {
result = inewint(temp->i);
return(result);
} else {
(result = newsdot())->i = temp->i;
result->CDR = temp->CDR;
temp->CDR = 0;
}
return(result);
}
lispval
finatom(name)
register char *name;
{
extern int uctolc;
register FILE *useport = rdrport;
register char c, stats;
register char *savenm;
savenm = name - 1; /* remember start of name */
while(!(next()&SEPMASK)) {
if(stats == VESC) c = getc(useport) & 0177;
*name++=c;
if (name >= endstrb)
error("ATOM TOO LONG",FALSE);
}
*name = NULL_CHAR;
ungetc(c,useport);
if (uctolc) for(; *savenm ; savenm++)
if( isupper(*savenm) ) *savenm = tolower(*savenm);
return(getatom());
}
/* printr ***************************************************************/
/* prints the first argument onto the port specified by the second */
printr(a,useport)
register lispval a;
register FILE *useport;
{
register lispval temp;
char strflag = 0;
char Idqc = 0;
val_loop:
if( ! VALID(a) )
{
error("BAD LISP DATA ENCOUNTERED BY PRINTR",TRUE);
a = badst;
}
switch (TYPE(a)) {
case UNBO: fputs("<UNBOUND>",useport);
break;
case VALUE: fputs("(ptr to)",useport);
a = a->l;
goto val_loop;
case INT: fprintf(useport,"%d",a->i);
break;
case DOUB: fprintf(useport,"%0.16G",a->r);
break;
case PORT: fputs("port",useport);
break;
case ARRAY: fputs("array[",useport);
printr(a->length,useport);
fputs("]",useport);
break;
case BCD: fprintf(useport,"#%X-",a->entry);
printr(a->discipline,useport);
break;
case SDOT: pbignum(a,useport);
break;
case DTPR: if(a->car==quota && a->cdr!=nil
&& a->cdr->cdr==nil) {
putc('\'',useport);
printr(a->cdr->car,useport);
break;
}
putc('(',useport);
morelist: printr(a->car,useport);
if ((a = a->cdr) != nil)
{
putc(' ',useport);
if (TYPE(a) == DTPR) goto morelist;
fputs(". ",useport);
printr(a,useport);
}
fputc(')',useport);
break;
case STRNG: strflag = TRUE;
Idqc = Xsdc;
case ATOM: {
char *front, *temp; int clean;
temp = front = (strflag ? ((char *) a) : a->pname);
if(Idqc==0) Idqc = Xdqc;
if(Idqc) {
clean = *temp;
if (*temp == '-') temp++;
clean = clean && (ctable[*temp] != VNUM);
while (clean && *temp)
clean = (!(ctable[*temp++] & QUTMASK));
if (clean)
fputs(front,useport);
else {
putc(Idqc,useport);
for(temp=front;*temp;temp++) {
if( *temp==Idqc
|| ctable[*temp] == VESC)
putc(Xesc,useport);
putc(*temp,useport);
}
putc(Idqc,useport);
}
} else {
register char *cp = front;
if(ctable[*cp]==VNUM)
putc(Xesc,useport);
for(; *cp; cp++) {
if(ctable[*cp]& QUTMASK)
putc(Xesc,useport);
putc(*cp,useport);
}
}
}
}
}
/* dmpport ****************************************************************/
/* outputs buffer indicated by first argument whether full or not */
dmpport(useport)
register lispval useport;
{
fflush(useport);
}
/* protect and unprot moved to eval.c (whr) */
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.