home *** CD-ROM | disk | FTP | other *** search
/ PD Collection CD 1 / PD Collection CD 1.iso / programer2 / icon / Source / Icont / C / Lcode < prev    next >
Encoding:
Text File  |  1990-07-20  |  30.1 KB  |  1,214 lines
  1. /*
  2.  * lcode.c -- linker routines to parse .u1 files and produce icode.
  3.  */
  4.  
  5. #include <math.h>
  6. #include "../h/config.h"
  7. #include "general.h"
  8. #include "tproto.h"
  9. #include "globals.h"
  10. #include "opcode.h"
  11. #include "link.h"
  12. #include "../h/keyword.h"
  13. #include "../h/version.h"
  14. #include "../h/header.h"
  15.  
  16. /*
  17.  * Prototypes.
  18.  */
  19.  
  20. hidden novalue    backpatch    Params((int lab));
  21. hidden novalue    clearlab    Params((noargs));
  22. hidden novalue    flushcode    Params((noargs));
  23. hidden novalue    intout        Params((int oint));
  24. hidden novalue    lemit        Params((int op,char *name));
  25. hidden novalue    lemitcon    Params((int k));
  26. hidden novalue    lemiteven    Params((noargs));
  27. hidden novalue    lemitin        Params((int op,word offset,int n,char *name));
  28. hidden novalue    lemitint    Params((int op,long i,char *name));
  29. hidden novalue    lemitl        Params((int op,int lab,char *name));
  30. hidden novalue    lemitn        Params((int op,word n,char *name));
  31. hidden novalue    lemitproc
  32.    Params((char *name,int nargs,int ndyn,int nstat, int fstat));
  33. hidden novalue    lemitr        Params((int op,word loc,char *name));
  34. hidden novalue    outblock    Params((char *addr,int count));
  35. hidden novalue    wordout        Params((word oword));
  36.  
  37. #ifdef DeBugLinker
  38. hidden novalue    dumpblock    Params((char *addr,int count));
  39. #endif                    /* DeBugLinker */
  40.  
  41. #if AMIGA
  42. #include <fcntl.h>
  43. #endif                    /* AMIGA */
  44.  
  45. #if MVS
  46. extern char *routname;            /* at least under SAS C */
  47. #endif                    /* MVS */
  48.  
  49. #ifndef MaxHeader
  50. #define MaxHeader MaxHdr
  51. #endif                    /* MaxHeader */
  52.  
  53. word pc = 0;        /* simulated program counter */
  54.  
  55. #define outword(n)    wordout((word)(n))
  56. #define outop(n)    intout((int)(n))
  57. #define CodeCheck(n) if ((long)codep + n > (long)((long)codeb + maxcode))\
  58.                      quit("out of code buffer space")
  59.  
  60. /*
  61.  * gencode - read .u1 file, resolve variable references, and generate icode.
  62.  *  Basic process is to read each line in the file and take some action
  63.  *  as dictated by the opcode.    This action sometimes involves parsing
  64.  *  of arguments and usually culminates in the call of the appropriate
  65.  *  lemit* routine.
  66.  */
  67. novalue gencode()
  68.    {
  69.    register int op, k, lab;
  70.    int j, nargs, flags, implicit;
  71.    char *id, *name, *procname;
  72.    struct centry *cp;
  73.    struct gentry *gp;
  74.    struct fentry *fp;
  75.    union xval gg;
  76.  
  77.    while ((op = getopc(&name)) != EOF) {
  78.       switch (op) {
  79.  
  80.          /* Ternary operators. */
  81.  
  82.          case Op_Toby:
  83.          case Op_Sect:
  84.  
  85.          /* Binary operators. */
  86.  
  87.          case Op_Asgn:
  88.          case Op_Cat:
  89.          case Op_Diff:
  90.          case Op_Div:
  91.          case Op_Eqv:
  92.          case Op_Inter:
  93.          case Op_Lconcat:
  94.          case Op_Lexeq:
  95.          case Op_Lexge:
  96.          case Op_Lexgt:
  97.          case Op_Lexle:
  98.          case Op_Lexlt:
  99.          case Op_Lexne:
  100.          case Op_Minus:
  101.          case Op_Mod:
  102.          case Op_Mult:
  103.          case Op_Neqv:
  104.          case Op_Numeq:
  105.          case Op_Numge:
  106.          case Op_Numgt:
  107.          case Op_Numle:
  108.          case Op_Numlt:
  109.          case Op_Numne:
  110.          case Op_Plus:
  111.          case Op_Power:
  112.          case Op_Rasgn:
  113.          case Op_Rswap:
  114.          case Op_Subsc:
  115.          case Op_Swap:
  116.          case Op_Unions:
  117.  
  118.          /* Unary operators. */
  119.  
  120.          case Op_Bang:
  121.          case Op_Compl:
  122.          case Op_Neg:
  123.          case Op_Nonnull:
  124.          case Op_Null:
  125.          case Op_Number:
  126.          case Op_Random:
  127.          case Op_Refresh:
  128.          case Op_Size:
  129.          case Op_Tabmat:
  130.          case Op_Value:
  131.  
  132.          /* Instructions. */
  133.  
  134.          case Op_Bscan:
  135.          case Op_Ccase:
  136.          case Op_Coact:
  137.          case Op_Cofail:
  138.          case Op_Coret:
  139.          case Op_Dup:
  140.          case Op_Efail:
  141.          case Op_Eret:
  142.          case Op_Escan:
  143.          case Op_Esusp:
  144.          case Op_Limit:
  145.          case Op_Lsusp:
  146.          case Op_Pfail:
  147.          case Op_Pnull:
  148.          case Op_Pop:
  149.          case Op_Pret:
  150.          case Op_Psusp:
  151.          case Op_Push1:
  152.          case Op_Pushn1:
  153.          case Op_Sdup:
  154.             newline();
  155.             lemit(op, name);
  156.             break;
  157.  
  158.          case Op_Chfail:
  159.          case Op_Create:
  160.          case Op_Goto:
  161.          case Op_Init:
  162.             lab = getlab();
  163.             newline();
  164.             lemitl(op, lab, name);
  165.             break;
  166.  
  167.          case Op_Cset:
  168.          case Op_Real:
  169.             k = getdec();
  170.             newline();
  171.             lemitr(op, lctable[k].c_pc, name);
  172.             break;
  173.  
  174.          case Op_Field:
  175.             id = getid();
  176.             newline();
  177.             fp = flocate(id);
  178.             if (fp == NULL) {
  179.                lfatal(id, "invalid field name");
  180.                break;
  181.                }
  182.             lemitn(op, (word)(fp->f_fid-1), name);
  183.             break;
  184.  
  185.  
  186.          case Op_Int: {
  187.             long i;
  188.             k = getdec();
  189.             newline();
  190.             cp = &lctable[k];
  191.             /*
  192.              * Check to see if a large integers has been converted to a string.
  193.              *  If so, generate the code for +s.
  194.              */
  195.             if (cp->c_flag & F_StrLit) {
  196.                id = cp->c_val.sval;
  197.                lemit(Op_Pnull,"pnull");
  198.                lemitin(Op_Str, (word)(id-lsspace), cp->c_length, "str");
  199.                lemit(Op_Number,"number");
  200.                break;
  201.                }
  202.             i = (long)cp->c_val.ival;
  203.             lemitint(op, i, name);
  204.             break;
  205.             }
  206.  
  207.  
  208.          case Op_Invoke:
  209.             k = getdec();
  210.             newline();
  211.             if (k == -1)
  212.                lemit(Op_Apply,"apply");
  213.             else
  214.                lemitn(op, (word)k, name);
  215.             break;
  216.  
  217.          case Op_Keywd:
  218.             k = getdec();
  219.             newline();
  220.             switch (k) {
  221.                case K_FAIL:
  222.                   lemit(Op_Efail,"efail");
  223.                   break;
  224.                case K_NULL:
  225.                   lemit(Op_Pnull,"pnull");
  226.                   break;
  227.                default:
  228.                lemitn(op, (word)k, name);
  229.             }
  230.             break;
  231.  
  232.          case Op_Llist:
  233.             k = getdec();
  234.             newline();
  235.             lemitn(op, (word)k, name);
  236.             break;
  237.  
  238.          case Op_Lab:
  239.             lab = getlab();
  240.             newline();
  241.  
  242. #ifdef DeBugLinker
  243.             if (Dflag)
  244.                fprintf(dbgfile, "L%d:\n", lab);
  245. #endif                    /* DeBugLinker */
  246.             backpatch(lab);
  247.             break;
  248.  
  249.          case Op_Line:
  250.             if (lnfree >= &lntable[nsize])
  251.                quit("out of line number table space");
  252.             lnfree->ipc = pc;
  253.             lineno = getdec();
  254.             lnfree->line = lineno;
  255.             lnfree++;
  256.  
  257. #ifdef EvalTrace
  258.             lemitn(op, (word)lineno, name);
  259. #endif                    /* EvalTrace */
  260.             
  261.             newline();
  262.  
  263.  
  264. #ifdef LineCodes
  265.             lemit(Op_Noop,"noop");
  266. #endif                    /* LineCodes */
  267.  
  268.             break;
  269.  
  270. #ifdef EvalTrace
  271.          case Op_Colm:
  272.             colmno = getdec();
  273.             lemitn(op, (word)colmno, name);
  274.             break;
  275. #endif                    /* EvalTrace */
  276.  
  277.          case Op_Mark:
  278.             lab = getlab();
  279.             newline();
  280.             lemitl(op, lab, name);
  281.             break;
  282.  
  283.          case Op_Mark0:
  284.             lemit(op, name);
  285.             break;
  286.  
  287.          case Op_Str:
  288.             k = getdec();
  289.             newline();
  290.             cp = &lctable[k];
  291.             id = cp->c_val.sval;
  292.             lemitin(op, (word)(id-lsspace), cp->c_length, name);
  293.             break;
  294.     
  295.          case Op_Tally:
  296.             k = getdec();
  297.             newline();
  298.             lemitn(op, (word)k, name);
  299.             break;
  300.  
  301.          case Op_Unmark:
  302.             lemit(Op_Unmark, name);
  303.             break;
  304.  
  305.          case Op_Var:
  306.             k = getdec();
  307.             newline();
  308.             flags = lltable[k].l_flag;
  309.             if (flags & F_Global)
  310.                lemitn(Op_Global, (word)(lltable[k].l_val.global-lgtable),
  311.                   "global");
  312.             else if (flags & F_Static)
  313.                lemitn(Op_Static, (word)(lltable[k].l_val.staticid-1), "static");
  314.             else if (flags & F_Argument)
  315.                lemitn(Op_Arg, (word)(lltable[k].l_val.offset-1), "arg");
  316.             else
  317.                lemitn(Op_Local, (word)(lltable[k].l_val.offset-1), "local");
  318.             break;
  319.  
  320.          /* Declarations. */
  321.  
  322.          case Op_Proc:
  323.             procname = getid();
  324.             newline();
  325.             locinit();
  326.             clearlab();
  327.             lineno = 0;
  328.             gp = glocate(procname);
  329.             implicit = gp->g_flag & F_ImpError;
  330.             nargs = gp->g_nargs;
  331.             lemiteven();
  332.             break;
  333.  
  334.          case Op_Local:
  335.             k = getdec();
  336.             flags = getoct();
  337.             id = getid();
  338.             putlocal(k, id, flags, implicit, procname);
  339.             break;
  340.  
  341.          case Op_Con:
  342.             k = getdec();
  343.             flags = getoct();
  344.             if (flags & F_IntLit) {
  345.                {
  346.                long m;
  347.                char *s;
  348.  
  349.                j = getdec();        /* number of characters in integer */
  350.                m = getint(j,&s);    /* convert if possible */
  351.                if (m < 0) {         /* negative indicates integer too big */
  352.                   gg.sval = s;        /* convert to a string */
  353.                   putconst(k, F_StrLit, j, pc, &gg);
  354.                   }
  355.                else {            /* integers is small enough */
  356.                   gg.ival = m;
  357.                   putconst(k, flags, 0, pc, &gg);
  358.                   }
  359.                }
  360.                }
  361.             else if (flags & F_RealLit) {
  362.                gg.rval = getreal();
  363.                putconst(k, flags, 0, pc, &gg);
  364.                }
  365.             else if (flags & F_StrLit) {
  366.                j = getdec();
  367.                gg.sval = getstrlit(j);
  368.                putconst(k, flags, j, pc, &gg);
  369.                }
  370.             else if (flags & F_CsetLit) {
  371.                j = getdec();
  372.                gg.sval = getstrlit(j);
  373.                putconst(k, flags, j, pc, &gg);
  374.                }
  375.             else
  376.                fprintf(stderr, "gencode: illegal constant\n");
  377.             newline();
  378.             lemitcon(k);
  379.             break;
  380.  
  381.          case Op_Filen:
  382.             if (fnmfree >= &fnmtbl[fnmsize])
  383.                quit("out of file name table space");
  384.  
  385. #ifdef CRAY
  386.             fnmfree->ipc = pc/8;
  387. #else                    /* CRAY */
  388.             fnmfree->ipc = pc;
  389. #endif                    /* CRAY */
  390.  
  391.             fnmfree->fname = getrest() - lsspace;
  392.             fnmfree++;
  393.             newline();
  394.             break;
  395.  
  396.          case Op_Declend:
  397.             newline();
  398.             gp->g_pc = pc;
  399.             lemitproc(procname, nargs, dynoff, lstatics-static1, static1);
  400.             break;
  401.  
  402.          case Op_End:
  403.             newline();
  404.             flushcode();
  405.             break;
  406.  
  407.          default:
  408.             fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name);
  409.             newline();
  410.          }
  411.       }
  412.    }
  413.  
  414. /*
  415.  *  lemit - emit opcode.
  416.  *  lemitl - emit opcode with reference to program label.
  417.  *    for a description of the chaining and backpatching for labels.
  418.  *  lemitn - emit opcode with integer argument.
  419.  *  lemitr - emit opcode with pc-relative reference.
  420.  *  lemitin - emit opcode with reference to identifier table & integer argument.
  421.  *  lemitint - emit word opcode with integer argument.
  422.  *  lemiteven - emit null bytes to bring pc to word boundary.
  423.  *  lemitcon - emit constant table entry.
  424.  *  lemitproc - emit procedure block.
  425.  *
  426.  * The lemit* routines call out* routines to effect the "outputting" of icode.
  427.  *  Note that the majority of the code for the lemit* routines is for debugging
  428.  *  purposes.
  429.  */
  430. static novalue lemit(op, name)
  431. int op;
  432. char *name;
  433.    {
  434.  
  435. #ifdef DeBugLinker
  436.    if (Dflag)
  437.       fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name);
  438. #else                    /* DeBugLinker */
  439. #if MACINTOSH && MPW
  440. /* #pragma unused(name)    */
  441. #endif                    /* MACINTOSH && MPW */
  442. #endif                    /* DeBugLinker */
  443.  
  444.    outop(op);
  445.    }
  446.  
  447. static novalue lemitl(op, lab, name)
  448. int op, lab;
  449. char *name;
  450.    {
  451.  
  452. #ifdef DeBugLinker
  453.    if (Dflag)
  454.       fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name);
  455. #else                    /* DeBugLinker */
  456. #if MACINTOSH && MPW
  457. /* #pragma unused(name)    */
  458. #endif                    /* MACINTOSH && MPW */
  459. #endif                    /* DeBugLinker */
  460.  
  461.    if (lab >= maxlabels)
  462.       quit("out of label space");
  463.    outop(op);
  464.    if (labels[lab] <= 0) {        /* forward reference */
  465.       outword(labels[lab]);
  466.       labels[lab] = WordSize - pc;    /* add to front of reference chain */
  467.       }
  468.    else                    /* output relative offset */
  469.  
  470. #ifdef CRAY
  471.       outword((labels[lab] - (pc + WordSize))/8);
  472. #else                    /* CRAY */
  473.       outword(labels[lab] - (pc + WordSize));
  474. #endif                    /* CRAY */
  475.    }
  476.  
  477. static novalue lemitn(op, n, name)
  478. int op;
  479. word n;
  480. char *name;
  481.    {
  482.  
  483. #ifdef DeBugLinker
  484.    if (Dflag)
  485.       fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n,
  486.          name);
  487. #else                    /* DeBugLinker */
  488. #if MACINTOSH && MPW
  489. /* #pragma unused(name) */
  490. #endif                    /* MACINTOSH && MPW */
  491. #endif                    /* DeBugLinker */
  492.  
  493.    outop(op);
  494.    outword(n);
  495.    }
  496.  
  497.  
  498. static novalue lemitr(op, loc, name)
  499. int op;
  500. word loc;
  501. char *name;
  502.    {
  503.  
  504. #ifdef CRAY
  505.    loc = (loc - pc - 16)/8;
  506. #else                    /* CRAY */
  507.    loc -= pc + ((IntBits/ByteBits) + WordSize);
  508. #endif                    /* CRAY */
  509.  
  510. #ifdef DeBugLinker
  511.    if (Dflag) {
  512.       if (loc >= 0)
  513.          fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op,
  514.             (long)loc, name);
  515.       else
  516.          fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op,
  517.             (long)-loc, name);
  518.       }
  519. #else                    /* DeBugLinker */
  520. #if MACINTOSH && MPW
  521. /* #pragma unused(name) */
  522. #endif                    /* MACINTOSH && MPW */
  523. #endif                    /* DeBugLinker */
  524.  
  525.    outop(op);
  526.    outword(loc);
  527.    }
  528.  
  529. static novalue lemitin(op, offset, n, name)
  530. int op, n;
  531. word offset;
  532. char *name;
  533.    {
  534.  
  535. #ifdef DeBugLinker
  536.    if (Dflag)
  537.       fprintf(dbgfile, "%ld:\t%d\t%d,I+%ld\t\t\t# %s\n", (long)pc, op, n,
  538.          (long)offset, name);
  539. #else                    /* DeBugLinker */
  540. #if MACINTOSH && MPW
  541. /* #pragma unused(name) */
  542. #endif                    /* MACINTOSH && MPW */
  543. #endif                    /* DeBugLinker */
  544.  
  545.    outop(op);
  546.    outword(n);
  547.    outword(offset);
  548.    }
  549.  
  550. /*
  551.  * lemitint can have some pitfalls.  outword is used to output the
  552.  *  integer and this is picked up in the interpreter as the second
  553.  *  word of a short integer.  The integer value output must be
  554.  *  the same size as what the interpreter expects.  See op_int and op_intx
  555.  *  in interp.s
  556.  */
  557. static novalue lemitint(op, i, name)
  558. int op;
  559. long i;
  560. char *name;
  561.    {
  562.  
  563. #ifdef DeBugLinker
  564.    if (Dflag)
  565.       fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name);
  566. #else                    /* DeBugLinker */
  567. #if MACINTOSH && MPW
  568. /* #pragma unused(name) */
  569. #endif                    /* MACINTOSH && MPW */
  570. #endif                    /* DeBugLinker */
  571.  
  572.    outop(op);
  573.    outword(i);
  574.    }
  575.  
  576. static novalue lemiteven()
  577.    {
  578.    word x = 0;
  579.    register int len;
  580.  
  581.    if (len = pc % (IntBits/ByteBits))
  582.       outblock((char *)x, (IntBits/ByteBits) - len);
  583.    }
  584.  
  585. static novalue lemitcon(k)
  586. register int k;
  587.    {
  588.    register int i, j;
  589.    register char *s;
  590.    int csbuf[CsetSize];
  591.    union {
  592.       char ovly[1];  /* Array used to overlay l and f on a bytewise basis. */
  593.       long l;
  594.       double f;
  595.       } x;
  596.  
  597.    if (lctable[k].c_flag & F_RealLit) {
  598.  
  599. #ifdef Double
  600. /* access real values one word at a time */
  601.       {  int *rp, *rq;
  602.          rp = (int *) &(x.f);
  603.          rq = (int *) &(lctable[k].c_val.rval);
  604.          *rp++ = *rq++;
  605.          *rp    = *rq;
  606.       }
  607. #else                    /* Double */
  608.       x.f = lctable[k].c_val.rval;
  609. #endif                    /* Double */
  610.  
  611. #ifdef DeBugLinker
  612.       if (Dflag) {
  613.          fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Real);
  614.          dumpblock(x.ovly,sizeof(double));
  615.          fprintf(dbgfile, "\t\t\t( %g )\n",x.f);
  616.          }
  617. #endif                    /* DeBugLinker */
  618.  
  619.       outword(T_Real);
  620.  
  621. #ifdef Double
  622. /* fill out real block with an empty word */
  623.       outword(0);
  624. #endif                    /* Double */
  625.  
  626.       outblock(x.ovly,sizeof(double));
  627.       }
  628.    else if (lctable[k].c_flag & F_CsetLit) {
  629.       for (i = 0; i < CsetSize; i++)
  630.          csbuf[i] = 0;
  631.       s = lctable[k].c_val.sval;
  632.       i = lctable[k].c_length;
  633.       while (i--) {
  634.          Setb(ToAscii(*s), csbuf);
  635.          s++;
  636.          }
  637.       j = 0;
  638.       for (i = 0; i < 256; i++) {
  639.          if (Testb(i, csbuf))
  640.            j++;
  641.          }
  642.  
  643. #ifdef DeBugLinker
  644.       if (Dflag) {
  645.          fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset);
  646.          fprintf(dbgfile, "\t%d\n",j);
  647.          }
  648. #endif                    /* DeBugLinker */
  649.  
  650.       outword(T_Cset);
  651.       outword(j);           /* cset size */
  652.       outblock((char *)csbuf,sizeof(csbuf));
  653.  
  654. #ifdef DeBugLinker
  655.       if (Dflag)
  656.          dumpblock((char *)csbuf,CsetSize);
  657. #endif                    /* DeBugLinker */
  658.  
  659.       }
  660.    }
  661.  
  662. static novalue lemitproc(name, nargs, ndyn, nstat, fstat)
  663. char *name;
  664. int nargs, ndyn, nstat, fstat;
  665.    {
  666.    register int i;
  667.    register char *p;
  668.    int size;
  669.    /*
  670.     * FncBlockSize = sizeof(BasicFncBlock) +
  671.     *  sizeof(descrip)*(# of args + # of dynamics + # of statics).
  672.     */
  673.    size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat);
  674.  
  675. #ifdef DeBugLinker
  676.    if (Dflag) {
  677.       fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */
  678.       fprintf(dbgfile, "\t%d\n", size);            /* size of block */
  679.       fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size));    /* entry point */
  680.       fprintf(dbgfile, "\t%d\n", nargs);        /* # arguments */
  681.       fprintf(dbgfile, "\t%d\n", ndyn);            /* # dynamic locals */
  682.       fprintf(dbgfile, "\t%d\n", nstat);        /* # static locals */
  683.       fprintf(dbgfile, "\t%d\n", fstat);        /* first static */
  684.       fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n",    /* name of procedure */
  685.          (int)strlen(name), (long)(name-lsspace), name);
  686.       }
  687. #endif                    /* DeBugLinker */
  688.  
  689.    outword(T_Proc);
  690.    outword(size);
  691.    outword(pc + size - 2*WordSize); /* Have to allow for the two words
  692.                      that we've already output. */
  693.    outword(nargs);
  694.    outword(ndyn);
  695.    outword(nstat);
  696.    outword(fstat);
  697.    outword(strlen(name));
  698.    outword(name - lsspace);
  699.  
  700.    /*
  701.     * Output string descriptors for argument names by looping through
  702.     *  all locals, and picking out those with F_Argument set.
  703.     */
  704.    for (i = 0; i <= nlocal; i++) {
  705.       if (lltable[i].l_flag & F_Argument) {
  706.          p = lltable[i].l_name;
  707.  
  708. #ifdef DeBugLinker
  709.          if (Dflag)
  710.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p),
  711.                (long)(p-lsspace), p);
  712. #endif                    /* DeBugLinker */
  713.  
  714.          outword(strlen(p));
  715.          outword(p - lsspace);
  716.          }
  717.       }
  718.  
  719.    /*
  720.     * Output string descriptors for local variable names.
  721.     */
  722.    for (i = 0; i <= nlocal; i++) {
  723.       if (lltable[i].l_flag & F_Dynamic) {
  724.          p = lltable[i].l_name;
  725.  
  726. #ifdef DeBugLinker
  727.          if (Dflag)
  728.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p),
  729.                (long)(p-lsspace), p);
  730. #endif                    /* DeBugLinker */
  731.  
  732.          outword(strlen(p));
  733.          outword(p - lsspace);
  734.          }
  735.       }
  736.  
  737.    /*
  738.     * Output string descriptors for local variable names.
  739.     */
  740.    for (i = 0; i <= nlocal; i++) {
  741.       if (lltable[i].l_flag & F_Static) {
  742.          p = lltable[i].l_name;
  743.  
  744. #ifdef DeBugLinker
  745.          if (Dflag)
  746.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p),
  747.                (long)(p-lsspace), p);
  748. #endif                    /* DeBugLinker */
  749.  
  750.          outword(strlen(p));
  751.          outword(p - lsspace);
  752.          }
  753.       }
  754.    }
  755.  
  756. /*
  757.  * gentables - generate interpreter code for global, static,
  758.  *  identifier, and record tables, and built-in procedure blocks.
  759.  */
  760.  
  761. novalue gentables()
  762.    {
  763.    register int i;
  764.    register char *s;
  765.    register struct gentry *gp;
  766.    struct fentry *fp;
  767.    struct rentry *rp;
  768.    struct header hdr;
  769.  
  770. #if MVS
  771.    FILE *toutfile;        /* temporary file for icode output */
  772. #endif                    /* MVS */
  773.  
  774.    lemiteven();
  775.  
  776.    /*
  777.     * Output record constructor procedure blocks.
  778.     */
  779.    hdr.records = pc;
  780.  
  781. #ifdef DeBugLinker
  782.    if (Dflag)
  783.       fprintf(dbgfile, "%ld:\t%d\t\t\t\t# record blocks\n",(long)pc, nrecords);
  784. #endif                    /* DeBugLinker */
  785.  
  786.    outword(nrecords);
  787.    for (gp = lgtable; gp < lgfree; gp++) {
  788.       if (gp->g_flag & (F_Record & ~F_Global)) {
  789.          s = gp->g_name;
  790.          gp->g_pc = pc;
  791.  
  792. #ifdef DeBugLinker
  793.          if (Dflag) {
  794.             fprintf(dbgfile, "%ld:\n", pc);
  795.             fprintf(dbgfile, "\t%d\n", T_Proc);
  796.             fprintf(dbgfile, "\t%d\n", RkBlkSize);
  797.             fprintf(dbgfile, "\t_mkrec\n");
  798.             fprintf(dbgfile, "\t%d\n", gp->g_nargs);
  799.             fprintf(dbgfile, "\t-2\n");
  800.             fprintf(dbgfile, "\t%d\n", gp->g_procid);
  801.             fprintf(dbgfile, "\t1\n");
  802.             fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(s),
  803.                (long)(s-lsspace), s);
  804.             }
  805.  
  806. #endif                    /* DeBugLinker */
  807.  
  808.          outword(T_Proc);        /* type code */
  809.          outword(RkBlkSize);        /* size of block */
  810.          outword(0);            /* entry point (filled in by interp)*/
  811.          outword(gp->g_nargs);        /* number of fields */
  812.          outword(-2);            /* record constructor indicator */
  813.          outword(gp->g_procid);        /* record id */
  814.          outword(1);            /* serial number */
  815.          outword(strlen(s));        /* name of record */
  816.          outword(s - lsspace);
  817.          }
  818.       }
  819.  
  820.    /*
  821.     * Output record/field table.
  822.     */
  823.    hdr.ftab = pc;
  824.  
  825. #ifdef DeBugLinker
  826.    if (Dflag)
  827.       fprintf(dbgfile, "%ld:\t\t\t\t\t# record/field table\n", (long)pc);
  828. #endif                    /* DeBugLinker */
  829.  
  830.    for (fp = lftable; fp < lffree; fp++) {
  831.  
  832. #ifdef DeBugLinker
  833.       if (Dflag)
  834.          fprintf(dbgfile, "%ld:\n", (long)pc);
  835. #endif                    /* DeBugLinker */
  836.  
  837.       rp = fp->f_rlist;
  838.       for (i = 1; i <= nrecords; i++) {
  839.          if (rp != NULL && rp->r_recid == i) {
  840.  
  841. #ifdef DeBugLinker
  842.             if (Dflag)
  843.         fprintf(dbgfile, "\t%d\n", rp->r_fnum);
  844. #endif                    /* DeBugLinker */
  845.  
  846.             outword(rp->r_fnum);
  847.             rp = rp->r_link;
  848.             }
  849.          else {
  850.  
  851. #ifdef DeBugLinker
  852.             if (Dflag)
  853.         fprintf(dbgfile, "\t-1\n");
  854. #endif                    /* DeBugLinker */
  855.  
  856.             outword(-1);
  857.             }
  858.  
  859. #ifdef DeBugLinker
  860.          if (Dflag && (i == nrecords || (i & 03) == 0))
  861.             putc('\n', dbgfile);
  862. #endif                    /* DeBugLinker */
  863.  
  864.          }
  865.       }
  866.  
  867.    /*
  868.     * Output descriptors for field names.
  869.     */
  870.  
  871.     hdr.fnames = pc;
  872.     for (fp = lftable; fp < lffree; fp++) {
  873.        s = fp->f_name;
  874.  
  875. #ifdef DeBugLinker
  876.        if (Dflag)
  877.           fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n",
  878.                (long)pc, (int)strlen(s), (long)(s-lsspace), s);
  879. #endif                    /* DeBugLinker */
  880.  
  881.        outword(strlen(s));      /* name of field */
  882.        outword(s - lsspace);
  883.      }
  884.  
  885.  
  886.    /*
  887.     * Output global variable descriptors.
  888.     */
  889.    hdr.globals = pc;
  890.    for (gp = lgtable; gp < lgfree; gp++) {
  891.       if (gp->g_flag & (F_Builtin & ~F_Global)) {    /* function */
  892.  
  893. #ifdef DeBugLinker
  894.          if (Dflag)
  895.             fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n",
  896.         (long)pc, (long)D_Proc, -gp->g_procid, gp->g_name);
  897. #endif                    /* DeBugLinker */
  898.  
  899.          outword(D_Proc);
  900.          outword(-gp->g_procid);
  901.          }
  902.       else if (gp->g_flag & (F_Proc & ~F_Global)) {    /* Icon procedure */
  903.  
  904. #ifdef DeBugLinker
  905.          if (Dflag)
  906.             fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
  907.         (long)pc,(long)D_Proc, (long)gp->g_pc, gp->g_name);
  908. #endif                    /* DeBugLinker */
  909.  
  910.          outword(D_Proc);
  911.          outword(gp->g_pc);
  912.          }
  913.       else if (gp->g_flag & (F_Record & ~F_Global)) {    /* record constructor */
  914.  
  915. #ifdef DeBugLinker
  916.          if (Dflag)
  917.             fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
  918.         (long)pc, (long)D_Proc, (long)gp->g_pc, gp->g_name);
  919. #endif                    /* DeBugLinker */
  920.  
  921.          outword(D_Proc);
  922.          outword(gp->g_pc);
  923.          }
  924.       else {    /* global variable */
  925.  
  926. #ifdef DeBugLinker
  927.          if (Dflag)
  928.             fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc,
  929.                (long)D_Null, gp->g_name);
  930. #endif                    /* DeBugLinker */
  931.  
  932.          outword(D_Null);
  933.          outword(0);
  934.          }
  935.       }
  936.  
  937.    /*
  938.     * Output descriptors for global variable names.
  939.     */
  940.    hdr.gnames = pc;
  941.    for (gp = lgtable; gp < lgfree; gp++) {
  942.  
  943. #ifdef DeBugLinker
  944.       if (Dflag)
  945.          fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n",
  946.             (long)pc, (int)strlen(gp->g_name), (long)(gp->g_name-lsspace),
  947.                gp->g_name);
  948. #endif                    /* DeBugLinker */
  949.  
  950.       outword(strlen(gp->g_name));
  951.       outword(gp->g_name - lsspace);
  952.       }
  953.  
  954.    /*
  955.     * Output a null descriptor for each static variable.
  956.     */
  957.    hdr.statics = pc;
  958.    for (i = lstatics; i > 0; i--) {
  959.  
  960. #ifdef DeBugLinker
  961.       if (Dflag)
  962.          fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc);
  963. #endif                    /* DeBugLinker */
  964.  
  965.       outword(D_Null);
  966.       outword(0);
  967.       }
  968.    flushcode();
  969.  
  970.    /*
  971.     * Output the string constant table and the two tables associating icode
  972.     *  locations with source program locations.  Note that the calls to write
  973.     *  really do all the work.
  974.     */
  975.  
  976. #ifdef DeBugLinker
  977.    if (Dflag) {
  978.       for (s = lsspace; s < lsfree; ) {
  979.          fprintf(dbgfile, "%ld:\t%03o", (long)pc, *s++);
  980.          for (i = 7; i > 0; i--) {
  981.             if (s >= lsfree)
  982.         break;
  983.             fprintf(dbgfile, " %03o", *s++);
  984.             }
  985.          putc('\n', dbgfile);
  986.          }
  987.       }
  988. #endif                    /* DeBugLinker */
  989.  
  990.    hdr.filenms = pc;
  991.    pc += (char *)fnmfree - (char *)fnmtbl;
  992.    hdr.linenums = pc;
  993.    pc += (char *)lnfree - (char *)lntable;
  994.    hdr.strcons = pc;
  995.    pc += lsfree - lsspace;
  996.  
  997.    if (longwrite((char *)fnmtbl, (long)((char *)fnmfree - (char *)fnmtbl),
  998.       outfile) < 0)
  999.          quit("cannot write icode file");
  1000.    if (longwrite((char *)lntable, (long)((char *)lnfree - (char *)lntable),
  1001.       outfile) < 0)
  1002.          quit("cannot write icode file");
  1003.    if (longwrite(lsspace, (long)(lsfree - lsspace), outfile) < 0)
  1004.          quit("cannot write icode file");
  1005.  
  1006.    /*
  1007.     * Output icode file header.
  1008.     */
  1009.    hdr.hsize = pc;
  1010.    strcpy((char *)hdr.config,IVersion);
  1011.    hdr.trace = trace;
  1012.  
  1013.  
  1014. #ifdef DeBugLinker
  1015.    if (Dflag) {
  1016.       fprintf(dbgfile, "size:     %ld\n", (long)hdr.hsize);
  1017.       fprintf(dbgfile, "trace:     %ld\n", (long)hdr.trace);
  1018.       fprintf(dbgfile, "records: %ld\n", (long)hdr.records);
  1019.       fprintf(dbgfile, "ftab:     %ld\n", (long)hdr.ftab);
  1020.       fprintf(dbgfile, "fnames:  %ld\n", (long)hdr.fnames);
  1021.       fprintf(dbgfile, "globals: %ld\n", (long)hdr.globals);
  1022.       fprintf(dbgfile, "gnames:  %ld\n", (long)hdr.gnames);
  1023.       fprintf(dbgfile, "statics: %ld\n", (long)hdr.statics);
  1024.       fprintf(dbgfile, "strcons:   %ld\n", (long)hdr.strcons);
  1025.       fprintf(dbgfile, "filenms:   %ld\n", (long)hdr.filenms);
  1026.       fprintf(dbgfile, "linenums:   %ld\n", (long)hdr.linenums);
  1027.       fprintf(dbgfile, "config:   %s\n", hdr.config);
  1028.       }
  1029. #endif                    /* DeBugLinker */
  1030.  
  1031. #ifdef Header
  1032.    fseek(outfile, (long)MaxHeader, 0);
  1033. #else                                   /* Header */
  1034.  
  1035. #if MVS
  1036. /*
  1037.  * This kind of backpatching cannot work on a PDS member, and that's
  1038.  *  probably where the code is going.  So the code goes out first to
  1039.  *  a temporary file, and then copied to the real icode file after
  1040.  *  the header is written.
  1041.  */
  1042.    fseek(outfile, sizeof(hdr), SEEK_SET);
  1043.    toutfile = outfile;
  1044.    outfile = fopen(routname, WriteBinary);
  1045.    if (outfile == NULL)
  1046.       quitf("cannot create %s",routname);
  1047. #else
  1048.    fseek(outfile, 0L, 0);
  1049. #endif                                  /* MVS */
  1050. #endif                                  /* Header */
  1051.  
  1052.    if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0)
  1053.       quit("cannot write icode file");
  1054.  
  1055. #if MVS
  1056.    {
  1057.       char *allelse = malloc(hdr.hsize);
  1058.       if (hdr.hsize != fread(allelse, 1, hdr.hsize, toutfile) ||
  1059.           longwrite(allelse, hdr.hsize, outfile) < 0)
  1060.             quit("cannot write icode file");
  1061.       free(allelse);
  1062.       fclose(toutfile);
  1063.    }
  1064. #endif                    /* MVS */
  1065.    }
  1066.  
  1067. /*
  1068.  * intout(i) outputs i as an int that is used by the runtime system
  1069.  *  IntBits/ByteBits bytes must be moved from &word[0] to &codep[0].
  1070.  */
  1071. static novalue intout(oint)
  1072. int oint;
  1073.    {
  1074.    int i;
  1075.    union {
  1076.       int i;
  1077.       char c[IntBits/ByteBits]; 
  1078.       } u;
  1079.  
  1080.    CodeCheck(1);
  1081.    u.i = oint;
  1082.  
  1083.    for (i = 0; i < IntBits/ByteBits; i++)
  1084.       codep[i] = u.c[i];
  1085.  
  1086.    codep += IntBits/ByteBits;
  1087.    pc += IntBits/ByteBits;
  1088.    }
  1089.  
  1090. /*
  1091.  * wordout(i) outputs i as a word that is used by the runtime system
  1092.  *  WordSize bytes must be moved from &oword[0] to &codep[0].
  1093.  */
  1094. static novalue wordout(oword)
  1095. word oword;
  1096.    {
  1097.    int i;
  1098.    union {
  1099.     word i;
  1100.     char c[WordSize];
  1101.     } u;
  1102.  
  1103.    CodeCheck(1);
  1104.    u.i = oword;
  1105.  
  1106.    for (i = 0; i < WordSize; i++)
  1107.       codep[i] = u.c[i];
  1108.  
  1109.    codep += WordSize;
  1110.    pc += WordSize;
  1111.    }
  1112.  
  1113. /*
  1114.  * outblock(a,i) output i bytes starting at address a.
  1115.  */
  1116. static novalue outblock(addr,count)
  1117. char *addr;
  1118. int count;
  1119.    {
  1120.    CodeCheck(count);
  1121.    pc += count;
  1122.    while (count--)
  1123.       *codep++ = *addr++;
  1124.    }
  1125.  
  1126. #ifdef DeBugLinker
  1127. /*
  1128.  * dumpblock(a,i) dump contents of i bytes at address a, used only
  1129.  *  in conjunction with -L.
  1130.  */
  1131. static novalue dumpblock(addr, count)
  1132. char *addr;
  1133. int count;
  1134.    {
  1135.    int i;
  1136.    for (i = 0; i < count; i++) {
  1137.       if ((i & 7) == 0)
  1138.          fprintf(dbgfile,"\n\t");
  1139.       fprintf(dbgfile," %03o",(0377 & (unsigned)addr[i]));
  1140.       }
  1141.    putc('\n',dbgfile);
  1142.    }
  1143. #endif                    /* DeBugLinker */
  1144.  
  1145. /*
  1146.  * flushcode - write buffered code to the output file.
  1147.  */
  1148. static novalue flushcode()
  1149.    {
  1150.    if (codep > codeb)
  1151.       if (longwrite(codeb, DiffPtrs(codep,codeb), outfile) < 0)
  1152.          quit("cannot write icode file");
  1153.    codep = codeb;
  1154.    }
  1155.  
  1156. /*
  1157.  * clearlab - clear label table to all zeroes.
  1158.  */
  1159. static novalue clearlab()
  1160.    {
  1161.    register int i;
  1162.  
  1163.    for (i = 0; i < maxlabels; i++)
  1164.       labels[i] = 0;
  1165.    }
  1166.  
  1167. /*
  1168.  * backpatch - fill in all forward references to lab.
  1169.  */
  1170. static novalue backpatch(lab)
  1171. int lab;
  1172.    {
  1173.    word p, r;
  1174.    char *q;
  1175.    char *cp, *cr;
  1176.    register int j;
  1177.  
  1178.    if (lab >= maxlabels)
  1179.       quit("out of label space");
  1180.  
  1181.    p = labels[lab];
  1182.    if (p > 0)
  1183.       quit("multiply defined label in ucode");
  1184.    while (p < 0) {        /* follow reference chain */
  1185.  
  1186. #ifdef CRAY
  1187.       r = (pc - (WordSize - p))/8;    /* compute relative offset */
  1188. #else                    /* CRAY */
  1189.       r = pc - (WordSize - p);    /* compute relative offset */
  1190. #endif                    /* CRAY */
  1191.       q = codep - (pc + p);    /* point to word with address */
  1192.       cp = (char *) &p;        /* address of integer p       */
  1193.       cr = (char *) &r;        /* address of integer r       */
  1194.       for (j = 0; j < WordSize; j++) {      /* move bytes from word pointed to */
  1195.          *cp++ = *q;              /* by q to p, and move bytes from */
  1196.          *q++ = *cr++;              /* r to word pointed to by q */
  1197.          }            /* moves integers at arbitrary addresses */
  1198.       }
  1199.    labels[lab] = pc;
  1200.    }
  1201.  
  1202. #ifdef DeBugLinker
  1203. novalue idump(s)        /* dump code region */
  1204.    char *s;
  1205.    {
  1206.    int *c;
  1207.  
  1208.    fprintf(stderr,"\ndump of code region %s:\n",s);
  1209.    for (c = (int *)codeb; c < (int *)codep; c++)
  1210.        fprintf(stderr,"%ld: %d\n",(long)c, (int)*c);
  1211.    fflush(stderr);
  1212.    }
  1213. #endif                    /* DeBugLinker */
  1214.