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) */
Defined functions
atomtoolong
defined in line 679; used 11 times
- in line 61, 331
- in /usr/src/ucb/lisp/franz/alloc.c line 403
- in /usr/src/ucb/lisp/franz/lam2.c line 255, 268, 275, 281, 287, 299
- in /usr/src/ucb/lisp/franz/lam7.c line 474, 481
dmpport
defined in line 1015; used 7 times
- in /usr/src/ucb/lisp/franz/error.c line 269, 350-352(2)
- in /usr/src/ucb/lisp/franz/fex1.c line 257
- in /usr/src/ucb/lisp/franz/lam5.c line 506
- in /usr/src/ucb/lisp/franz/lamr.c line 384
- in /usr/src/ucb/lisp/franz/lisp.c line 83
printr
defined in line 708; used 24 times
- in line 776, 790, 837-842(2), 860, 866, 877
- in /usr/src/ucb/lisp/franz/error.c line 168, 197, 272
- in /usr/src/ucb/lisp/franz/eval.c line 345
- in /usr/src/ucb/lisp/franz/fasl.c line 536, 574, 588, 608
- in /usr/src/ucb/lisp/franz/fex1.c line 254
- in /usr/src/ucb/lisp/franz/frame.c line 271, 279-284(2)
- in /usr/src/ucb/lisp/franz/lam1.c line 869, 913
- in /usr/src/ucb/lisp/franz/lam3.c line 375
- in /usr/src/ucb/lisp/franz/lam5.c line 505
- in /usr/src/ucb/lisp/franz/lisp.c line 86
Defined variables
keywait
defined in line 62; used 3 times
- in line 88-91(2)
- in /usr/src/ucb/lisp/franz/inits.c line 190
Defined struct's
Defined macros
|
Last modified: 1985-08-14
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 2309 |
|