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