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