From 44aabe24ce13db3ec902bceff16be6a9b14f2e89 Mon Sep 17 00:00:00 2001 From: CSRG Date: Mon, 14 Dec 1987 03:37:11 -0800 Subject: [PATCH] BSD 4_3_Net_2 development Work on file usr/src/usr.bin/lisp/franz/io.c Synthesized-from: CSRG/cd2/net.2 --- usr/src/usr.bin/lisp/franz/io.c | 1021 +++++++++++++++++++++++++++++++ 1 file changed, 1021 insertions(+) create mode 100644 usr/src/usr.bin/lisp/franz/io.c diff --git a/usr/src/usr.bin/lisp/franz/io.c b/usr/src/usr.bin/lisp/franz/io.c new file mode 100644 index 0000000000..a2b33926be --- /dev/null +++ b/usr/src/usr.bin/lisp/franz/io.c @@ -0,0 +1,1021 @@ +#ifndef lint +static char *rcsid = + "$Header: io.c,v 1.12 87/12/14 18:36:58 sklower Exp $"; +#endif + +/* -[Tue Nov 22 10:01:14 1983 by jkf]- + * io.c $Locker: $ + * input output functions + * + * (c) copyright 1982, Regents of the University of California + */ + +#include "global.h" +#include +#include "chars.h" +#include "chkrtab.h" + +struct readtable { +unsigned 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, VSD, 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, VDQ, VCHAR, VCHAR, VERR, +/* unused Xsdc Xesc Xdqc */ + 0, '"', '\\', '|' +}; + +extern unsigned char *ctable; +lispval atomval; /* external varaible containing atom returned + from internal atom reading routine */ +lispval readrx(); lispval readr(); lispval readry(); +char *atomtoolong(); +int keywait; +int plevel = -1; /* contains maximum list recursion count */ +int plength = -1; /* maximum number of list elements printed */ +static int dbqflag; +static int mantisfl = 0; +extern int uctolc; +extern lispval lastrtab; /* external variable designating current reader + table */ +static char baddot1[]= +"Bad reader construction: (. )\nShould be (nil . )\n"; +static char baddot2[]= +"Bad reader construction: ( . not followed by )"; + +/* 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->a.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; + int inlbkt = FALSE; + lispval errorh(); + Savestack(4); /* ???not necessary because np explicitly restored if + changed */ + +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; + goto out; + default: + atomval = readrx(code); + case TSCA: + np++->val=atomval; + *current = work = newdot(); + work->d.car = atomval; + np--; + current = (lispval *) &(work->d.cdr); + break; + case TINF: + imacrox(result->val,TRUE); + work = atomval; + result->val = work->d.car; + current = (lispval *) & (result->val); + goto mcom; + case TSPL: + macrox(); /* input and output in atomval */ + *current = atomval; + mcom: + while(*current!=nil) { + if(TYPE(*current)!=DTPR) + errorh1(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current); + current=(lispval *)&((*current)->d.cdr); + } + break; + case TPERD: + if(result->val==nil) { + work = result->val=newdot(); + current = (lispval *) &(work->d.cdr); + fprintf(stderr,baddot1); + } + work = readrx(TLPARA); + if (work->d.cdr!=nil) { + *current = work; work = newdot(); + work->d.cdr = *current; *current = nil; + work->d.car = result->val; + result->val = errorh1(Vermisc,baddot2,nil,TRUE,58,work); + goto out; + } + *current = work->d.car; + /* there is the possibility that the expression + following the dot is terminated with a "]" + and thus needs no closing lparens to follow + */ + if(rbktf && inlbkt) + rbktf = FALSE; + goto out; + case TEOF: + errorh1(Vermisc,"Premature end of file after ", + nil,FALSE,0,result->val); + } + if(rbktf) { + if(inlbkt) + rbktf = FALSE; + goto out; + } + } + case TSCA: + Restorestack(); + return(atomval); + case TEOF: + Restorestack(); + return(eofa); + case TMAC: + macrox(); + Restorestack(); + return(atomval); + case TINF: + imacrox(nil,FALSE); + work = atomval; + if(work==nil) { code = Iratom(); goto top;} + work = work->d.car; + Restorestack(); + if(work->d.cdr==nil) + return(work->d.car); + else + return(work); + case TSPL: + macrox(); + if((work = atomval)!=nil) { + if(TYPE(work)==DTPR && work->d.cdr==nil) { + Restorestack(); + return(work->d.car); + } else { + errorh1(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)->d.car = quota; + work = work->d.cdr = newdot(); + work->d.car = readrx(Iratom()); + goto out; + + case TRPARA: + Restorestack(); + return(errorh(Vermisc, + "read: read a right paren when expecting an s-expression", + nil,FALSE,0)); + case TPERD: + Restorestack(); + return(errorh(Vermisc, + "read: read a period when expecting an s-expression", + nil,FALSE,0)); + + /* should never get here, we should have covered all cases above */ + default: + Restorestack(); + return(errorh1(Vermisc,"Readlist error, code ",nil,FALSE,0,inewint((long)code))); + } +out: + work = result->val; + np = result; + Restorestack(); + return(work); +} +macrox() +{ + FILE *svport; + lispval handy, Lapply(); + + Savestack(0); + svport = rdrport; /* save from possible changing */ + lbot = np; + protect(handy=Iget(atomval,lastrtab)); + if (handy == nil) + { + errorh1(Vermisc,"read: can't find the character macro for ",nil, + FALSE,0,atomval); + } + protect(nil); + atomval = Lapply(); + chkrtab(Vreadtable->a.clb); /* the macro could have changed + the readtable + */ + rdrport = svport; /* restore old value */ + Restorestack(); + return; +} +imacrox(current,inlist) +register lispval current; +{ + FILE *svport; + register lispval work; + lispval Lapply(), handy; + + Savestack(2); + svport = rdrport; /* save from possible changing */ + if(inlist) + { + protect(handy = newdot()); + handy->d.car = current; + for(work = handy->d.car; (TYPE(work->d.cdr))==DTPR; ) + work = work->d.cdr; + handy->d.cdr = work; + } + else handy = current; + + lbot = np; + protect(Iget(atomval,lastrtab)); + protect(handy); + atomval = Lfuncal(); + chkrtab(Vreadtable->a.clb); /* the macro could have changed + the readtable + */ + rdrport = svport; /* restore old value */ + Restorestack(); + 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(TRUE)); + default: + return(atomval); + } +} + +#define push(); *name++ = c; if(name>=endstrb) name = atomtoolong(name); +#define next() (((cc=getc(useport))!=EOF)?(stats = ctable[c = cc &0177]):\ + ((c=0),(saweof = 1),(stats = SEPMASK))) +Iratom() +{ + register FILE *useport = rdrport; + register char c, marker, *name; + extern lispval finatom(), calcnum(), getnum(); + int code, cc; + int strflag = FALSE; + + name = strbuf; + +again: cc = getc(useport); + if(cc==EOF) + { + clearerr(useport); + return(TEOF); + } + c = cc & 0177; + *name = c; + + switch(synclass(ctable[c])) { + + default: goto again; + + case synclass(VNUM): + + case synclass(VSIGN): *name++ = c; + atomval = (getnum(name)); + return(TSCA); + + case synclass(VESC): + dbqflag = TRUE; + *name++ = getc(useport) & 0177; + atomval = (finatom(name)); + return(TSCA); + + case synclass(VCHAR): + if(uctolc && isupper(c)) c = tolower(c); + *name++ = c; + atomval = (finatom(name)); + return(TSCA); + + case synclass(VLPARA): return(TLPARA); + + case synclass(VRPARA): return(TRPARA); + + case synclass(VPERD): marker = peekc(useport) & 0177; + if(synclass(VNUM)!=synclass(ctable[marker])) + { if(SEPMASK & ctable[marker]) + return(TPERD); + else { *name++ = c; /* this period begins an atm */ + atomval = finatom(name); + return(TSCA); + } + } + *name++ = '.'; + mantisfl = 1; + atomval = (getnum(name)); + return(TSCA); + + case synclass(VLBRCK): return(TLBKT); + + case synclass(VRBRCK): rbktf = TRUE; + return(TRPARA); + + case synclass(VSQ): return(TSQ); + + case synclass(VSD): strflag = TRUE; + case synclass(VDQ): name = strbuf; + marker = c; + while ((c = getc(useport)) != marker) { + + if(synclass(VESC)==synclass(ctable[c])) + c = getc(useport) & 0177; + push(); + if (feof(useport)) { + clearerr(useport); + error("EOF encountered while reading atom", FALSE); + } + } + *name = NULL_CHAR; + if(strflag) + atomval = (lispval) newstr(TRUE); + else + atomval = (getatom(TRUE)); + return(TSCA); + + case synclass(VERR): if (c == '\0') + { + fprintf(stderr,"[read: null read and ignored]\n"); + goto again; /* null pname */ + } + fprintf(stderr,"%c (%o): ",c,(int) c); + error("ILLEGAL CHARACTER IN ATOM",TRUE); + + case synclass(VSINF): + code = TINF; + goto same; + case synclass(VSSPL): + code = TSPL; + goto same; + case synclass(VSMAC): + code = TMAC; + same: + marker = peekc(rdrport); + if(! (SEPMASK & ctable[marker]) ) { + *name++ = c; /* this is not a macro */ + atomval = (finatom(name)); + return(TSCA); + } + goto simple; + case synclass(VINF): + code = TINF; + goto simple; + case synclass(VSCA): + code = TSCA; + goto simple; + case synclass(VSPL): + code = TSPL; + goto simple; + case synclass(VMAC): + code = TMAC; + simple: + strbuf[0] = c; + strbuf[1] = 0; + atomval = (getatom(TRUE)); + return(code); + } +} + +lispval +getnum(name) +register char *name; +{ + unsigned char c; + register lispval result; + register FILE *useport=rdrport; + unsigned char stats; + int sawdigit = 0, saweof = 0,cc; + char *exploc = (char *) 0; + double realno; + extern lispval finatom(), calcnum(), newdoub(), dopow(); + + if(mantisfl) { + mantisfl = 0; + next(); + goto mantissa; + } + if(VNUM==ctable[*(unsigned char*)(name-1)]) sawdigit = 1; + while(VNUM==next()) { + push(); /* recognize [0-9]*, in "ex" parlance */ + sawdigit = 1; + } + if(c=='.') { + push(); /* continue */ + } else if(stats & SEPMASK) { + if(!saweof)ungetc((int)c,useport); + return(calcnum(strbuf,name,(int)ibase->a.clb->i)); + } else if(c=='^') { + push(); + return(dopow(name,(int)ibase->a.clb->i)); + } else if(c=='_') { + if(sawdigit) /* _ must be preceeded by a digit */ + { + push(); + return(dopow(name,2)); + } + else goto backout; + } else if(c=='e' || c=='E' || c=='d' ||c=='D') { + if(sawdigit) goto expt; + else goto backout; + } else { + backout: + ungetc((int)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,(int)ibase->a.clb->i)); + } else if(c=='_') { + push(); + return(dopow(name,2)); + } else if( stats & SEPMASK) { + /* Here we have 1.x where x is not number + * but is a separator + * Here we have decimal int. NOT FORTRAN! + */ + if(!saweof)ungetc((int)c,useport); + return(calcnum(strbuf,name-1,10)); + } + else goto last; /* return a symbol */ + } +mantissa: + do { + push(); + } while (VNUM==next()); + + /* Here we have [0-9]*\.[0-9]* + * three possibilities: + * next character is e,E,d or D in which case we examine + * the exponent [then we are faced with a similar + * situation to this one: is the character after the + * exponent a separator or not] + * next character is a separator, in which case we have a + * number (without an exponent) + * next character is not a separator in which case we have + * an atom (whose prefix just happens to look like a + * number) + */ + if( (c == 'e') || (c == 'E') || (c == 'd') || (c == 'D')) goto expt; + + if(stats & SEPMASK) goto verylast; /* a real number */ + else goto last; /* prefix makes it look like a number, but it isn't */ + +expt: + exploc = name; /* remember location of exponent character */ + push(); + next(); + if(c=='+' || c =='-') { + push(); + next(); + } + while (VNUM==stats) { + push(); + next(); + } + + /* if a separator follows then we have a number, else just + * an atom + */ + if (stats & SEPMASK) goto verylast; + +last: /* get here when what looks like a number turns out to be an atom */ + if(!saweof) ungetc((int)c,useport); + return(finatom(name)); + +verylast: + if(!saweof) ungetc((int)c,useport); + /* scanf requires that the exponent be 'e' */ + if(exploc != (char *) 0 ) *exploc = 'e'; + *name=0; + sscanf(strbuf,"%F",&realno); + (result = newdoub())->r = realno; + return(result); +} + +lispval +dopow(part2,base) +register char *part2; +{ + register char *name = part2; + register FILE *useport = rdrport; + register int power; + lispval work; + unsigned char stats,c; + int cc, saweof = 0; + char *end1 = part2 - 1; lispval Ltimes(); + Savestack(4); + + while(VNUM==next()) { + push(); + } + if(c!='.') { + if(!saweof)ungetc((int)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,(int)ibase->a.clb->i); + + /* calculate exponent */ + if(c=='.') + power = calcnum(part2,name,10)->i; + else + power = calcnum(part2,name,(int)ibase->a.clb->i)->i; + while(power-- > 0) + lbot[1].val = Ltimes(); + work = lbot[1].val; + Restorestack(); + return(work); +} + + +lispval +calcnum(strbuf,name,base) +register char *name; +char *strbuf; +{ + register char *p; + register lispval result, temp; + int negflag = 0; + + result = temp = newsdot(); /* initialize sdot cell */ + protect(temp); + p = strbuf; + if(*p=='+') p++; + else if(*p=='-') {negflag = 1; p++;} + *name = 0; + if(p>=name) return(getatom(TRUE)); + + for(;p < name; p++) + dmlad(temp,(long)base,(long)*p-'0'); + if(negflag) + dmlad(temp,-1L,0L); + + if(temp->s.CDR==0) { + result = inewint(temp->i); + pruneb(np[-1].val); + } + np--; + return(result); +} +lispval +finatom(name) +register char *name; +{ + register FILE *useport = rdrport; + unsigned char c, stats; + int cc, saweof = 0; + + while(!(next()&SEPMASK)) { + + if(synclass(stats) == synclass(VESC)) { + c = getc(useport) & 0177; + } else { + if(uctolc && isupper(c)) c = tolower(c); + } + push(); + } + *name = NULL_CHAR; + if(!saweof)ungetc((int)c,useport); + return(getatom(TRUE)); +} + +char * +atomtoolong(copyto) +char *copyto; +{ + int size; + register char *oldp = strbuf; + register char *newp; + lispval nveci(); + /* + * the string buffer contains an string which is too long + * so we get a bigger buffer. + */ + + size = (endstrb - strbuf)*4 + 28 ; + newp = (char *) nveci(size); + atom_buffer = (lispval) newp; + strbuf = newp; + endstrb = newp + size - 1; + while(oldp < copyto) *newp++ = *oldp++; + return(newp); +} + +/* printr ***************************************************************/ +/* prints the first argument onto the port specified by the second */ + +/* + * Last modified Mar 21, 1980 for hunks + */ + +printr(a,useport) +register lispval a; +register FILE *useport; +{ + register hsize, i; + char strflag = 0; + char Idqc = 0; + char *chstr; + int curplength = plength; + int quot; + lispval Istsrch(); + lispval debugmode; + +val_loop: + if(! VALID(a)) { + debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr; + if(debugmode != nil) { + printf("\n",a); + error("Bad lisp data encountered by printr", FALSE); + } else { + a = badst; + printf("",a); + return; + } + } + + switch (TYPE(a)) + { + + + case UNBO: fputs("",useport); + break; + + case VALUE: fputs("(ptr to)",useport); + a = a->l; + goto val_loop; + + case INT: fprintf(useport,"%d",a->i); + break; + + case DOUB: { char buf[64]; + lfltpr(buf,a->r); + fputs(buf,useport); + } + break; + + case PORT: { lispval cp; + if((cp = ioname[PN(a->p)]) == nil) + fputs("%$unopenedport",useport); + else fprintf(useport,"%%%s",cp); + } + break; + + case HUNK2: + case HUNK4: + case HUNK8: + case HUNK16: + case HUNK32: + case HUNK64: + case HUNK128: + if(plevel == 0) + { + fputs("%",useport); + break; + } + hsize = 2 << HUNKSIZE(a); + fputs("{", useport); + plevel--; + printr(a->h.hunk[0], useport); + curplength--; + for (i=1; i < hsize; i++) + { + if (a->h.hunk[i] == hunkfree) + break; + if (curplength-- == 0) + { + fputs(" ...",useport); + break; + } + else + { + fputs(" ", useport); + printr(a->h.hunk[i], useport); + } + } + fputs("}", useport); + plevel++; + break; + + case VECTOR: + chstr = "vector"; + quot = 4; /* print out # of longwords */ + goto veccommon; + + case VECTORI: + chstr = "vectori"; + quot = 1; + veccommon: + /* print out 'vector' or 'vectori' except in + * these circumstances: + * property is a symbol, in which case print + * the symbol's pname + * property is a list with a 'print' property, + * in which case it is funcalled to print the + * vector + */ + if(a->v.vector[VPropOff] != nil) + { + if ((i=TYPE(a->v.vector[VPropOff])) == ATOM) + { + chstr = a->v.vector[VPropOff]->a.pname; + } + else if ((i == DTPR) && vectorpr(a,useport)) + { + break; /* printed by vectorpr */ + } + else if ((i == DTPR) + && (a->v.vector[VPropOff]->d.car != nil) + && TYPE(a->v.vector[VPropOff]->d.car) + == ATOM) + { + chstr = a->v.vector[VPropOff]->d.car->a.pname; + } + } + fprintf(useport,"%s[%d]", + chstr, a->vl.vectorl[VSizeOff]/quot); + break; + + case ARRAY: fputs("array[",useport); + printr(a->ar.length,useport); + fputs("]",useport); + break; + + case BCD: fprintf(useport,"#%X-",a->bcd.start); + printr(a->bcd.discipline,useport); + break; + + case OTHER: fprintf(useport,"#Other-%X",a); + break; + + case SDOT: pbignum(a,useport); + break; + + case DTPR: if(plevel==0) + { + fputs("&",useport); + break; + } + plevel--; + if(a->d.car==quota && a->d.cdr!=nil + && a->d.cdr->d.cdr==nil) { + putc('\'',useport); + printr(a->d.cdr->d.car,useport); + plevel++; + break; + } + putc('(',useport); + curplength--; + morelist: printr(a->d.car,useport); + if ((a = a->d.cdr) != nil) + { + if(curplength-- == 0) + { + fputs(" ...",useport); + goto out; + } + putc(' ',useport); + if (TYPE(a) == DTPR) goto morelist; + fputs(". ",useport); + printr(a,useport); + } + out: + fputc(')',useport); + plevel++; + break; + + case STRNG: strflag = TRUE; + Idqc = Xsdc; + + case ATOM: { + char *front, *temp, first; int clean; + temp = front = (strflag ? ((char *) a) : a->a.pname); + if(Idqc==0) Idqc = Xdqc; + + if(Idqc) { + clean = first = *temp; + first &= 0177; + switch(QUTMASK & ctable[first]) { + case QWNFRST: + case QALWAYS: + clean = 0; break; + case QWNUNIQ: + if(temp[1]==0) clean = 0; + } + if (first=='-'||first=='+') temp++; + if(synclass(ctable[*temp])==VNUM) clean = 0; + while (clean && *temp) { + if((ctable[*temp]&QUTMASK)==QALWAYS) + clean = 0; + else if(uctolc && (isupper(*temp))) + clean = 0; + temp++; + } + if (clean && !strflag) + fputs(front,useport); + else { + putc(Idqc,useport); + for(temp=front;*temp;temp++) { + if( *temp==Idqc + || (synclass(ctable[*temp])) == CESC) + putc(Xesc,useport); + putc(*temp,useport); + } + putc(Idqc,useport); + } + + } else { + register char *cp = front; + int handy = ctable[*cp & 0177]; + + if(synclass(handy)==CNUM) + putc(Xesc,useport); + else switch(handy & QUTMASK) { + case QWNUNIQ: + if(cp[1]==0) putc(Xesc,useport); + break; + case QWNFRST: + case QALWAYS: + putc(Xesc,useport); + } + for(; *cp; cp++) { + if((ctable[*cp]& QUTMASK)==QALWAYS) + putc(Xesc,useport); + putc(*cp,useport); + } + } + } + } +} + +/* -- vectorpr + * (perhaps) print out vector specially + * this is called with a vector whose property list begins with + * a list. We search for the 'print' property and if it exists, + * funcall the print function with two args: the vector and the port. + * We return TRUE iff we funcalled the function, else we return FALSE + * to have the standard printing done + */ + +vectorpr(vec,port) +register lispval vec; +FILE *port; +{ + register lispval handy; + int svplevel = plevel; /* save these global values */ + int svplength = plength; + Savestack(2); + + + for ( handy = vec->v.vector[VPropOff]->d.cdr + ; handy != nil; handy = handy->d.cdr->d.cdr) + { + if (handy->d.car == Vprintsym) + { + lbot = np; + protect(handy->d.cdr->d.car); /* function to call */ + protect(vec); + protect(P(port)); + Lfuncal(); + plevel = svplevel; /* restore globals */ + plength = svplength; + Restorestack(); + return(TRUE); /* did the call */ + } + } + Restorestack(); + return(FALSE); /* nothing printed */ +} + + + + + + +lfltpr(buf,val) /* lisp floating point printer */ +char *buf; +double val; +{ + register char *cp1; + + sprintf(buf,(char *)Vfloatformat->a.clb,val); + for(cp1 = buf; *cp1; cp1++) + if(*cp1=='.'|| *cp1=='E' || *cp1 == 'e') return; + + /* if we are here, there was no dot, so the number was + an integer. Furthermore, cp1 already points to the + end of the string. */ + + *cp1++ = '.'; + *cp1++ = '0'; + *cp1++ = 0; +} + + +/* dmpport ****************************************************************/ +/* outputs buffer indicated by first argument whether full or not */ + +dmpport(useport) +FILE *useport; +{ + fflush(useport); +} + +/* protect and unprot moved to eval.c (whr) */ -- 2.20.1