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