![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp|
Return to io.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 ! root 1: #include "global.h" ! 2: #include <stdio.h> ! 3: #include <ctype.h> ! 4: #include "chars.h" ! 5: ! 6: struct readtable { ! 7: char ctable[132]; ! 8: } initread = { ! 9: /* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */ ! 10: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR, ! 11: /* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */ ! 12: VCHAR, VSEP, VSEP, VSEP, VSEP, VSEP, VERR, VERR, ! 13: /* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */ ! 14: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR, ! 15: /* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */ ! 16: VERR, VERR, VERR, VSEP, VERR, VERR, VERR, VERR, ! 17: /* sp ! " # $ % & ' */ ! 18: VSEP, VCHAR, VDQ, VCHAR, VCHAR, VCHAR, VCHAR, VSQ, ! 19: /* ( ) * + , - . / */ ! 20: VLPARA, VRPARA, VCHAR, VSIGN, VCHAR, VSIGN, VPERD, VCHAR, ! 21: /* 0 1 2 3 4 5 6 7 */ ! 22: VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, ! 23: /* 8 9 : ; < = > ? */ ! 24: VNUM, VNUM, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 25: /* @ A B C D E F G */ ! 26: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 27: /* H I J K L M N O */ ! 28: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 29: /* P Q R S T U V W */ ! 30: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 31: /* X Y Z [ \ ] ^ _ */ ! 32: VCHAR, VCHAR, VCHAR, VLBRCK, VESC, VRBRCK, VCHAR, VCHAR, ! 33: /* ` a b c d e f g */ ! 34: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 35: /* h i j k l m n o */ ! 36: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 37: /* p q r s t u v w */ ! 38: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 39: /* x y z { | } ~ del */ ! 40: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VEOF, ! 41: /* unused unused Xesc Xdqc */ ! 42: 0, 0, '\\', '"' ! 43: }; ! 44: ! 45: char *ctable = initread.ctable; ! 46: lispval atomval; /* external varaible containing atom returned ! 47: from internal atom reading routine */ ! 48: lispval protect(); ! 49: lispval unprotect(); ! 50: lispval readrx(); lispval readr(); lispval readry(); ! 51: int keywait; ! 52: static int dbqflag; ! 53: static int macflag; ! 54: static int splflag; ! 55: static int mantisfl = 0; ! 56: lispval lastrtab; /* external variable designating current reader ! 57: table */ ! 58: static char baddot1[]= ! 59: "Bad reader construction: (. <something>)\nShould be (nil . <something>)\n"; ! 60: static char baddot2[]= ! 61: "Bad reader construction: (<something> .)\n\ ! 62: Should be (<something> . <something>), assumed to be (<something>)"; ! 63: static char baddot3[]= ! 64: "Bad reader construction: (<something> . <something> not followed by )"; ! 65: ! 66: #include "chkrtab.h" ! 67: /* readr ****************************************************************/ ! 68: /* returns a s-expression read in from the port specified as the first */ ! 69: /* argument. Handles superbrackets, reader macros. */ ! 70: lispval ! 71: readr(useport) ! 72: FILE *useport; ! 73: { ! 74: register lispval handy = Vreadtable->clb; ! 75: ! 76: chkrtab(handy); ! 77: rbktf = FALSE; ! 78: rdrport = (FILE *) useport; ! 79: if(useport==stdin) ! 80: keywait = TRUE; ! 81: handy = readrx(Iratom()); ! 82: if(useport==stdin) ! 83: keywait = FALSE; ! 84: return(handy); ! 85: ! 86: } ! 87: ! 88: ! 89: /* readrx **************************************************************/ ! 90: /* returns a s-expression beginning with the syntax code of an atom */ ! 91: /* passed in the first */ ! 92: /* argument. Does the actual work for readr, including list, dotted */ ! 93: /* pair, and quoted atom detection */ ! 94: lispval ! 95: readrx(code) ! 96: register int code; ! 97: { ! 98: register lispval work; ! 99: register lispval *current; ! 100: register struct argent *result; ! 101: register struct argent *lbot, *np; ! 102: int inlbkt = FALSE; ! 103: lispval errorh(); ! 104: ! 105: top: ! 106: switch(code) ! 107: { ! 108: case TLBKT: ! 109: inlbkt = TRUE; ! 110: case TLPARA: ! 111: result = np; ! 112: current = (lispval *)np; ! 113: np++->val = nil; /*protect(nil);*/ ! 114: for(EVER) { ! 115: switch(code = Iratom()) ! 116: { ! 117: case TRPARA: ! 118: if(rbktf && inlbkt) ! 119: rbktf = FALSE; ! 120: return(result->val); ! 121: default: ! 122: atomval = readrx(code); ! 123: case TSCA: ! 124: np++->val=atomval; ! 125: *current = work = newdot(); ! 126: work->car = atomval; ! 127: np--; ! 128: current = (lispval *) &(work->cdr); ! 129: break; ! 130: case TSPL: ! 131: macrox(); /* input and output in atomval */ ! 132: *current = atomval; ! 133: while(*current!=nil) { ! 134: if(TYPE(*current)!=DTPR) ! 135: errorh(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current); ! 136: current=(lispval *)&((*current)->cdr); ! 137: } ! 138: break; ! 139: case TPERD: ! 140: if(result->val==nil) { ! 141: work = result->val=newdot(); ! 142: current = (lispval *) &(work->cdr); ! 143: fprintf(stderr,baddot1); ! 144: } ! 145: code = Iratom(); ! 146: if(code==TRPARA) { ! 147: return(errorh(Vermisc,baddot2,nil,TRUE,58,result->val)); ! 148: } ! 149: *current = readrx(code); ! 150: if((code = Iratom())!=TRPARA) { ! 151: errorh(Vermisc,baddot3,nil,TRUE,59,result->val,atomval); ! 152: } ! 153: if(rbktf && inlbkt) ! 154: rbktf = FALSE; ! 155: return(result->val); ! 156: case TEOF: ! 157: clearerr(rdrport); ! 158: error("Premature end of file.", FALSE); ! 159: } ! 160: if(rbktf) { ! 161: if(inlbkt) ! 162: rbktf = FALSE; ! 163: return(result->val); ! 164: } ! 165: } ! 166: case TSCA: ! 167: return(atomval); ! 168: case TEOF: ! 169: return(eofa); ! 170: case TMAC: ! 171: macrox(); ! 172: return(atomval); ! 173: case TSPL: ! 174: macrox(); ! 175: if((work = atomval)!=nil) { ! 176: if(TYPE(work)==DTPR && work->cdr==nil) ! 177: return(work->car); ! 178: else ! 179: errorh(Vermisc, ! 180: "Improper value returned from splicing macro at top-level",nil,FALSE,9,work); ! 181: } ! 182: code = Iratom(); ! 183: goto top; ! 184: /* return(readrx(Iratom())); */ ! 185: case TSQ: ! 186: result = np; ! 187: protect(newdot()); ! 188: (work = result->val)->car = quota; ! 189: work = work->cdr = newdot(); ! 190: work->car = readrx(Iratom()); ! 191: return(result->val); ! 192: default: ! 193: return(error("Readlist error",FALSE)); ! 194: } ! 195: } ! 196: macrox() ! 197: { ! 198: lispval Lapply(); ! 199: ! 200: snpand(0); ! 201: lbot = np; ! 202: protect(Iget(atomval,macro)); ! 203: protect(nil); ! 204: atomval = Lapply(); ! 205: return; ! 206: } ! 207: ! 208: ! 209: ! 210: /* ratomr ***************************************************************/ ! 211: /* this routine returns a pointer to an atom read in from the port given*/ ! 212: /* by the first argument */ ! 213: lispval ! 214: ratomr(useport) ! 215: register FILE *useport; ! 216: { ! 217: rdrport = useport; ! 218: switch(Iratom()) ! 219: { ! 220: case TEOF: ! 221: return(eofa); ! 222: case TSQ: ! 223: case TRPARA: ! 224: case TLPARA: ! 225: case TLBKT: ! 226: case TPERD: ! 227: strbuf[1]=0; ! 228: return(getatom()); ! 229: default: ! 230: return(atomval); ! 231: } ! 232: } ! 233: Iratom() ! 234: { ! 235: register FILE *useport = rdrport; ! 236: register char c, marker, *name; ! 237: extern lispval finatom(), calcnum(), getnum(); ! 238: char positv = TRUE; ! 239: int code; ! 240: int strflag = FALSE; ! 241: ! 242: name = strbuf; ! 243: ! 244: again: c = getc(useport) & 0177; ! 245: *name = c; ! 246: ! 247: switch(ctable[c] & 0377) { ! 248: ! 249: default: goto again; ! 250: ! 251: case VNUM: ! 252: ! 253: case VSIGN: *name++ = c; ! 254: atomval = (getnum(name)); ! 255: return(TSCA); ! 256: ! 257: case VESC: ! 258: dbqflag = TRUE; ! 259: *name++ = getc(useport) & 0177; ! 260: atomval = (finatom(name)); ! 261: return(TSCA); ! 262: ! 263: case VCHAR: ! 264: *name++ = c; ! 265: atomval = (finatom(name)); ! 266: return(TSCA); ! 267: ! 268: case VLPARA: return(TLPARA); ! 269: ! 270: case VRPARA: return(TRPARA); ! 271: ! 272: case VPERD: c = peekc(useport); ! 273: if(VNUM!=ctable[c]) ! 274: return(TPERD); ! 275: *name++ = '.'; ! 276: mantisfl = 1; ! 277: atomval = (getnum(name)); ! 278: return(TSCA); ! 279: ! 280: case VLBRCK: return(TLBKT); ! 281: ! 282: case VRBRCK: rbktf = TRUE; ! 283: return(TRPARA); ! 284: ! 285: case VEOF: /*printf("returning eof atom\n");*/ ! 286: return(TEOF); ! 287: ! 288: case VSQ: return(TSQ); ! 289: ! 290: case VSD: strflag = TRUE; ! 291: case VDQ: name = strbuf; ! 292: marker = c; ! 293: while ((c = getc(useport)) != marker) { ! 294: ! 295: if(VESC==ctable[c]) c = getc(useport); ! 296: *name++ = c; ! 297: if (name >= endstrb) ! 298: error("ATOM TOO LONG",FALSE); ! 299: if (feof(useport)) { ! 300: clearerr(useport); ! 301: error("EOF ecountered while reading atom", FALSE); ! 302: } ! 303: } ! 304: *name = NULL_CHAR; ! 305: if(strflag) ! 306: atomval = (lispval) inewstr(strbuf); ! 307: else ! 308: atomval = (getatom(name)); ! 309: return(TSCA); ! 310: ! 311: case VERR: if (c == '\0') goto same; /* null pname */ ! 312: fprintf(stderr,"%c (%o): ",c,(int) c); ! 313: error("ILLEGAL CHARACTER IN ATOM",TRUE); ! 314: ! 315: case VSPL: ! 316: code = TSPL; ! 317: goto same; ! 318: case VMAC: ! 319: code = TMAC; ! 320: goto same; ! 321: case VSCA: ! 322: code = TSCA; ! 323: same: ! 324: strbuf[0] = c; ! 325: strbuf[1] = 0; ! 326: atomval = (getatom()); ! 327: return(code); ! 328: } ! 329: } ! 330: ! 331: #define push(); if(name==endstrb) error("Int too long",FALSE); else *name++=c; ! 332: #define next() (stats = ctable[c=getc(useport) & 0177]) ! 333: ! 334: lispval ! 335: getnum(name) ! 336: register char *name; ! 337: { ! 338: register char c; ! 339: register lispval result; ! 340: register FILE *useport=rdrport; ! 341: char stats; ! 342: double realno; ! 343: extern lispval finatom(), calcnum(), newdoub(), dopow(); ! 344: ! 345: if(mantisfl) { ! 346: mantisfl = 0; ! 347: next(); ! 348: goto mantissa; ! 349: } ! 350: while(VNUM==next()) { ! 351: push(); /* recognize [0-9]*, in "ex" parlance */ ! 352: } ! 353: if(stats==VPERD) { ! 354: push(); /* continue */ ! 355: } else if(stats & SEPMASK) { ! 356: ungetc(c,useport); ! 357: return(calcnum(strbuf,name,ibase->clb->i)); ! 358: } else if(c=='^') { ! 359: push(); ! 360: return(dopow(name,ibase->clb->i)); ! 361: } else if(c=='_') { ! 362: push(); ! 363: return(dopow(name,2)); ! 364: } else{ ! 365: ungetc(c,useport); ! 366: return(finatom(name)); ! 367: } ! 368: /* at this point we have [0-9]*\. , which might ! 369: be a decimal int or the leading part of a ! 370: float */ ! 371: if(next()!=VNUM) { ! 372: if(c=='e' || c=='E' || c=='d' ||c=='D') ! 373: goto expt; ! 374: else if(c=='^') { ! 375: push(); ! 376: return(dopow(name,ibase->clb->i)); ! 377: } else if(c=='_') { ! 378: push(); ! 379: return(dopow(name,2)); ! 380: } else { ! 381: /* Here we have 1.x where x not num, not sep */ ! 382: /* Here we have decimal int. NOT FORTRAN! */ ! 383: ungetc(c,useport); ! 384: return(calcnum(strbuf,name-1,10)); ! 385: } ! 386: } ! 387: mantissa: ! 388: do { ! 389: push(); ! 390: } while (VNUM==next()); ! 391: /* Here we have [0-9]*\.[0-9]* */ ! 392: if(stats & SEPMASK) ! 393: goto last; ! 394: else if(c!='e' && c!='E' && c!='d' && c!='D') { ! 395: ungetc(c,useport); ! 396: goto verylast; ! 397: } ! 398: expt: push(); ! 399: next(); ! 400: if(c=='+' || c =='-') { ! 401: push(); ! 402: next(); ! 403: } ! 404: while (VNUM==stats) { ! 405: push(); ! 406: next(); ! 407: } ! 408: last: ungetc(c,useport); ! 409: if(! (stats & SEPMASK) ) ! 410: return(finatom(name)); ! 411: ! 412: verylast: ! 413: *name=0; ! 414: sscanf(strbuf,"%F",&realno); ! 415: (result = newdoub())->r = realno; ! 416: return(result); ! 417: } ! 418: ! 419: lispval ! 420: dopow(part2,base) ! 421: lispval base; ! 422: char *part2; ! 423: { ! 424: register char *name = part2; ! 425: register char c; ! 426: register FILE *useport = rdrport; ! 427: register int power; ! 428: register struct argent *lbot, *np; ! 429: char stats; ! 430: char *end1 = part2 - 1; lispval Ltimes(); ! 431: ! 432: while(VNUM==next()) { ! 433: push(); ! 434: } ! 435: if(c!='.') { ! 436: ungetc(c,useport); ! 437: } ! 438: if(c!='.' && !(stats & SEPMASK)) { ! 439: return(finatom(name)); ! 440: } ! 441: lbot = np; ! 442: np++->val = inewint(base); ! 443: /* calculate "mantissa"*/ ! 444: if(*end1=='.') ! 445: np++->val = calcnum(strbuf,end1-1,10); ! 446: else ! 447: np++->val = calcnum(strbuf,end1,ibase->clb->i); ! 448: ! 449: /* calculate exponent */ ! 450: if(c=='.') ! 451: power = calcnum(part2,name,10)->i; ! 452: else ! 453: power = calcnum(part2,name,ibase->clb->i)->i; ! 454: while(power-- > 0) ! 455: lbot[1].val = Ltimes(); ! 456: return(lbot[1].val); ! 457: } ! 458: ! 459: ! 460: lispval ! 461: calcnum(strbuf,name,base) ! 462: char *name; ! 463: char *strbuf; ! 464: { ! 465: register char *p; ! 466: register lispval result, temp; ! 467: int negflag = 0; ! 468: ! 469: temp = rdrsdot; /* initialize sdot cell */ ! 470: temp->CDR = nil; ! 471: temp->i = 0; ! 472: p = strbuf; ! 473: if(*p=='+') p++; ! 474: else if(*p=='-') {negflag = 1; p++;} ! 475: *name = 0; ! 476: if(p>=name) return(getatom()); ! 477: ! 478: for(;p < name; p++) ! 479: dmlad(temp,base,*p-'0'); ! 480: if(negflag) ! 481: dmlad(temp,-1,0); ! 482: ! 483: if(temp->CDR==0) { ! 484: result = inewint(temp->i); ! 485: return(result); ! 486: } else { ! 487: (result = newsdot())->i = temp->i; ! 488: result->CDR = temp->CDR; ! 489: temp->CDR = 0; ! 490: } ! 491: return(result); ! 492: } ! 493: lispval ! 494: finatom(name) ! 495: register char *name; ! 496: { ! 497: extern int uctolc; ! 498: register FILE *useport = rdrport; ! 499: register char c, stats; ! 500: register char *savenm; ! 501: savenm = name - 1; /* remember start of name */ ! 502: while(!(next()&SEPMASK)) { ! 503: ! 504: if(stats == VESC) c = getc(useport) & 0177; ! 505: *name++=c; ! 506: if (name >= endstrb) ! 507: error("ATOM TOO LONG",FALSE); ! 508: } ! 509: *name = NULL_CHAR; ! 510: ungetc(c,useport); ! 511: if (uctolc) for(; *savenm ; savenm++) ! 512: if( isupper(*savenm) ) *savenm = tolower(*savenm); ! 513: return(getatom()); ! 514: } ! 515: ! 516: /* printr ***************************************************************/ ! 517: /* prints the first argument onto the port specified by the second */ ! 518: printr(a,useport) ! 519: register lispval a; ! 520: register FILE *useport; ! 521: { ! 522: register lispval temp; ! 523: char strflag = 0; ! 524: char Idqc = 0; ! 525: ! 526: ! 527: val_loop: ! 528: if( ! VALID(a) ) ! 529: { ! 530: error("BAD LISP DATA ENCOUNTERED BY PRINTR",TRUE); ! 531: a = badst; ! 532: } ! 533: ! 534: switch (TYPE(a)) { ! 535: ! 536: ! 537: case UNBO: fputs("<UNBOUND>",useport); ! 538: break; ! 539: ! 540: case VALUE: fputs("(ptr to)",useport); ! 541: a = a->l; ! 542: goto val_loop; ! 543: ! 544: case INT: fprintf(useport,"%d",a->i); ! 545: break; ! 546: ! 547: case DOUB: fprintf(useport,"%0.16G",a->r); ! 548: break; ! 549: ! 550: case PORT: fputs("port",useport); ! 551: break; ! 552: ! 553: case ARRAY: fputs("array[",useport); ! 554: printr(a->length,useport); ! 555: fputs("]",useport); ! 556: break; ! 557: ! 558: case BCD: fprintf(useport,"#%X-",a->entry); ! 559: printr(a->discipline,useport); ! 560: break; ! 561: ! 562: case SDOT: pbignum(a,useport); ! 563: break; ! 564: ! 565: case DTPR: if(a->car==quota && a->cdr!=nil ! 566: && a->cdr->cdr==nil) { ! 567: putc('\'',useport); ! 568: printr(a->cdr->car,useport); ! 569: break; ! 570: } ! 571: putc('(',useport); ! 572: morelist: printr(a->car,useport); ! 573: if ((a = a->cdr) != nil) ! 574: { ! 575: putc(' ',useport); ! 576: if (TYPE(a) == DTPR) goto morelist; ! 577: fputs(". ",useport); ! 578: printr(a,useport); ! 579: } ! 580: fputc(')',useport); ! 581: break; ! 582: ! 583: case STRNG: strflag = TRUE; ! 584: Idqc = Xsdc; ! 585: ! 586: case ATOM: { ! 587: char *front, *temp; int clean; ! 588: temp = front = (strflag ? ((char *) a) : a->pname); ! 589: if(Idqc==0) Idqc = Xdqc; ! 590: ! 591: if(Idqc) { ! 592: clean = *temp; ! 593: if (*temp == '-') temp++; ! 594: clean = clean && (ctable[*temp] != VNUM); ! 595: while (clean && *temp) ! 596: clean = (!(ctable[*temp++] & QUTMASK)); ! 597: if (clean) ! 598: fputs(front,useport); ! 599: else { ! 600: putc(Idqc,useport); ! 601: for(temp=front;*temp;temp++) { ! 602: if( *temp==Idqc ! 603: || ctable[*temp] == VESC) ! 604: putc(Xesc,useport); ! 605: putc(*temp,useport); ! 606: } ! 607: putc(Idqc,useport); ! 608: } ! 609: ! 610: } else { ! 611: register char *cp = front; ! 612: ! 613: if(ctable[*cp]==VNUM) ! 614: putc(Xesc,useport); ! 615: for(; *cp; cp++) { ! 616: if(ctable[*cp]& QUTMASK) ! 617: putc(Xesc,useport); ! 618: putc(*cp,useport); ! 619: } ! 620: ! 621: } ! 622: ! 623: } ! 624: } ! 625: } ! 626: ! 627: /* dmpport ****************************************************************/ ! 628: /* outputs buffer indicated by first argument whether full or not */ ! 629: dmpport(useport) ! 630: register lispval useport; ! 631: { ! 632: fflush(useport); ! 633: } ! 634: ! 635: /* protect and unprot moved to eval.c (whr) */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.