![[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] / 43BSD / ucb / lisp / franz|
Return to io.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 ! root 1: #ifndef lint ! 2: static char *rcsid = ! 3: "$Header: io.c,v 1.11 85/03/24 11:03:19 sklower Exp $"; ! 4: #endif ! 5: ! 6: /* -[Tue Nov 22 10:01:14 1983 by jkf]- ! 7: * io.c $Locker: $ ! 8: * input output functions ! 9: * ! 10: * (c) copyright 1982, Regents of the University of California ! 11: */ ! 12: ! 13: #include "global.h" ! 14: #include <ctype.h> ! 15: #include "chars.h" ! 16: #include "chkrtab.h" ! 17: ! 18: struct readtable { ! 19: unsigned char ctable[132]; ! 20: } initread = { ! 21: /* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */ ! 22: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR, ! 23: /* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */ ! 24: VCHAR, VSEP, VSEP, VSEP, VSEP, VSEP, VERR, VERR, ! 25: /* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */ ! 26: VERR, VERR, VERR, VERR, VERR, VERR, VERR, VERR, ! 27: /* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */ ! 28: VERR, VERR, VERR, VSEP, VERR, VERR, VERR, VERR, ! 29: /* sp ! " # $ % & ' */ ! 30: VSEP, VCHAR, VSD, VCHAR, VCHAR, VCHAR, VCHAR, VSQ, ! 31: /* ( ) * + , - . / */ ! 32: VLPARA, VRPARA, VCHAR, VSIGN, VCHAR, VSIGN, VPERD, VCHAR, ! 33: /* 0 1 2 3 4 5 6 7 */ ! 34: VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, VNUM, ! 35: /* 8 9 : ; < = > ? */ ! 36: VNUM, VNUM, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 37: /* @ A B C D E F G */ ! 38: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 39: /* H I J K L M N O */ ! 40: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 41: /* P Q R S T U V W */ ! 42: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 43: /* X Y Z [ \ ] ^ _ */ ! 44: VCHAR, VCHAR, VCHAR, VLBRCK, VESC, VRBRCK, VCHAR, VCHAR, ! 45: /* ` a b c d e f g */ ! 46: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 47: /* h i j k l m n o */ ! 48: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 49: /* p q r s t u v w */ ! 50: VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, VCHAR, ! 51: /* x y z { | } ~ del */ ! 52: VCHAR, VCHAR, VCHAR, VCHAR, VDQ, VCHAR, VCHAR, VERR, ! 53: /* unused Xsdc Xesc Xdqc */ ! 54: 0, '"', '\\', '|' ! 55: }; ! 56: ! 57: extern unsigned char *ctable; ! 58: lispval atomval; /* external varaible containing atom returned ! 59: from internal atom reading routine */ ! 60: lispval readrx(); lispval readr(); lispval readry(); ! 61: char *atomtoolong(); ! 62: int keywait; ! 63: int plevel = -1; /* contains maximum list recursion count */ ! 64: int plength = -1; /* maximum number of list elements printed */ ! 65: static int dbqflag; ! 66: static int mantisfl = 0; ! 67: extern int uctolc; ! 68: extern lispval lastrtab; /* external variable designating current reader ! 69: table */ ! 70: static char baddot1[]= ! 71: "Bad reader construction: (. <something>)\nShould be (nil . <something>)\n"; ! 72: static char baddot2[]= ! 73: "Bad reader construction: (<something> . <something> not followed by )"; ! 74: ! 75: /* readr ****************************************************************/ ! 76: /* returns a s-expression read in from the port specified as the first */ ! 77: /* argument. Handles superbrackets, reader macros. */ ! 78: lispval ! 79: readr(useport) ! 80: FILE *useport; ! 81: { ! 82: register lispval handy = Vreadtable->a.clb; ! 83: ! 84: chkrtab(handy); ! 85: rbktf = FALSE; ! 86: rdrport = (FILE *) useport; ! 87: if(useport==stdin) ! 88: keywait = TRUE; ! 89: handy = readrx(Iratom()); ! 90: if(useport==stdin) ! 91: keywait = FALSE; ! 92: return(handy); ! 93: ! 94: } ! 95: ! 96: ! 97: /* readrx **************************************************************/ ! 98: /* returns a s-expression beginning with the syntax code of an atom */ ! 99: /* passed in the first */ ! 100: /* argument. Does the actual work for readr, including list, dotted */ ! 101: /* pair, and quoted atom detection */ ! 102: lispval ! 103: readrx(code) ! 104: register int code; ! 105: { ! 106: register lispval work; ! 107: register lispval *current; ! 108: register struct argent *result; ! 109: int inlbkt = FALSE; ! 110: lispval errorh(); ! 111: Savestack(4); /* ???not necessary because np explicitly restored if ! 112: changed */ ! 113: ! 114: top: ! 115: switch(code) ! 116: { ! 117: case TLBKT: ! 118: inlbkt = TRUE; ! 119: case TLPARA: ! 120: result = np; ! 121: current = (lispval *)np; ! 122: np++->val = nil; /*protect(nil);*/ ! 123: for(EVER) { ! 124: switch(code = Iratom()) ! 125: { ! 126: case TRPARA: ! 127: if(rbktf && inlbkt) ! 128: rbktf = FALSE; ! 129: goto out; ! 130: default: ! 131: atomval = readrx(code); ! 132: case TSCA: ! 133: np++->val=atomval; ! 134: *current = work = newdot(); ! 135: work->d.car = atomval; ! 136: np--; ! 137: current = (lispval *) &(work->d.cdr); ! 138: break; ! 139: case TINF: ! 140: imacrox(result->val,TRUE); ! 141: work = atomval; ! 142: result->val = work->d.car; ! 143: current = (lispval *) & (result->val); ! 144: goto mcom; ! 145: case TSPL: ! 146: macrox(); /* input and output in atomval */ ! 147: *current = atomval; ! 148: mcom: ! 149: while(*current!=nil) { ! 150: if(TYPE(*current)!=DTPR) ! 151: errorh1(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current); ! 152: current=(lispval *)&((*current)->d.cdr); ! 153: } ! 154: break; ! 155: case TPERD: ! 156: if(result->val==nil) { ! 157: work = result->val=newdot(); ! 158: current = (lispval *) &(work->d.cdr); ! 159: fprintf(stderr,baddot1); ! 160: } ! 161: work = readrx(TLPARA); ! 162: if (work->d.cdr!=nil) { ! 163: *current = work; work = newdot(); ! 164: work->d.cdr = *current; *current = nil; ! 165: work->d.car = result->val; ! 166: result->val = errorh1(Vermisc,baddot2,nil,TRUE,58,work); ! 167: goto out; ! 168: } ! 169: *current = work->d.car; ! 170: /* there is the possibility that the expression ! 171: following the dot is terminated with a "]" ! 172: and thus needs no closing lparens to follow ! 173: */ ! 174: if(rbktf && inlbkt) ! 175: rbktf = FALSE; ! 176: goto out; ! 177: case TEOF: ! 178: errorh1(Vermisc,"Premature end of file after ", ! 179: nil,FALSE,0,result->val); ! 180: } ! 181: if(rbktf) { ! 182: if(inlbkt) ! 183: rbktf = FALSE; ! 184: goto out; ! 185: } ! 186: } ! 187: case TSCA: ! 188: Restorestack(); ! 189: return(atomval); ! 190: case TEOF: ! 191: Restorestack(); ! 192: return(eofa); ! 193: case TMAC: ! 194: macrox(); ! 195: Restorestack(); ! 196: return(atomval); ! 197: case TINF: ! 198: imacrox(nil,FALSE); ! 199: work = atomval; ! 200: if(work==nil) { code = Iratom(); goto top;} ! 201: work = work->d.car; ! 202: Restorestack(); ! 203: if(work->d.cdr==nil) ! 204: return(work->d.car); ! 205: else ! 206: return(work); ! 207: case TSPL: ! 208: macrox(); ! 209: if((work = atomval)!=nil) { ! 210: if(TYPE(work)==DTPR && work->d.cdr==nil) { ! 211: Restorestack(); ! 212: return(work->d.car); ! 213: } else { ! 214: errorh1(Vermisc, ! 215: "Improper value returned from splicing macro at top-level",nil,FALSE,9,work); ! 216: } ! 217: } ! 218: code = Iratom(); ! 219: goto top; ! 220: /* return(readrx(Iratom())); */ ! 221: case TSQ: ! 222: result = np; ! 223: protect(newdot()); ! 224: (work = result->val)->d.car = quota; ! 225: work = work->d.cdr = newdot(); ! 226: work->d.car = readrx(Iratom()); ! 227: goto out; ! 228: ! 229: case TRPARA: ! 230: Restorestack(); ! 231: return(errorh(Vermisc, ! 232: "read: read a right paren when expecting an s-expression", ! 233: nil,FALSE,0)); ! 234: case TPERD: ! 235: Restorestack(); ! 236: return(errorh(Vermisc, ! 237: "read: read a period when expecting an s-expression", ! 238: nil,FALSE,0)); ! 239: ! 240: /* should never get here, we should have covered all cases above */ ! 241: default: ! 242: Restorestack(); ! 243: return(errorh1(Vermisc,"Readlist error, code ",nil,FALSE,0,inewint((long)code))); ! 244: } ! 245: out: ! 246: work = result->val; ! 247: np = result; ! 248: Restorestack(); ! 249: return(work); ! 250: } ! 251: macrox() ! 252: { ! 253: FILE *svport; ! 254: lispval handy, Lapply(); ! 255: ! 256: Savestack(0); ! 257: svport = rdrport; /* save from possible changing */ ! 258: lbot = np; ! 259: protect(handy=Iget(atomval,lastrtab)); ! 260: if (handy == nil) ! 261: { ! 262: errorh1(Vermisc,"read: can't find the character macro for ",nil, ! 263: FALSE,0,atomval); ! 264: } ! 265: protect(nil); ! 266: atomval = Lapply(); ! 267: chkrtab(Vreadtable->a.clb); /* the macro could have changed ! 268: the readtable ! 269: */ ! 270: rdrport = svport; /* restore old value */ ! 271: Restorestack(); ! 272: return; ! 273: } ! 274: imacrox(current,inlist) ! 275: register lispval current; ! 276: { ! 277: FILE *svport; ! 278: register lispval work; ! 279: lispval Lapply(), handy; ! 280: ! 281: Savestack(2); ! 282: svport = rdrport; /* save from possible changing */ ! 283: if(inlist) ! 284: { ! 285: protect(handy = newdot()); ! 286: handy->d.car = current; ! 287: for(work = handy->d.car; (TYPE(work->d.cdr))==DTPR; ) ! 288: work = work->d.cdr; ! 289: handy->d.cdr = work; ! 290: } ! 291: else handy = current; ! 292: ! 293: lbot = np; ! 294: protect(Iget(atomval,lastrtab)); ! 295: protect(handy); ! 296: atomval = Lfuncal(); ! 297: chkrtab(Vreadtable->a.clb); /* the macro could have changed ! 298: the readtable ! 299: */ ! 300: rdrport = svport; /* restore old value */ ! 301: Restorestack(); ! 302: return; ! 303: } ! 304: ! 305: ! 306: ! 307: /* ratomr ***************************************************************/ ! 308: /* this routine returns a pointer to an atom read in from the port given*/ ! 309: /* by the first argument */ ! 310: lispval ! 311: ratomr(useport) ! 312: register FILE *useport; ! 313: { ! 314: rdrport = useport; ! 315: switch(Iratom()) ! 316: { ! 317: case TEOF: ! 318: return(eofa); ! 319: case TSQ: ! 320: case TRPARA: ! 321: case TLPARA: ! 322: case TLBKT: ! 323: case TPERD: ! 324: strbuf[1]=0; ! 325: return(getatom(TRUE)); ! 326: default: ! 327: return(atomval); ! 328: } ! 329: } ! 330: ! 331: #define push(); *name++ = c; if(name>=endstrb) name = atomtoolong(name); ! 332: #define next() (((cc=getc(useport))!=EOF)?(stats = ctable[c = cc &0177]):\ ! 333: ((c=0),(saweof = 1),(stats = SEPMASK))) ! 334: Iratom() ! 335: { ! 336: register FILE *useport = rdrport; ! 337: register char c, marker, *name; ! 338: extern lispval finatom(), calcnum(), getnum(); ! 339: int code, cc; ! 340: int strflag = FALSE; ! 341: ! 342: name = strbuf; ! 343: ! 344: again: cc = getc(useport); ! 345: if(cc==EOF) ! 346: { ! 347: clearerr(useport); ! 348: return(TEOF); ! 349: } ! 350: c = cc & 0177; ! 351: *name = c; ! 352: ! 353: switch(synclass(ctable[c])) { ! 354: ! 355: default: goto again; ! 356: ! 357: case synclass(VNUM): ! 358: ! 359: case synclass(VSIGN): *name++ = c; ! 360: atomval = (getnum(name)); ! 361: return(TSCA); ! 362: ! 363: case synclass(VESC): ! 364: dbqflag = TRUE; ! 365: *name++ = getc(useport) & 0177; ! 366: atomval = (finatom(name)); ! 367: return(TSCA); ! 368: ! 369: case synclass(VCHAR): ! 370: if(uctolc && isupper(c)) c = tolower(c); ! 371: *name++ = c; ! 372: atomval = (finatom(name)); ! 373: return(TSCA); ! 374: ! 375: case synclass(VLPARA): return(TLPARA); ! 376: ! 377: case synclass(VRPARA): return(TRPARA); ! 378: ! 379: case synclass(VPERD): marker = peekc(useport) & 0177; ! 380: if(synclass(VNUM)!=synclass(ctable[marker])) ! 381: { if(SEPMASK & ctable[marker]) ! 382: return(TPERD); ! 383: else { *name++ = c; /* this period begins an atm */ ! 384: atomval = finatom(name); ! 385: return(TSCA); ! 386: } ! 387: } ! 388: *name++ = '.'; ! 389: mantisfl = 1; ! 390: atomval = (getnum(name)); ! 391: return(TSCA); ! 392: ! 393: case synclass(VLBRCK): return(TLBKT); ! 394: ! 395: case synclass(VRBRCK): rbktf = TRUE; ! 396: return(TRPARA); ! 397: ! 398: case synclass(VSQ): return(TSQ); ! 399: ! 400: case synclass(VSD): strflag = TRUE; ! 401: case synclass(VDQ): name = strbuf; ! 402: marker = c; ! 403: while ((c = getc(useport)) != marker) { ! 404: ! 405: if(synclass(VESC)==synclass(ctable[c])) ! 406: c = getc(useport) & 0177; ! 407: push(); ! 408: if (feof(useport)) { ! 409: clearerr(useport); ! 410: error("EOF encountered while reading atom", FALSE); ! 411: } ! 412: } ! 413: *name = NULL_CHAR; ! 414: if(strflag) ! 415: atomval = (lispval) newstr(TRUE); ! 416: else ! 417: atomval = (getatom(TRUE)); ! 418: return(TSCA); ! 419: ! 420: case synclass(VERR): if (c == '\0') ! 421: { ! 422: fprintf(stderr,"[read: null read and ignored]\n"); ! 423: goto again; /* null pname */ ! 424: } ! 425: fprintf(stderr,"%c (%o): ",c,(int) c); ! 426: error("ILLEGAL CHARACTER IN ATOM",TRUE); ! 427: ! 428: case synclass(VSINF): ! 429: code = TINF; ! 430: goto same; ! 431: case synclass(VSSPL): ! 432: code = TSPL; ! 433: goto same; ! 434: case synclass(VSMAC): ! 435: code = TMAC; ! 436: same: ! 437: marker = peekc(rdrport); ! 438: if(! (SEPMASK & ctable[marker]) ) { ! 439: *name++ = c; /* this is not a macro */ ! 440: atomval = (finatom(name)); ! 441: return(TSCA); ! 442: } ! 443: goto simple; ! 444: case synclass(VINF): ! 445: code = TINF; ! 446: goto simple; ! 447: case synclass(VSCA): ! 448: code = TSCA; ! 449: goto simple; ! 450: case synclass(VSPL): ! 451: code = TSPL; ! 452: goto simple; ! 453: case synclass(VMAC): ! 454: code = TMAC; ! 455: simple: ! 456: strbuf[0] = c; ! 457: strbuf[1] = 0; ! 458: atomval = (getatom(TRUE)); ! 459: return(code); ! 460: } ! 461: } ! 462: ! 463: lispval ! 464: getnum(name) ! 465: register char *name; ! 466: { ! 467: unsigned char c; ! 468: register lispval result; ! 469: register FILE *useport=rdrport; ! 470: unsigned char stats; ! 471: int sawdigit = 0, saweof = 0,cc; ! 472: char *exploc = (char *) 0; ! 473: double realno; ! 474: extern lispval finatom(), calcnum(), newdoub(), dopow(); ! 475: ! 476: if(mantisfl) { ! 477: mantisfl = 0; ! 478: next(); ! 479: goto mantissa; ! 480: } ! 481: if(VNUM==ctable[*(unsigned char*)(name-1)]) sawdigit = 1; ! 482: while(VNUM==next()) { ! 483: push(); /* recognize [0-9]*, in "ex" parlance */ ! 484: sawdigit = 1; ! 485: } ! 486: if(c=='.') { ! 487: push(); /* continue */ ! 488: } else if(stats & SEPMASK) { ! 489: if(!saweof)ungetc((int)c,useport); ! 490: return(calcnum(strbuf,name,(int)ibase->a.clb->i)); ! 491: } else if(c=='^') { ! 492: push(); ! 493: return(dopow(name,(int)ibase->a.clb->i)); ! 494: } else if(c=='_') { ! 495: if(sawdigit) /* _ must be preceeded by a digit */ ! 496: { ! 497: push(); ! 498: return(dopow(name,2)); ! 499: } ! 500: else goto backout; ! 501: } else if(c=='e' || c=='E' || c=='d' ||c=='D') { ! 502: if(sawdigit) goto expt; ! 503: else goto backout; ! 504: } else { ! 505: backout: ! 506: ungetc((int)c,useport); ! 507: return(finatom(name)); ! 508: } ! 509: /* at this point we have [0-9]*\. , which might ! 510: be a decimal int or the leading part of a ! 511: float */ ! 512: if(next()!=VNUM) { ! 513: if(c=='e' || c=='E' || c=='d' ||c=='D') ! 514: goto expt; ! 515: else if(c=='^') { ! 516: push(); ! 517: return(dopow(name,(int)ibase->a.clb->i)); ! 518: } else if(c=='_') { ! 519: push(); ! 520: return(dopow(name,2)); ! 521: } else if( stats & SEPMASK) { ! 522: /* Here we have 1.x where x is not number ! 523: * but is a separator ! 524: * Here we have decimal int. NOT FORTRAN! ! 525: */ ! 526: if(!saweof)ungetc((int)c,useport); ! 527: return(calcnum(strbuf,name-1,10)); ! 528: } ! 529: else goto last; /* return a symbol */ ! 530: } ! 531: mantissa: ! 532: do { ! 533: push(); ! 534: } while (VNUM==next()); ! 535: ! 536: /* Here we have [0-9]*\.[0-9]* ! 537: * three possibilities: ! 538: * next character is e,E,d or D in which case we examine ! 539: * the exponent [then we are faced with a similar ! 540: * situation to this one: is the character after the ! 541: * exponent a separator or not] ! 542: * next character is a separator, in which case we have a ! 543: * number (without an exponent) ! 544: * next character is not a separator in which case we have ! 545: * an atom (whose prefix just happens to look like a ! 546: * number) ! 547: */ ! 548: if( (c == 'e') || (c == 'E') || (c == 'd') || (c == 'D')) goto expt; ! 549: ! 550: if(stats & SEPMASK) goto verylast; /* a real number */ ! 551: else goto last; /* prefix makes it look like a number, but it isn't */ ! 552: ! 553: expt: ! 554: exploc = name; /* remember location of exponent character */ ! 555: push(); ! 556: next(); ! 557: if(c=='+' || c =='-') { ! 558: push(); ! 559: next(); ! 560: } ! 561: while (VNUM==stats) { ! 562: push(); ! 563: next(); ! 564: } ! 565: ! 566: /* if a separator follows then we have a number, else just ! 567: * an atom ! 568: */ ! 569: if (stats & SEPMASK) goto verylast; ! 570: ! 571: last: /* get here when what looks like a number turns out to be an atom */ ! 572: if(!saweof) ungetc((int)c,useport); ! 573: return(finatom(name)); ! 574: ! 575: verylast: ! 576: if(!saweof) ungetc((int)c,useport); ! 577: /* scanf requires that the exponent be 'e' */ ! 578: if(exploc != (char *) 0 ) *exploc = 'e'; ! 579: *name=0; ! 580: sscanf(strbuf,"%F",&realno); ! 581: (result = newdoub())->r = realno; ! 582: return(result); ! 583: } ! 584: ! 585: lispval ! 586: dopow(part2,base) ! 587: register char *part2; ! 588: { ! 589: register char *name = part2; ! 590: register FILE *useport = rdrport; ! 591: register int power; ! 592: lispval work; ! 593: unsigned char stats,c; ! 594: int cc, saweof = 0; ! 595: char *end1 = part2 - 1; lispval Ltimes(); ! 596: Savestack(4); ! 597: ! 598: while(VNUM==next()) { ! 599: push(); ! 600: } ! 601: if(c!='.') { ! 602: if(!saweof)ungetc((int)c,useport); ! 603: } ! 604: if(c!='.' && !(stats & SEPMASK)) { ! 605: return(finatom(name)); ! 606: } ! 607: lbot = np; ! 608: np++->val = inewint(base); ! 609: /* calculate "mantissa"*/ ! 610: if(*end1=='.') ! 611: np++->val = calcnum(strbuf,end1-1,10); ! 612: else ! 613: np++->val = calcnum(strbuf,end1,(int)ibase->a.clb->i); ! 614: ! 615: /* calculate exponent */ ! 616: if(c=='.') ! 617: power = calcnum(part2,name,10)->i; ! 618: else ! 619: power = calcnum(part2,name,(int)ibase->a.clb->i)->i; ! 620: while(power-- > 0) ! 621: lbot[1].val = Ltimes(); ! 622: work = lbot[1].val; ! 623: Restorestack(); ! 624: return(work); ! 625: } ! 626: ! 627: ! 628: lispval ! 629: calcnum(strbuf,name,base) ! 630: register char *name; ! 631: char *strbuf; ! 632: { ! 633: register char *p; ! 634: register lispval result, temp; ! 635: int negflag = 0; ! 636: ! 637: result = temp = newsdot(); /* initialize sdot cell */ ! 638: protect(temp); ! 639: p = strbuf; ! 640: if(*p=='+') p++; ! 641: else if(*p=='-') {negflag = 1; p++;} ! 642: *name = 0; ! 643: if(p>=name) return(getatom(TRUE)); ! 644: ! 645: for(;p < name; p++) ! 646: dmlad(temp,(long)base,(long)*p-'0'); ! 647: if(negflag) ! 648: dmlad(temp,-1L,0L); ! 649: ! 650: if(temp->s.CDR==0) { ! 651: result = inewint(temp->i); ! 652: pruneb(np[-1].val); ! 653: } ! 654: np--; ! 655: return(result); ! 656: } ! 657: lispval ! 658: finatom(name) ! 659: register char *name; ! 660: { ! 661: register FILE *useport = rdrport; ! 662: unsigned char c, stats; ! 663: int cc, saweof = 0; ! 664: ! 665: while(!(next()&SEPMASK)) { ! 666: ! 667: if(synclass(stats) == synclass(VESC)) { ! 668: c = getc(useport) & 0177; ! 669: } else { ! 670: if(uctolc && isupper(c)) c = tolower(c); ! 671: } ! 672: push(); ! 673: } ! 674: *name = NULL_CHAR; ! 675: if(!saweof)ungetc((int)c,useport); ! 676: return(getatom(TRUE)); ! 677: } ! 678: ! 679: char * ! 680: atomtoolong(copyto) ! 681: char *copyto; ! 682: { ! 683: int size; ! 684: register char *oldp = strbuf; ! 685: register char *newp; ! 686: lispval nveci(); ! 687: /* ! 688: * the string buffer contains an string which is too long ! 689: * so we get a bigger buffer. ! 690: */ ! 691: ! 692: size = (endstrb - strbuf)*4 + 28 ; ! 693: newp = (char *) nveci(size); ! 694: atom_buffer = (lispval) newp; ! 695: strbuf = newp; ! 696: endstrb = newp + size - 1; ! 697: while(oldp < copyto) *newp++ = *oldp++; ! 698: return(newp); ! 699: } ! 700: ! 701: /* printr ***************************************************************/ ! 702: /* prints the first argument onto the port specified by the second */ ! 703: ! 704: /* ! 705: * Last modified Mar 21, 1980 for hunks ! 706: */ ! 707: ! 708: printr(a,useport) ! 709: register lispval a; ! 710: register FILE *useport; ! 711: { ! 712: register hsize, i; ! 713: char strflag = 0; ! 714: char Idqc = 0; ! 715: char *chstr; ! 716: int curplength = plength; ! 717: int quot; ! 718: lispval Istsrch(); ! 719: lispval debugmode; ! 720: ! 721: val_loop: ! 722: if(! VALID(a)) { ! 723: debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr; ! 724: if(debugmode != nil) { ! 725: printf("<printr:bad lisp data: 0x%x>\n",a); ! 726: error("Bad lisp data encountered by printr", FALSE); ! 727: } else { ! 728: a = badst; ! 729: printf("<printr:bad lisp data: 0x%x>",a); ! 730: return; ! 731: } ! 732: } ! 733: ! 734: switch (TYPE(a)) ! 735: { ! 736: ! 737: ! 738: case UNBO: fputs("<UNBOUND>",useport); ! 739: break; ! 740: ! 741: case VALUE: fputs("(ptr to)",useport); ! 742: a = a->l; ! 743: goto val_loop; ! 744: ! 745: case INT: fprintf(useport,"%d",a->i); ! 746: break; ! 747: ! 748: case DOUB: { char buf[64]; ! 749: lfltpr(buf,a->r); ! 750: fputs(buf,useport); ! 751: } ! 752: break; ! 753: ! 754: case PORT: { lispval cp; ! 755: if((cp = ioname[PN(a->p)]) == nil) ! 756: fputs("%$unopenedport",useport); ! 757: else fprintf(useport,"%%%s",cp); ! 758: } ! 759: break; ! 760: ! 761: case HUNK2: ! 762: case HUNK4: ! 763: case HUNK8: ! 764: case HUNK16: ! 765: case HUNK32: ! 766: case HUNK64: ! 767: case HUNK128: ! 768: if(plevel == 0) ! 769: { ! 770: fputs("%",useport); ! 771: break; ! 772: } ! 773: hsize = 2 << HUNKSIZE(a); ! 774: fputs("{", useport); ! 775: plevel--; ! 776: printr(a->h.hunk[0], useport); ! 777: curplength--; ! 778: for (i=1; i < hsize; i++) ! 779: { ! 780: if (a->h.hunk[i] == hunkfree) ! 781: break; ! 782: if (curplength-- == 0) ! 783: { ! 784: fputs(" ...",useport); ! 785: break; ! 786: } ! 787: else ! 788: { ! 789: fputs(" ", useport); ! 790: printr(a->h.hunk[i], useport); ! 791: } ! 792: } ! 793: fputs("}", useport); ! 794: plevel++; ! 795: break; ! 796: ! 797: case VECTOR: ! 798: chstr = "vector"; ! 799: quot = 4; /* print out # of longwords */ ! 800: goto veccommon; ! 801: ! 802: case VECTORI: ! 803: chstr = "vectori"; ! 804: quot = 1; ! 805: veccommon: ! 806: /* print out 'vector' or 'vectori' except in ! 807: * these circumstances: ! 808: * property is a symbol, in which case print ! 809: * the symbol's pname ! 810: * property is a list with a 'print' property, ! 811: * in which case it is funcalled to print the ! 812: * vector ! 813: */ ! 814: if(a->v.vector[VPropOff] != nil) ! 815: { ! 816: if ((i=TYPE(a->v.vector[VPropOff])) == ATOM) ! 817: { ! 818: chstr = a->v.vector[VPropOff]->a.pname; ! 819: } ! 820: else if ((i == DTPR) && vectorpr(a,useport)) ! 821: { ! 822: break; /* printed by vectorpr */ ! 823: } ! 824: else if ((i == DTPR) ! 825: && (a->v.vector[VPropOff]->d.car != nil) ! 826: && TYPE(a->v.vector[VPropOff]->d.car) ! 827: == ATOM) ! 828: { ! 829: chstr = a->v.vector[VPropOff]->d.car->a.pname; ! 830: } ! 831: } ! 832: fprintf(useport,"%s[%d]", ! 833: chstr, a->vl.vectorl[VSizeOff]/quot); ! 834: break; ! 835: ! 836: case ARRAY: fputs("array[",useport); ! 837: printr(a->ar.length,useport); ! 838: fputs("]",useport); ! 839: break; ! 840: ! 841: case BCD: fprintf(useport,"#%X-",a->bcd.start); ! 842: printr(a->bcd.discipline,useport); ! 843: break; ! 844: ! 845: case OTHER: fprintf(useport,"#Other-%X",a); ! 846: break; ! 847: ! 848: case SDOT: pbignum(a,useport); ! 849: break; ! 850: ! 851: case DTPR: if(plevel==0) ! 852: { ! 853: fputs("&",useport); ! 854: break; ! 855: } ! 856: plevel--; ! 857: if(a->d.car==quota && a->d.cdr!=nil ! 858: && a->d.cdr->d.cdr==nil) { ! 859: putc('\'',useport); ! 860: printr(a->d.cdr->d.car,useport); ! 861: plevel++; ! 862: break; ! 863: } ! 864: putc('(',useport); ! 865: curplength--; ! 866: morelist: printr(a->d.car,useport); ! 867: if ((a = a->d.cdr) != nil) ! 868: { ! 869: if(curplength-- == 0) ! 870: { ! 871: fputs(" ...",useport); ! 872: goto out; ! 873: } ! 874: putc(' ',useport); ! 875: if (TYPE(a) == DTPR) goto morelist; ! 876: fputs(". ",useport); ! 877: printr(a,useport); ! 878: } ! 879: out: ! 880: fputc(')',useport); ! 881: plevel++; ! 882: break; ! 883: ! 884: case STRNG: strflag = TRUE; ! 885: Idqc = Xsdc; ! 886: ! 887: case ATOM: { ! 888: char *front, *temp, first; int clean; ! 889: temp = front = (strflag ? ((char *) a) : a->a.pname); ! 890: if(Idqc==0) Idqc = Xdqc; ! 891: ! 892: if(Idqc) { ! 893: clean = first = *temp; ! 894: first &= 0177; ! 895: switch(QUTMASK & ctable[first]) { ! 896: case QWNFRST: ! 897: case QALWAYS: ! 898: clean = 0; break; ! 899: case QWNUNIQ: ! 900: if(temp[1]==0) clean = 0; ! 901: } ! 902: if (first=='-'||first=='+') temp++; ! 903: if(synclass(ctable[*temp])==VNUM) clean = 0; ! 904: while (clean && *temp) { ! 905: if((ctable[*temp]&QUTMASK)==QALWAYS) ! 906: clean = 0; ! 907: else if(uctolc && (isupper(*temp))) ! 908: clean = 0; ! 909: temp++; ! 910: } ! 911: if (clean && !strflag) ! 912: fputs(front,useport); ! 913: else { ! 914: putc(Idqc,useport); ! 915: for(temp=front;*temp;temp++) { ! 916: if( *temp==Idqc ! 917: || (synclass(ctable[*temp])) == CESC) ! 918: putc(Xesc,useport); ! 919: putc(*temp,useport); ! 920: } ! 921: putc(Idqc,useport); ! 922: } ! 923: ! 924: } else { ! 925: register char *cp = front; ! 926: int handy = ctable[*cp & 0177]; ! 927: ! 928: if(synclass(handy)==CNUM) ! 929: putc(Xesc,useport); ! 930: else switch(handy & QUTMASK) { ! 931: case QWNUNIQ: ! 932: if(cp[1]==0) putc(Xesc,useport); ! 933: break; ! 934: case QWNFRST: ! 935: case QALWAYS: ! 936: putc(Xesc,useport); ! 937: } ! 938: for(; *cp; cp++) { ! 939: if((ctable[*cp]& QUTMASK)==QALWAYS) ! 940: putc(Xesc,useport); ! 941: putc(*cp,useport); ! 942: } ! 943: } ! 944: } ! 945: } ! 946: } ! 947: ! 948: /* -- vectorpr ! 949: * (perhaps) print out vector specially ! 950: * this is called with a vector whose property list begins with ! 951: * a list. We search for the 'print' property and if it exists, ! 952: * funcall the print function with two args: the vector and the port. ! 953: * We return TRUE iff we funcalled the function, else we return FALSE ! 954: * to have the standard printing done ! 955: */ ! 956: ! 957: vectorpr(vec,port) ! 958: register lispval vec; ! 959: FILE *port; ! 960: { ! 961: register lispval handy; ! 962: int svplevel = plevel; /* save these global values */ ! 963: int svplength = plength; ! 964: Savestack(2); ! 965: ! 966: ! 967: for ( handy = vec->v.vector[VPropOff]->d.cdr ! 968: ; handy != nil; handy = handy->d.cdr->d.cdr) ! 969: { ! 970: if (handy->d.car == Vprintsym) ! 971: { ! 972: lbot = np; ! 973: protect(handy->d.cdr->d.car); /* function to call */ ! 974: protect(vec); ! 975: protect(P(port)); ! 976: Lfuncal(); ! 977: plevel = svplevel; /* restore globals */ ! 978: plength = svplength; ! 979: Restorestack(); ! 980: return(TRUE); /* did the call */ ! 981: } ! 982: } ! 983: Restorestack(); ! 984: return(FALSE); /* nothing printed */ ! 985: } ! 986: ! 987: ! 988: ! 989: ! 990: ! 991: ! 992: lfltpr(buf,val) /* lisp floating point printer */ ! 993: char *buf; ! 994: double val; ! 995: { ! 996: register char *cp1; char *sprintf(); ! 997: ! 998: sprintf(buf,(char *)Vfloatformat->a.clb,val); ! 999: for(cp1 = buf; *cp1; cp1++) ! 1000: if(*cp1=='.'|| *cp1=='E' || *cp1 == 'e') return; ! 1001: ! 1002: /* if we are here, there was no dot, so the number was ! 1003: an integer. Furthermore, cp1 already points to the ! 1004: end of the string. */ ! 1005: ! 1006: *cp1++ = '.'; ! 1007: *cp1++ = '0'; ! 1008: *cp1++ = 0; ! 1009: } ! 1010: ! 1011: ! 1012: /* dmpport ****************************************************************/ ! 1013: /* outputs buffer indicated by first argument whether full or not */ ! 1014: ! 1015: dmpport(useport) ! 1016: FILE *useport; ! 1017: { ! 1018: fflush(useport); ! 1019: } ! 1020: ! 1021: /* 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.