![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lcode.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / icon / src / link|
Return to lcode.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / link |
1.1 ! root 1: /* ! 2: * Routines to parse .u1 files and produce icode. ! 3: */ ! 4: ! 5: #include "opcode.h" ! 6: #include "ilink.h" ! 7: #include "../h/keyword.h" ! 8: #include "../h/version.h" ! 9: #include "../h/header.h" ! 10: ! 11: #ifndef MaxHeader ! 12: #define MaxHeader MaxHdr ! 13: #endif MaxHeader ! 14: ! 15: static word pc = 0; /* simulated program counter */ ! 16: ! 17: #define outword(n) wordout((word)(n)) ! 18: ! 19: /* ! 20: * gencode - read .u1 file, resolve variable references, and generate icode. ! 21: * Basic process is to read each line in the file and take some action ! 22: * as dictated by the opcode. This action sometimes involves parsing ! 23: * of operands and usually culminates in the call of the appropriate ! 24: * emit* routine. ! 25: * ! 26: * Appendix C of the "tour" has a complete description of the intermediate ! 27: * language that gencode parses. ! 28: */ ! 29: gencode() ! 30: { ! 31: register int op, k, lab; ! 32: int j, nargs, flags, implicit; ! 33: char *id, *name, *procname; ! 34: struct centry *cp; ! 35: struct gentry *gp; ! 36: struct fentry *fp, *flocate(); ! 37: ! 38: extern long getint(); ! 39: extern double getreal(); ! 40: union { ! 41: long ival; ! 42: double rval; ! 43: char *sval; ! 44: } gg; ! 45: extern char *getid(), *getstrlit(); ! 46: extern struct gentry *glocate(); ! 47: ! 48: while ((op = getop(&name)) != EOF) { ! 49: switch (op) { ! 50: ! 51: /* Ternary operators. */ ! 52: ! 53: case Op_Toby: ! 54: case Op_Sect: ! 55: ! 56: /* Binary operators. */ ! 57: ! 58: case Op_Asgn: ! 59: case Op_Cat: ! 60: case Op_Diff: ! 61: case Op_Div: ! 62: case Op_Eqv: ! 63: case Op_Inter: ! 64: case Op_Lconcat: ! 65: case Op_Lexeq: ! 66: case Op_Lexge: ! 67: case Op_Lexgt: ! 68: case Op_Lexle: ! 69: case Op_Lexlt: ! 70: case Op_Lexne: ! 71: case Op_Minus: ! 72: case Op_Mod: ! 73: case Op_Mult: ! 74: case Op_Neqv: ! 75: case Op_Numeq: ! 76: case Op_Numge: ! 77: case Op_Numgt: ! 78: case Op_Numle: ! 79: case Op_Numlt: ! 80: case Op_Numne: ! 81: case Op_Plus: ! 82: case Op_Power: ! 83: case Op_Rasgn: ! 84: case Op_Rswap: ! 85: case Op_Subsc: ! 86: case Op_Swap: ! 87: case Op_Unions: ! 88: ! 89: /* Unary operators. */ ! 90: ! 91: case Op_Bang: ! 92: case Op_Compl: ! 93: case Op_Neg: ! 94: case Op_Nonnull: ! 95: case Op_Null: ! 96: case Op_Number: ! 97: case Op_Random: ! 98: case Op_Refresh: ! 99: case Op_Size: ! 100: case Op_Tabmat: ! 101: case Op_Value: ! 102: ! 103: /* Instructions. */ ! 104: ! 105: case Op_Bscan: ! 106: case Op_Ccase: ! 107: case Op_Coact: ! 108: case Op_Cofail: ! 109: case Op_Coret: ! 110: case Op_Dup: ! 111: case Op_Efail: ! 112: case Op_Eret: ! 113: case Op_Escan: ! 114: case Op_Esusp: ! 115: case Op_Limit: ! 116: case Op_Lsusp: ! 117: case Op_Pfail: ! 118: case Op_Pnull: ! 119: case Op_Pop: ! 120: case Op_Pret: ! 121: case Op_Psusp: ! 122: case Op_Push1: ! 123: case Op_Pushn1: ! 124: case Op_Sdup: ! 125: newline(); ! 126: emit(op, name); ! 127: break; ! 128: ! 129: case Op_Chfail: ! 130: case Op_Create: ! 131: case Op_Goto: ! 132: case Op_Init: ! 133: lab = getlab(); ! 134: newline(); ! 135: emitl(op, lab, name); ! 136: break; ! 137: ! 138: case Op_Cset: ! 139: case Op_Real: ! 140: k = getdec(); ! 141: newline(); ! 142: emitr(op, ctable[k].c_pc, name); ! 143: break; ! 144: ! 145: case Op_Field: ! 146: id = getid(); ! 147: newline(); ! 148: fp = flocate(id); ! 149: if (fp == NULL) { ! 150: err(id, "invalid field name", 0); ! 151: break; ! 152: } ! 153: emitn(op, (word)(fp->f_fid-1), name); ! 154: break; ! 155: ! 156: case Op_Int: ! 157: k = getdec(); ! 158: newline(); ! 159: cp = &ctable[k]; ! 160: if (cp->c_flag & F_LongLit) ! 161: emitr(Op_Long, cp->c_pc, "long"); ! 162: else { ! 163: long int i; ! 164: i = (long)cp->c_val.ival; ! 165: emitint(op, i, name); ! 166: } ! 167: break; ! 168: ! 169: case Op_Invoke: ! 170: k = getdec(); ! 171: newline(); ! 172: emitn(op, (word)k, name); ! 173: break; ! 174: ! 175: case Op_Keywd: ! 176: k = getdec(); ! 177: newline(); ! 178: switch (k) { ! 179: case K_FAIL: ! 180: emit(Op_Efail,"efail"); ! 181: break; ! 182: case K_NULL: ! 183: emit(Op_Pnull,"pnull"); ! 184: break; ! 185: default: ! 186: emitn(op, (word)k, name); ! 187: } ! 188: break; ! 189: ! 190: case Op_Llist: ! 191: k = getdec(); ! 192: newline(); ! 193: emitn(op, (word)k, name); ! 194: break; ! 195: ! 196: case Op_Lab: ! 197: lab = getlab(); ! 198: newline(); ! 199: if (Dflag) ! 200: fprintf(dbgfile, "L%d:\n", lab); ! 201: backpatch(lab); ! 202: break; ! 203: ! 204: case Op_Line: ! 205: line = getdec(); ! 206: newline(); ! 207: emitn(op, (word)line, name); ! 208: break; ! 209: ! 210: case Op_Mark: ! 211: lab = getlab(); ! 212: newline(); ! 213: emitl(op, lab, name); ! 214: break; ! 215: ! 216: case Op_Mark0: ! 217: emit(op, name); ! 218: break; ! 219: ! 220: case Op_Str: ! 221: k = getdec(); ! 222: newline(); ! 223: cp = &ctable[k]; ! 224: id = cp->c_val.sval; ! 225: emitin(op, (word)(id-strings), cp->c_length, name); ! 226: break; ! 227: ! 228: case Op_Tally: ! 229: k = getdec(); ! 230: newline(); ! 231: emitn(op, (word)k, name); ! 232: break; ! 233: ! 234: case Op_Unmark: ! 235: emit(Op_Unmark, name); ! 236: break; ! 237: ! 238: case Op_Var: ! 239: k = getdec(); ! 240: newline(); ! 241: flags = ltable[k].l_flag; ! 242: if (flags & F_Global) ! 243: emitn(Op_Global, (word)(ltable[k].l_val.global-gtable), "global"); ! 244: else if (flags & F_Static) ! 245: emitn(Op_Static, (word)(ltable[k].l_val.staticid-1), "static"); ! 246: else if (flags & F_Argument) ! 247: emitn(Op_Arg, (word)(ltable[k].l_val.offset-1), "arg"); ! 248: else ! 249: emitn(Op_Local, (word)(ltable[k].l_val.offset-1), "local"); ! 250: break; ! 251: ! 252: /* Declarations. */ ! 253: ! 254: case Op_Proc: ! 255: procname = getid(); ! 256: newline(); ! 257: locinit(); ! 258: clearlab(); ! 259: line = 0; ! 260: gp = glocate(procname); ! 261: implicit = gp->g_flag & F_ImpError; ! 262: nargs = gp->g_nargs; ! 263: emiteven(); ! 264: break; ! 265: ! 266: case Op_Local: ! 267: k = getdec(); ! 268: flags = getoct(); ! 269: id = getid(); ! 270: putloc(k, id, flags, implicit, procname); ! 271: break; ! 272: ! 273: case Op_Con: ! 274: k = getdec(); ! 275: flags = getoct(); ! 276: if (flags & F_IntLit) { ! 277: gg.ival = getint(); ! 278: putconst(k, flags, 0, pc, gg); ! 279: } ! 280: else if (flags & F_RealLit) { ! 281: gg.rval = getreal(); ! 282: putconst(k, flags, 0, pc, gg); ! 283: } ! 284: else if (flags & F_StrLit) { ! 285: j = getdec(); ! 286: gg.sval = getstrlit(j); ! 287: putconst(k, flags, j, pc, gg); ! 288: } ! 289: else if (flags & F_CsetLit) { ! 290: j = getdec(); ! 291: gg.sval = getstrlit(j); ! 292: putconst(k, flags, j, pc, gg); ! 293: } ! 294: else ! 295: fprintf(stderr, "gencode: illegal constant\n"); ! 296: newline(); ! 297: emitcon(k); ! 298: break; ! 299: ! 300: case Op_Filen: ! 301: file = getid(); ! 302: newline(); ! 303: break; ! 304: ! 305: case Op_Declend: ! 306: newline(); ! 307: gp->g_pc = pc; ! 308: emitproc(procname, nargs, dynoff, statics-static1, static1); ! 309: break; ! 310: ! 311: case Op_End: ! 312: newline(); ! 313: flushcode(); ! 314: break; ! 315: ! 316: default: ! 317: fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name); ! 318: newline(); ! 319: } ! 320: } ! 321: } ! 322: ! 323: /* ! 324: * emit - emit opcode. ! 325: * emitl - emit opcode with reference to program label, consult the "tour" ! 326: * for a description of the chaining and backpatching for labels. ! 327: * emitn - emit opcode with integer argument. ! 328: * emitr - emit opcode with pc-relative reference. ! 329: * emiti - emit opcode with reference to identifier table. ! 330: * emitin - emit opcode with reference to identifier table & integer argument. ! 331: * emitint - emit word opcode with integer argument. ! 332: * emiteven - emit null bytes to bring pc to word boundary. ! 333: * emitcon - emit constant table entry. ! 334: * emitproc - emit procedure block. ! 335: * ! 336: * The emit* routines call out* routines to effect the "outputting" of icode. ! 337: * Note that the majority of the code for the emit* routines is for debugging ! 338: * purposes. ! 339: */ ! 340: emit(op, name) ! 341: int op; ! 342: char *name; ! 343: { ! 344: if (Dflag) ! 345: fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name); ! 346: outword(op); ! 347: } ! 348: ! 349: emitl(op, lab, name) ! 350: int op, lab; ! 351: char *name; ! 352: { ! 353: if (Dflag) ! 354: fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name); ! 355: if (lab >= maxlabels) ! 356: syserr("too many labels in ucode"); ! 357: outword(op); ! 358: if (labels[lab] <= 0) { /* forward reference */ ! 359: outword(labels[lab]); ! 360: labels[lab] = WordSize - pc; /* add to front of reference chain */ ! 361: } ! 362: else /* output relative offset */ ! 363: outword(labels[lab] - (pc + WordSize)); ! 364: } ! 365: ! 366: emitn(op, n, name) ! 367: int op; ! 368: word n; ! 369: char *name; ! 370: { ! 371: if (Dflag) ! 372: fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n, name); ! 373: outword(op); ! 374: outword(n); ! 375: } ! 376: ! 377: emitr(op, loc, name) ! 378: int op; ! 379: word loc; ! 380: char *name; ! 381: { ! 382: loc -= pc + (WordSize * 2); ! 383: if (Dflag) { ! 384: if (loc >= 0) ! 385: fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op, (long)loc, name); ! 386: else ! 387: fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op, (long)-loc, name); ! 388: } ! 389: outword(op); ! 390: outword(loc); ! 391: } ! 392: ! 393: emiti(op, offset, name) ! 394: int op; ! 395: word offset; ! 396: char *name; ! 397: { ! 398: if (Dflag) ! 399: fprintf(dbgfile, "%ld:\t%d\tI+%d\t\t\t# %s\n", (long)pc, op, offset, name); ! 400: outword(op); ! 401: outword(offset); ! 402: } ! 403: ! 404: emitin(op, offset, n, name) ! 405: int op, n; ! 406: word offset; ! 407: char *name; ! 408: { ! 409: if (Dflag) ! 410: fprintf(dbgfile, "%ld:\t%d\t%d,I+%ld\t\t\t# %s\n", (long)pc, op, n, (long)offset, name); ! 411: outword(op); ! 412: outword(n); ! 413: outword(offset); ! 414: } ! 415: /* ! 416: * emitint can have some pitfalls. outword is used to output the ! 417: * integer and this is picked up in the interpreter as the second ! 418: * word of a short integer. The integer value output must be ! 419: * the same size as what the interpreter expects. See op_int and op_intx ! 420: * in interp.s ! 421: */ ! 422: emitint(op, i, name) ! 423: int op; ! 424: long int i; ! 425: char *name; ! 426: { ! 427: if (Dflag) ! 428: fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)i, name); ! 429: outword(op); ! 430: outword(i); ! 431: } ! 432: ! 433: emiteven() ! 434: { ! 435: while ((pc % WordSize) != 0) { ! 436: if (Dflag) ! 437: fprintf(dbgfile, "%ld:\t0\n",(long) pc); ! 438: outword(0); ! 439: } ! 440: } ! 441: ! 442: emitcon(k) ! 443: register int k; ! 444: { ! 445: register int i, j; ! 446: register char *s; ! 447: int csbuf[CsetSize]; ! 448: union { ! 449: char ovly[1]; /* Array used to overlay l and f on a bytewise basis. */ ! 450: long int l; ! 451: double f; ! 452: } x; ! 453: ! 454: if (ctable[k].c_flag & F_RealLit) { ! 455: #ifdef Double ! 456: /* access real values one word at a time */ ! 457: { int *rp, *rq; ! 458: rp = (int *) &(x.f); ! 459: rq = (int *) &(ctable[k].c_val.rval); ! 460: *rp++ = *rq++; ! 461: *rp = *rq; ! 462: } ! 463: #else Double ! 464: x.f = ctable[k].c_val.rval; ! 465: #endif Double ! 466: if (Dflag) { ! 467: fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Real); ! 468: dumpblock(x.ovly,sizeof(double)); ! 469: fprintf(dbgfile, "\t\t\t( %g )\n",x.f); ! 470: } ! 471: outword(T_Real); ! 472: ! 473: #ifdef Double ! 474: /* fill out real block with an empty word */ ! 475: outword(0); ! 476: #endif Double ! 477: outblock(x.ovly,sizeof(double)); ! 478: } ! 479: else if (ctable[k].c_flag & F_LongLit) { ! 480: x.l = ctable[k].c_val.ival; ! 481: if (Dflag) { ! 482: fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Longint); ! 483: dumpblock(x.ovly,sizeof(long)); ! 484: fprintf(dbgfile,"\t\t\t( %ld)\n",(long)x.l); ! 485: } ! 486: outword(T_Longint); ! 487: outblock(x.ovly,sizeof(long)); ! 488: } ! 489: else if (ctable[k].c_flag & F_CsetLit) { ! 490: for (i = 0; i < CsetSize; i++) ! 491: csbuf[i] = 0; ! 492: s = ctable[k].c_val.sval; ! 493: i = ctable[k].c_length; ! 494: while (i--) { ! 495: Setb(*s, csbuf); ! 496: s++; ! 497: } ! 498: j = 0; ! 499: for (i = 0; i < 256; i++) { ! 500: if (Testb(i, csbuf)) ! 501: j++; ! 502: } ! 503: if (Dflag) { ! 504: fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset); ! 505: fprintf(dbgfile, "\t%d\n",j); ! 506: fprintf(dbgfile,csbuf,sizeof(csbuf)); ! 507: } ! 508: outword(T_Cset); ! 509: outword(j); /* cset size */ ! 510: outblock(csbuf,sizeof(csbuf)); ! 511: if (Dflag) ! 512: dumpblock(csbuf,CsetSize); ! 513: } ! 514: } ! 515: ! 516: emitproc(name, nargs, ndyn, nstat, fstat) ! 517: char *name; ! 518: int nargs, ndyn, nstat, fstat; ! 519: { ! 520: register int i; ! 521: register char *p; ! 522: int size; ! 523: /* ! 524: * FncBlockSize = sizeof(BasicFncBlock) + ! 525: * sizeof(descrip)*(# of args + # of dynamics + # of statics). ! 526: */ ! 527: size = (10*WordSize) + (2*WordSize) * (nargs+ndyn+nstat); ! 528: ! 529: if (Dflag) { ! 530: fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */ ! 531: fprintf(dbgfile, "\t%d\n", size); /* size of block */ ! 532: fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size)); /* entry point */ ! 533: fprintf(dbgfile, "\t%d\n", nargs); /* # of arguments */ ! 534: fprintf(dbgfile, "\t%d\n", ndyn); /* # of dynamic locals */ ! 535: fprintf(dbgfile, "\t%d\n", nstat); /* # of static locals */ ! 536: fprintf(dbgfile, "\t%d\n", fstat); /* first static */ ! 537: fprintf(dbgfile, "\t%s\n", file); /* file */ ! 538: fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", /* name of procedure */ ! 539: strlen(name), (long)(name-strings), name); ! 540: } ! 541: outword(T_Proc); ! 542: outword(size); ! 543: outword(pc + size - 2*WordSize); /* Have to allow for the two words ! 544: that we've already output. */ ! 545: outword(nargs); ! 546: outword(ndyn); ! 547: outword(nstat); ! 548: outword(fstat); ! 549: outword(file - strings); ! 550: outword(strlen(name)); ! 551: outword(name - strings); ! 552: ! 553: /* ! 554: * Output string descriptors for argument names by looping through ! 555: * all locals, and picking out those with F_Argument set. ! 556: */ ! 557: for (i = 0; i <= nlocal; i++) { ! 558: if (ltable[i].l_flag & F_Argument) { ! 559: p = ltable[i].l_name; ! 560: if (Dflag) ! 561: fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", strlen(p), (long)(p-strings), p); ! 562: outword(strlen(p)); ! 563: outword(p - strings); ! 564: } ! 565: } ! 566: ! 567: /* ! 568: * Output string descriptors for local variable names. ! 569: */ ! 570: for (i = 0; i <= nlocal; i++) { ! 571: if (ltable[i].l_flag & F_Dynamic) { ! 572: p = ltable[i].l_name; ! 573: if (Dflag) ! 574: fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", strlen(p), (long)(p-strings), p); ! 575: outword(strlen(p)); ! 576: outword(p - strings); ! 577: } ! 578: } ! 579: ! 580: /* ! 581: * Output string descriptors for local variable names. ! 582: */ ! 583: for (i = 0; i <= nlocal; i++) { ! 584: if (ltable[i].l_flag & F_Static) { ! 585: p = ltable[i].l_name; ! 586: if (Dflag) ! 587: fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", strlen(p), (long)(p-strings), p); ! 588: outword(strlen(p)); ! 589: outword(p - strings); ! 590: } ! 591: } ! 592: } ! 593: ! 594: /* ! 595: * gentables - generate interpreter code for global, static, ! 596: * identifier, and record tables, and built-in procedure blocks. ! 597: */ ! 598: ! 599: gentables() ! 600: { ! 601: register int i; ! 602: register char *s; ! 603: register struct gentry *gp; ! 604: struct fentry *fp; ! 605: struct rentry *rp; ! 606: struct header hdr; ! 607: char *strcpy(); ! 608: ! 609: emiteven(); ! 610: ! 611: /* ! 612: * Output record constructor procedure blocks. ! 613: */ ! 614: hdr.records = pc; ! 615: if (Dflag) ! 616: fprintf(dbgfile, "%ld:\t%d\t\t\t\t# record blocks\n",(long)pc, nrecords); ! 617: outword(nrecords); ! 618: for (gp = gtable; gp < gfree; gp++) { ! 619: if (gp->g_flag & (F_Record & ~F_Global)) { ! 620: s = gp->g_name; ! 621: gp->g_pc = pc; ! 622: if (Dflag) { ! 623: fprintf(dbgfile, "%ld:\n", pc); ! 624: fprintf(dbgfile, "\t%d\n", T_Proc); ! 625: fprintf(dbgfile, "\t%d\n", RkBlkSize); ! 626: fprintf(dbgfile, "\t_mkrec\n"); ! 627: fprintf(dbgfile, "\t%d\n", gp->g_nargs); ! 628: fprintf(dbgfile, "\t-2\n"); ! 629: fprintf(dbgfile, "\t%d\n", gp->g_procid); ! 630: fprintf(dbgfile, "\t0\n"); ! 631: fprintf(dbgfile, "\t0\n"); ! 632: fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", strlen(s), (long)(s-strings), s); ! 633: } ! 634: outword(T_Proc); /* type code */ ! 635: outword(RkBlkSize); /* size of block */ ! 636: outword(0); /* entry point (filled in by interp)*/ ! 637: outword(gp->g_nargs); /* number of fields */ ! 638: outword(-2); /* record constructor indicator */ ! 639: outword(gp->g_procid); /* record id */ ! 640: outword(0); /* not used */ ! 641: outword(0); /* not used */ ! 642: outword(strlen(s)); /* name of record */ ! 643: outword(s - strings); ! 644: } ! 645: } ! 646: ! 647: /* ! 648: * Output record/field table. ! 649: */ ! 650: hdr.ftab = pc; ! 651: if (Dflag) ! 652: fprintf(dbgfile, "%ld:\t\t\t\t\t# record/field table\n", (long)pc); ! 653: for (fp = ftable; fp < ffree; fp++) { ! 654: if (Dflag) ! 655: fprintf(dbgfile, "%ld:\n", (long)pc); ! 656: rp = fp->f_rlist; ! 657: for (i = 1; i <= nrecords; i++) { ! 658: if (rp != NULL && rp->r_recid == i) { ! 659: if (Dflag) ! 660: fprintf(dbgfile, "\t%d\n", rp->r_fnum); ! 661: outword(rp->r_fnum); ! 662: rp = rp->r_link; ! 663: } ! 664: else { ! 665: if (Dflag) ! 666: fprintf(dbgfile, "\t-1\n"); ! 667: outword(-1); ! 668: } ! 669: if (Dflag && (i == nrecords || (i & 03) == 0)) ! 670: putc('\n', dbgfile); ! 671: } ! 672: } ! 673: ! 674: /* ! 675: * Output global variable descriptors. ! 676: */ ! 677: hdr.globals = pc; ! 678: for (gp = gtable; gp < gfree; gp++) { ! 679: if (gp->g_flag & (F_Builtin & ~F_Global)) { /* built-in procedure */ ! 680: if (Dflag) ! 681: fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n", ! 682: (long)pc, (long)D_Proc, -gp->g_procid, gp->g_name); ! 683: outword(D_Proc); ! 684: outword(-gp->g_procid); ! 685: } ! 686: else if (gp->g_flag & (F_Proc & ~F_Global)) { /* Icon procedure */ ! 687: if (Dflag) ! 688: fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", ! 689: (long)pc,(long)D_Proc, (long)gp->g_pc, gp->g_name); ! 690: outword(D_Proc); ! 691: outword(gp->g_pc); ! 692: } ! 693: else if (gp->g_flag & (F_Record & ~F_Global)) { /* record constructor */ ! 694: if (Dflag) ! 695: fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", ! 696: (long)pc, (long)D_Proc, (long)gp->g_pc, gp->g_name); ! 697: outword(D_Proc); ! 698: outword(gp->g_pc); ! 699: } ! 700: else { /* global variable */ ! 701: if (Dflag) ! 702: fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc,(long)D_Null, gp->g_name); ! 703: outword(D_Null); ! 704: outword(0); ! 705: } ! 706: } ! 707: ! 708: /* ! 709: * Output descriptors for global variable names. ! 710: */ ! 711: hdr.gnames = pc; ! 712: for (gp = gtable; gp < gfree; gp++) { ! 713: if (Dflag) ! 714: fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n", ! 715: (long)pc, strlen(gp->g_name), (long)(gp->g_name-strings), gp->g_name); ! 716: outword(strlen(gp->g_name)); ! 717: outword(gp->g_name - strings); ! 718: } ! 719: ! 720: /* ! 721: * Output a null descriptor for each static variable. ! 722: */ ! 723: hdr.statics = pc; ! 724: for (i = statics; i > 0; i--) { ! 725: if (Dflag) ! 726: fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc); ! 727: outword(D_Null); ! 728: outword(0); ! 729: } ! 730: flushcode(); ! 731: ! 732: /* ! 733: * Output the identifier table. Note that the call to write ! 734: * really does all the work. ! 735: */ ! 736: hdr.ident = pc; ! 737: if (Dflag) { ! 738: for (s = strings; s < strfree; ) { ! 739: fprintf(dbgfile, "%ld:\t%03o\n", (long)pc, *s++); ! 740: for (i = 7; i > 0; i--) { ! 741: if (s >= strfree) ! 742: break; ! 743: fprintf(dbgfile, " %03o\n", *s++); ! 744: } ! 745: putc('\n', dbgfile); ! 746: } ! 747: } ! 748: #ifndef MSDOS ! 749: write(fileno(outfile), strings, strfree - strings); ! 750: #else MSDOS ! 751: #ifdef SPTR ! 752: write(fileno(outfile), strings, strfree - strings); ! 753: #else /* Handle the case where strfree-strings will create a long int */ ! 754: longwrite(fileno(outfile), strings, (long)(strfree - strings)); ! 755: #endif ! 756: #endif MSDOS ! 757: pc += strfree - strings; ! 758: ! 759: /* ! 760: * Output icode file header. ! 761: */ ! 762: hdr.hsize = pc; ! 763: strcpy((char *)hdr.config,IVersion); ! 764: hdr.trace = trace; ! 765: if (Dflag) { ! 766: fprintf(dbgfile, "size: %ld\n", (long)hdr.hsize); ! 767: fprintf(dbgfile, "trace: %ld\n", (long)hdr.trace); ! 768: fprintf(dbgfile, "records: %ld\n", (long)hdr.records); ! 769: fprintf(dbgfile, "ftab: %ld\n", (long)hdr.ftab); ! 770: fprintf(dbgfile, "globals: %ld\n", (long)hdr.globals); ! 771: fprintf(dbgfile, "gnames: %ld\n", (long)hdr.gnames); ! 772: fprintf(dbgfile, "statics: %ld\n", (long)hdr.statics); ! 773: fprintf(dbgfile, "ident: %ld\n", (long)hdr.ident); ! 774: fprintf(dbgfile, "config: %s\n", hdr.config); ! 775: } ! 776: #ifndef NoHeader ! 777: fseek(outfile, (long)MaxHeader, 0); ! 778: #else NoHeader ! 779: fseek(outfile, 0L, 0); ! 780: #endif NoHeader ! 781: write(fileno(outfile), &hdr, sizeof hdr); ! 782: } ! 783: ! 784: #define CodeCheck if (codep >= code + maxcode)\ ! 785: syserr("out of code buffer space") ! 786: /* ! 787: * outword(i) outputs i as a word that is used by the runtime system ! 788: * WordSize bytes must be moved from &word[0] to &codep[0]. ! 789: */ ! 790: wordout(oword) ! 791: word oword; ! 792: { ! 793: int i; ! 794: union { ! 795: word i; ! 796: char c[WordSize]; ! 797: } u; ! 798: ! 799: CodeCheck; ! 800: u.i = oword; ! 801: ! 802: for (i = 0; i < WordSize; i++) ! 803: codep[i] = u.c[i]; ! 804: ! 805: codep += WordSize; ! 806: pc += WordSize; ! 807: } ! 808: /* ! 809: * outblock(a,i) output i bytes starting at address a. ! 810: */ ! 811: outblock(addr,count) ! 812: char *addr; ! 813: int count; ! 814: { ! 815: if (codep + count > code + maxcode) ! 816: syserr("out of code buffer space"); ! 817: pc += count; ! 818: while (count--) ! 819: *codep++ = *addr++; ! 820: } ! 821: /* ! 822: * dumpblock(a,i) dump contents of i bytes at address a, used only ! 823: * in conjunction with -D. ! 824: */ ! 825: dumpblock(addr, count) ! 826: char *addr; ! 827: int count; ! 828: { ! 829: int i; ! 830: for (i = 0; i < count; i++) { ! 831: if ((i & 7) == 0) ! 832: fprintf(dbgfile,"\n\t"); ! 833: fprintf(dbgfile," %03o\n",(unsigned)addr[i]); ! 834: } ! 835: putc('\n',dbgfile); ! 836: } ! 837: ! 838: /* ! 839: * flushcode - write buffered code to the output file. ! 840: */ ! 841: flushcode() ! 842: { ! 843: if (codep > code) ! 844: write(fileno(outfile), code, codep - code); ! 845: codep = code; ! 846: } ! 847: ! 848: /* ! 849: * clearlab - clear label table to all zeroes. ! 850: */ ! 851: clearlab() ! 852: { ! 853: register int i; ! 854: ! 855: for (i = 0; i < maxlabels; i++) ! 856: labels[i] = 0; ! 857: } ! 858: ! 859: /* ! 860: * backpatch - fill in all forward references to lab. ! 861: */ ! 862: backpatch(lab) ! 863: int lab; ! 864: { ! 865: word p, r; ! 866: register char *q; ! 867: register char *cp, *cr; ! 868: register int j; ! 869: ! 870: if (lab >= maxlabels) ! 871: syserr("too many labels in ucode"); ! 872: ! 873: p = labels[lab]; ! 874: if (p > 0) ! 875: syserr("multiply defined label in ucode"); ! 876: while (p < 0) { /* follow reference chain */ ! 877: r = pc - (WordSize - p); /* compute relative offset */ ! 878: q = codep - (pc + p); /* point to word with address */ ! 879: cp = (char *) &p; /* address of integer p */ ! 880: cr = (char *) &r; /* address of integer r */ ! 881: for (j = 0; j < WordSize; j++) { /* move bytes from int pointed to */ ! 882: *cp++ = *q; /* by q to p, and move bytes from */ ! 883: *q++ = *cr++; /* r to int pointed to by q */ ! 884: } /* moves integers at arbitrary addresses */ ! 885: } ! 886: labels[lab] = pc; ! 887: } ! 888: #ifdef MSDOS ! 889: #ifdef LPTR ! 890: /* Write a long string in 32k chunks */ ! 891: static longwrite(file,s,len) ! 892: int file; ! 893: char *s; ! 894: long int len; ! 895: { ! 896: long int loopnum; ! 897: unsigned int leftover; ! 898: char *p; ! 899: ! 900: loopnum = len / 32768; ! 901: leftover = len % 32768; ! 902: for(p = s, loopnum = len/32768;loopnum;loopnum--) { ! 903: write(file,p,32768); ! 904: p += 32768; ! 905: } ! 906: if(leftover) write(file,p,leftover); ! 907: } ! 908: #endif LPTR ! 909: #endif MSDOS
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.