home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v92.tgz / v92.tar / v92 / src / iconc / codegen.c < prev    next >
C/C++ Source or Header  |  1996-03-22  |  58KB  |  1,893 lines
  1. /*
  2.  * codegen.c - routines to write out C code.
  3.  */
  4. #include <ctype.h>
  5. #include "::h:gsupport.h"
  6. #include "ctrans.h"
  7. #include "cglobals.h"
  8. #include "csym.h"
  9. #include "ccode.h"
  10. #include "ctree.h"
  11. #include "cproto.h"
  12.  
  13. /*
  14.  * MinOne - arrays sizes must be at least 1.
  15.  */
  16. #define MinOne(n) ((n) > 0 ? (n) : 1)
  17.  
  18. /*
  19.  * ChkSeqNum - make sure a label has been given a sequence number.
  20.  */
  21. #define ChkSeqNum(x) if ((x)->SeqNum == 0) (x)->SeqNum = ++lbl_seq_num
  22.  
  23. /*
  24.  * ChkBound - for a given procedure, signals that transfer control to a
  25.  *  bounding label all use the same signal number.
  26.  */
  27. #define ChkBound(x) (((x)->LabFlg & Bounding) ? bound_sig : (x))
  28.  
  29. /*
  30.  * When a switch statement for signal handling is optimized, there
  31.  *  are three possible forms of default clauses.
  32.  */
  33. #define DfltNone    0   /* no default clause */
  34. #define DfltBrk     1   /* default is just a break */
  35. #define DfltRetSig  2   /* default is to return the signal from the call */
  36.  
  37. /*
  38.  * Prototypes for static functions.
  39.  */
  40. hidden int     arg_nms   Params((struct lentry *lptr, int prt));
  41. hidden novalue bi_proc   Params((char *name, struct implement *ip));
  42. hidden novalue chkforgn  Params((int outer));
  43. hidden int     dyn_nms   Params((struct lentry *lptr, int prt));
  44. hidden novalue fldnames  Params((struct fldname *fields));
  45. hidden novalue fnc_blk   Params((struct gentry *gptr));
  46. hidden novalue frame     Params((int outer));
  47. hidden novalue good_clsg Params((struct code *call, int outer));
  48. hidden novalue initpblk  Params((FILE *f, int c, char *prefix, char *name,
  49.                            int nquals, int nparam, int ndynam, int nstatic,
  50.                            int frststat));
  51. hidden char  *is_builtin Params((struct gentry *gptr));
  52. hidden novalue proc_blk  Params((struct gentry *gptr, int init_glbl));
  53. hidden novalue prt_ary   Params((struct code *cd, int outer));
  54. hidden novalue prt_cond  Params((struct code *cond));
  55. hidden novalue prt_cont  Params((struct c_fnc *cont));
  56. hidden novalue prt_var   Params((struct lentry *var, int outer));
  57. hidden novalue prtcall   Params((struct code *call, int outer));
  58. hidden novalue prtcode   Params((struct code *cd, int outer));
  59. hidden novalue prtpccall Params((int outer));
  60. hidden novalue rec_blk   Params((struct gentry *gptr, int init_glbl));
  61. hidden novalue smpl_clsg Params((struct code *call, int outer));
  62. hidden novalue stat_nms  Params((struct lentry *lptr, int prt));
  63. hidden novalue val_loc   Params((struct val_loc *rslt, int outer));
  64.  
  65. static int n_stat = -1;        /* number of static variables */
  66.  
  67. /*
  68.  * var_dcls - produce declarations necessary to implement variables
  69.  *  and to initialize globals and statics: procedure blocks, procedure
  70.  *  frames, record blocks, declarations for globals and statics, the
  71.  *  C main program.
  72.  */
  73. novalue var_dcls()
  74.    {
  75.    register int i;
  76.    register struct gentry *gptr;
  77.    struct gentry *gbl_main;
  78.    struct pentry *prc_main;
  79.    int n_glob = 0;
  80.    int flag;
  81.    int init_glbl;
  82.    int first;
  83.    char *pfx;
  84.  
  85.    /*
  86.     * Output initialized array of descriptors for globals.
  87.     */
  88.    fprintf(codefile, "\nstatic struct {word dword; union block *vword;}");
  89.    fprintf(codefile, " init_globals[NGlobals] = {\n");
  90.    prc_main = NULL;
  91.    for (i = 0; i < GHSize; i++)
  92.       for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) {
  93.          flag = gptr->flag & ~(F_Global | F_StrInv);
  94.          if (strcmp(gptr->name, "main") == 0 && (gptr->flag & F_Proc)) {
  95.             /*
  96.              * Remember main procedure.
  97.              */
  98.             gbl_main = gptr;
  99.             prc_main = gbl_main->val.proc;
  100.             }
  101.          if (flag == 0) {
  102.             /*
  103.              * Ordinary variable.
  104.              */
  105.             gptr->index = n_glob++;
  106.             fprintf(codefile, "   {D_Null},\n");
  107.             }
  108.          else {
  109.             /*
  110.              * Procedure, function, or record constructor. If the variable
  111.              *  has not been optimized away, initialize the it to reference
  112.              *  the procedure block.
  113.              */
  114.             if (flag & F_SmplInv) {
  115.                init_glbl = 0;
  116.                flag &= ~(uword)F_SmplInv;
  117.                }
  118.             else {
  119.                init_glbl = 1;
  120.                gptr->index = n_glob++;
  121.                fprintf(codefile, "   {D_Proc, ");
  122.                }
  123.             switch (flag) {
  124.                case F_Proc:
  125.                   proc_blk(gptr, init_glbl);
  126.                   break;
  127.                case F_Builtin:
  128.                   if (init_glbl)
  129.                      fnc_blk(gptr);
  130.                   break;
  131.                case F_Record:
  132.                   rec_blk(gptr, init_glbl);
  133.                }
  134.             }
  135.          }
  136.    if (n_glob == 0)
  137.       fprintf(codefile, "   {D_Null} /* place holder */\n");
  138.    fprintf(codefile, "   };\n");
  139.  
  140.    if (prc_main == NULL) {
  141.       nfatal(NULL, "main procedure missing", NULL);
  142.       return;
  143.       }
  144.  
  145.    /*
  146.     * Output array of descriptors initialized to the names of the
  147.     *  global variables that have not been optimized away.
  148.     */
  149.    if (n_glob == 0)
  150.       fprintf(codefile, "\nstruct sdescrip init_gnames[1];\n");
  151.    else {
  152.       fprintf(codefile, "\nstruct sdescrip init_gnames[NGlobals] = {\n");
  153.       for (i = 0; i < GHSize; i++)
  154.          for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink)
  155.             if (!(gptr->flag & F_SmplInv))
  156.                fprintf(codefile, "   {%d, \"%s\"},\n", strlen(gptr->name),
  157.                   gptr->name);
  158.          fprintf(codefile, "   };\n");
  159.       }
  160.  
  161.    /*
  162.     * Output array of pointers to builtin functions that correspond to
  163.     *  names of the global variables.
  164.     */
  165.    if (n_glob == 0)
  166.       fprintf(codefile, "\nstruct b_proc *builtins[1];\n");
  167.    else {
  168.       fprintf(codefile, "\nstruct b_proc *builtins[NGlobals] = {\n");
  169.       for (i = 0; i < GHSize; i++)
  170.          for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink)
  171.             if (!(gptr->flag & F_SmplInv)) {  
  172.                /*
  173.                 * Need to output *something* to stay in step with other arrays.
  174.                 */
  175.                if (pfx = is_builtin(gptr)) {
  176.                   fprintf(codefile, "   (struct b_proc *)&BF%c%c_%s,\n",
  177.                      pfx[0], pfx[1], gptr->name);
  178.                   }
  179.                else
  180.                   fprintf(codefile, "   0,\n");
  181.                }
  182.          fprintf(codefile, "   };\n");
  183.       }
  184.  
  185.    /*
  186.     * Output C main function that initializes the run-time system and
  187.     *  calls the main procedure.
  188.     */
  189.    fprintf(codefile, "\n");
  190.    fprintf(codefile, "int main(argc, argv)\n");
  191.    fprintf(codefile, "int argc;\n");
  192.    fprintf(codefile, "char **argv;\n");
  193.    fprintf(codefile, "   {\n");
  194.  
  195.    /*
  196.     *  If the main procedure requires a command-line argument list, we
  197.     *  need a place to construct the Icon argument list.
  198.     */
  199.    if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) {
  200.       fprintf(codefile, "   struct {\n");
  201.       fprintf(codefile, "      struct tend_desc *previous;\n");
  202.       fprintf(codefile, "      int num;\n");
  203.       fprintf(codefile, "      struct descrip arg_lst;\n");
  204.       fprintf(codefile, "      } t;\n");
  205.       fprintf(codefile, "\n");
  206.       }
  207.  
  208.    /*
  209.     * Produce code to initialize run-time system variables. Some depend
  210.     *  on compiler options.
  211.     */
  212.    fprintf(codefile, "   op_tbl = (struct b_proc *)init_op_tbl;\n");
  213.    fprintf(codefile, "   globals = (dptr)init_globals;\n");
  214.    fprintf(codefile, "   eglobals = &globals[%d];\n", n_glob);
  215.    fprintf(codefile, "   gnames = (dptr)init_gnames;\n");
  216.    fprintf(codefile, "   egnames = &gnames[%d];\n", n_glob);
  217.    fprintf(codefile, "   estatics = &statics[%d];\n", n_stat + 1);
  218.    if (debug_info)
  219.       fprintf(codefile, "   debug_info = 1;\n");
  220.    else
  221.       fprintf(codefile, "   debug_info = 0;\n");
  222.    if (line_info) {
  223.       fprintf(codefile, "   line_info = 1;\n");
  224.       fprintf(codefile, "   file_name = \"\";\n");
  225.       fprintf(codefile, "   line_num = 0;\n");
  226.       }
  227.    else
  228.       fprintf(codefile, "   line_info = 0;\n");
  229.    if (err_conv)
  230.       fprintf(codefile, "   err_conv = 1;\n");
  231.    else
  232.       fprintf(codefile, "   err_conv = 0;\n");
  233.    if (largeints)
  234.       fprintf(codefile, "   largeints = 1;\n");
  235.    else
  236.       fprintf(codefile, "   largeints = 0;\n");
  237.  
  238.    /*
  239.     * Produce code to call the routine to initialize the runtime system.
  240.     */
  241.    if (trace)
  242.       fprintf(codefile, "   init(*argv, &argc, argv, -1);\n");
  243.    else
  244.       fprintf(codefile, "   init(*argv, &argc, argv, 0);\n");
  245.    fprintf(codefile, "\n");
  246.  
  247.    /*
  248.     * If the main procedure requires an argument list (perhaps because
  249.     *  it uses standard, rather than tailored calling conventions),
  250.     *  set up the argument list.
  251.     */
  252.    if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) {
  253.       fprintf(codefile, "   t.arg_lst = nulldesc;\n");
  254.       fprintf(codefile, "   t.num = 1;\n");
  255.       fprintf(codefile, "   t.previous = NULL;\n");
  256.       fprintf(codefile, "   tend = (struct tend_desc *)&t;\n");
  257.       if (prc_main->nargs == 0)
  258.          fprintf(codefile,
  259.             "   /* main() takes no arguments: construct no list */\n"); 
  260.       else
  261.          fprintf(codefile, "   cmd_line(argc, argv, &t.arg_lst);\n");
  262.       fprintf(codefile, "\n");
  263.       }
  264.    else
  265.       fprintf(codefile, "   tend = NULL;\n");
  266.  
  267.    if (gbl_main->flag & F_SmplInv) {
  268.       /*
  269.        * procedure main only has a simplified implementation if it
  270.        *  takes either 0 or 1 argument.
  271.        */
  272.       first = 1;
  273.       if (prc_main->nargs == 0)
  274.          fprintf(codefile, "   P%s_main(", prc_main->prefix);
  275.       else {
  276.          fprintf(codefile, "   P%s_main(&t.arg_lst", prc_main->prefix);
  277.          first = 0;
  278.          }
  279.       if (prc_main->ret_flag & (DoesRet | DoesSusp)) {
  280.          if (!first)
  281.             fprintf(codefile, ", ");
  282.          fprintf(codefile, "&trashcan");
  283.          first = 0;
  284.          }
  285.       if (prc_main->ret_flag & DoesSusp)
  286.          fprintf(codefile, ", (continuation)NULL");
  287.       fprintf(codefile, ");\n");
  288.       }
  289.    else /* the main procedure uses standard calling conventions */
  290.       fprintf(codefile,
  291.          "   P%s_main(1, &t.arg_lst, &trashcan, (continuation)NULL);\n",
  292.          prc_main->prefix);
  293.    fprintf(codefile, "   \n");
  294.    fprintf(codefile, "   c_exit(NormalExit);\n");
  295.    fprintf(codefile, "   }\n");
  296.  
  297.    /*
  298.     * Output to header file definitions related to global and static
  299.     *  variables.
  300.     */
  301.    fprintf(inclfile, "\n");
  302.    if (n_glob == 0) {
  303.       fprintf(inclfile, "#define NGlobals 1\n");
  304.       fprintf(inclfile, "int n_globals = 0;\n");
  305.       }
  306.    else {
  307.       fprintf(inclfile, "#define NGlobals %d\n", n_glob);
  308.       fprintf(inclfile, "int n_globals = NGlobals;\n");
  309.       }
  310.    ++n_stat;
  311.    fprintf(inclfile, "\n");
  312.    fprintf(inclfile, "int n_statics = %d;\n", n_stat);
  313.    fprintf(inclfile, "struct descrip statics[%d]", MinOne(n_stat));
  314.    if (n_stat > 0)  {
  315.       fprintf(inclfile, " = {\n");
  316.       for (i = 0; i < n_stat; ++i)
  317.          fprintf(inclfile, "   {D_Null},\n");
  318.       fprintf(inclfile, "   };\n");
  319.       }
  320.    else
  321.       fprintf(inclfile, ";\n");
  322.    }
  323.  
  324. /*
  325.  * proc_blk - create procedure block and initialize global variable, also
  326.  *   compute offsets for local procedure variables.
  327.  */
  328. static novalue proc_blk(gptr, init_glbl)
  329. struct gentry *gptr;
  330. int init_glbl;
  331.    {
  332.    struct pentry *p;
  333.    register char *name;
  334.    int nquals;
  335.  
  336.    name = gptr->name;
  337.    p = gptr->val.proc;
  338.  
  339.    /*
  340.     * If we don't initialize a global variable for this procedure, we
  341.     *  need only compute offsets for variables.
  342.     */
  343.    if (init_glbl) {
  344.       fprintf(codefile, "(union block *)&BP%s_%s},\n", p->prefix, name);
  345.       nquals = 1 + Abs(p->nargs) + p->ndynam + p->nstatic;
  346.       fprintf(inclfile, "\n");
  347.       fprintf(inclfile, "hidden int P%s_%s Params((int r_nargs, dptr r_args,",
  348.          p->prefix, name);
  349.       fprintf(inclfile, "dptr r_rslt, continuation r_s_cont));\n");
  350.       initpblk(inclfile, 'P', p->prefix, name, nquals, p->nargs, p->ndynam,
  351.          p->nstatic, n_stat + 1);
  352.       fprintf(inclfile, "\n   {%d, \"%s\"},\n", strlen(name), name);
  353.       }
  354.    arg_nms(p->args, init_glbl);
  355.    p->tnd_loc = dyn_nms(p->dynams, init_glbl);
  356.    stat_nms(p->statics, init_glbl);
  357.    if (init_glbl)
  358.       fprintf(inclfile, "   }};\n");
  359.    }
  360.  
  361. /*
  362.  * arg_nms - compute offsets of arguments and, if needed, output the
  363.  *  initializer for a descriptor for the argument name.
  364.  */
  365. static int arg_nms(lptr, prt)
  366. struct lentry *lptr;
  367. int prt;
  368.    {
  369.    register int n;
  370.  
  371.    if (lptr == NULL)
  372.       return 0;
  373.    n = arg_nms(lptr->next, prt);
  374.    lptr->val.index = n;
  375.    if (prt)
  376.       fprintf(inclfile, "   {%d, \"%s\"},\n", strlen(lptr->name), lptr->name);
  377.    return n + 1;
  378.    }
  379.  
  380. /*
  381.  * dyn_nams - compute offsets of dynamic locals and, if needed, output the
  382.  *  initializer for a descriptor for the variable name.
  383.  */
  384. static int dyn_nms(lptr, prt)
  385. struct lentry *lptr;
  386. int prt;
  387.    {
  388.    register int n;
  389.  
  390.    if (lptr == NULL)
  391.       return 0;
  392.    n = dyn_nms(lptr->next, prt);
  393.    lptr->val.index = n;
  394.    if (prt)
  395.       fprintf(inclfile, "   {%d, \"%s\"},\n", strlen(lptr->name), lptr->name);
  396.    return n + 1;
  397.    }
  398.  
  399. /*
  400.  * stat_nams - compute offsets of static locals and, if needed, output the
  401.  *  initializer for a descriptor for the variable name.
  402.  */
  403. static novalue stat_nms(lptr, prt)
  404. struct lentry *lptr;
  405. int prt;
  406.    {
  407.    if (lptr == NULL)
  408.       return;
  409.    stat_nms(lptr->next, prt);
  410.    lptr->val.index = ++n_stat;
  411.    if (prt)
  412.       fprintf(inclfile, "   {%d, \"%s\"},\n", strlen(lptr->name), lptr->name);
  413.    }
  414.  
  415. /*
  416.  * is_builtin - check if a global names or hides a builtin, returning prefix.
  417.  *  If it hides one, we must also generate the prototype and block here.
  418.  */
  419. static char *is_builtin(gptr)
  420. struct gentry *gptr;
  421.    {
  422.    struct implement *iptr;
  423.  
  424.    if (!(gptr->flag & F_StrInv))    /* if not eligible for string invoc */
  425.       return 0;
  426.    if (gptr->flag & F_Builtin)        /* if global *is* a builtin */
  427.       return gptr->val.builtin->prefix;
  428.    iptr = db_ilkup(gptr->name, bhash);
  429.    if (iptr == NULL)            /* if no builtin by this name */
  430.       return NULL;
  431.    bi_proc(gptr->name, iptr);        /* output prototype and proc block */
  432.    return iptr->prefix;
  433.    }
  434.  
  435. /*
  436.  * fnc_blk - output vword of descriptor for a built-in function and its
  437.  *   procedure block.
  438.  */
  439. static novalue fnc_blk(gptr)
  440. struct gentry *gptr;
  441.    {
  442.    struct implement *iptr;
  443.    char *name, *pfx;
  444.    
  445.    name = gptr->name;
  446.    iptr = gptr->val.builtin;
  447.    pfx = iptr->prefix;
  448.    /*
  449.     * output prototype and procedure block to inclfile.
  450.     */
  451.    bi_proc(name, iptr);
  452.    /*
  453.     * vword of descriptor references the procedure block.
  454.     */
  455.    fprintf(codefile, "(union block *)&BF%c%c_%s}, \n", pfx[0], pfx[1], name);
  456.    }
  457.  
  458. /*
  459.  * bi_proc - output prototype and procedure block for builtin function.
  460.  */
  461. static novalue bi_proc(name, ip)
  462. char *name;
  463.    struct implement *ip;
  464.    {
  465.    int nargs;
  466.    char prefix[3];
  467.  
  468.    prefix[0] = ip->prefix[0];
  469.    prefix[1] = ip->prefix[1];
  470.    prefix[2] = '\0';
  471.    nargs = ip->nargs;
  472.    if (nargs > 0 && ip->arg_flgs[nargs - 1] & VarPrm)
  473.       nargs = -nargs;
  474.    fprintf(inclfile, "\n");
  475.    implproto(ip);
  476.    initpblk(inclfile, 'F', prefix, name, 1, nargs, -1, 0, 0);
  477.    fprintf(inclfile, "{%d, \"%s\"}}};\n", strlen(name), name);
  478.    }
  479.  
  480. /*
  481.  * rec_blk - if needed, output vword of descriptor for a record
  482.  *   constructor and output its procedure block.
  483.  */
  484. static novalue rec_blk(gptr, init_glbl)
  485. struct gentry *gptr;
  486. int init_glbl;
  487.    {
  488.    struct rentry *r;
  489.    register char *name;
  490.    int nfields;
  491.  
  492.    name = gptr->name;
  493.    r = gptr->val.rec;
  494.    nfields = r->nfields;
  495.  
  496.    /*
  497.     * If the variable is not optimized away, output vword of descriptor.
  498.     */
  499.    if (init_glbl)
  500.       fprintf(codefile, "(union block *)&BR%s_%s},\n", r->prefix, name);
  501.  
  502.    fprintf(inclfile, "\n");
  503.    /*
  504.     * Prototype for C function implementing constructor. If no optimizations
  505.     *   have been performed on the variable, the standard calling conventions
  506.     *   are used and we need a continuation parameter.
  507.     */
  508.    fprintf(inclfile,
  509.       "hidden int R%s_%s Params((int r_nargs, dptr r_args, dptr r_rslt",
  510.       r->prefix, name);
  511.    if (init_glbl)
  512.       fprintf(inclfile, ", continuation r_s_cont");
  513.    fprintf(inclfile, "));\n");
  514.  
  515.    /*
  516.     * Procedure block, including record name and field names.
  517.     */
  518.    initpblk(inclfile, 'R', r->prefix, name, nfields + 1, nfields, -2,
  519.       r->rec_num, 1);
  520.    fprintf(inclfile, "\n   {%d, \"%s\"},\n", strlen(name), name);
  521.    fldnames(r->fields);
  522.    fprintf(inclfile, "   }};\n");
  523.    }
  524.  
  525.  
  526. /*
  527.  * fldnames - output the initializer for a descriptor for the field name.
  528.  */
  529. static novalue fldnames(fields)
  530. struct fldname *fields;
  531.    {
  532.    register char *name;
  533.  
  534.    if (fields == NULL)
  535.       return;
  536.    fldnames(fields->next);
  537.    name = fields->name;
  538.    fprintf(inclfile, "   {%d, \"%s\"},\n", strlen(name), name);
  539.    }
  540.  
  541. /*
  542.  * implproto - print prototype for function implementing a run-time operation.
  543.  */
  544. novalue implproto(ip)
  545. struct implement *ip;
  546.    {
  547.    if (ip->iconc_flgs & ProtoPrint)
  548.       return;    /* only print prototype once */
  549.    fprintf(inclfile, "int %c%c%c_%s ", ip->oper_typ, ip->prefix[0],
  550.        ip->prefix[1], ip->name);
  551.    fprintf(inclfile, "Params((int r_nargs, dptr r_args, dptr r_rslt, ");
  552.    fprintf(inclfile,"continuation r_s_cont));\n");
  553.    ip->iconc_flgs |= ProtoPrint;
  554.    }
  555.  
  556. /*
  557.  * const_blks - output blocks for cset and real constants.
  558.  */
  559. novalue const_blks()
  560.    {
  561.    register int i;
  562.    register struct centry *cptr;
  563.  
  564.    fprintf(inclfile, "\n");
  565.    for (i = 0; i < CHSize; i++)
  566.       for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) {
  567.          switch (cptr->flag) {
  568.             case F_CsetLit:
  569.                nxt_pre(cptr->prefix, pre, PrfxSz);
  570.                cptr->prefix[PrfxSz] = '\0';
  571.                fprintf(inclfile, "struct b_cset BDC%s = ", cptr->prefix);
  572.                cset_init(inclfile, cptr->u.cset);
  573.                break;
  574.             case F_RealLit:
  575.                nxt_pre(cptr->prefix, pre, PrfxSz);
  576.                cptr->prefix[PrfxSz] = '\0';
  577.                fprintf(inclfile, "struct b_real BDR%s = {T_Real, %s};\n",
  578.                    cptr->prefix, cptr->image);
  579.                break;
  580.             }
  581.          }
  582.    }
  583.  
  584. /*
  585.  * reccnstr - output record constructors.
  586.  */
  587. novalue recconstr(r)
  588. struct rentry *r;
  589.    {
  590.    register char *name;
  591.    int optim;
  592.    int nfields;
  593.  
  594.    if (r == NULL)
  595.       return;
  596.    recconstr(r->next);
  597.  
  598.    name = r->name;
  599.    nfields = r->nfields;
  600.  
  601.    /*
  602.     * Does this record constructor use optimized calling conventions?
  603.     */
  604.    optim = glookup(name)->flag & F_SmplInv;
  605.  
  606.    fprintf(codefile, "\n");
  607.    fprintf(codefile, "static int R%s_%s(r_nargs, r_args, r_rslt", r->prefix,
  608.       name);
  609.    if (!optim)
  610.       fprintf(codefile, ", r_s_cont");  /* continuation is passed */
  611.    fprintf(codefile, ")\n");
  612.    fprintf(codefile, "int r_nargs;\n");
  613.    fprintf(codefile, "dptr r_args;\n");
  614.    fprintf(codefile, "dptr r_rslt;\n");
  615.    if (!optim)
  616.       fprintf(codefile, "continuation r_s_cont;\n");
  617.    fprintf(codefile, "   {\n");
  618.    fprintf(codefile, "   register int i;\n");
  619.    fprintf(codefile, "   register struct b_record *rp;\n");
  620.    fprintf(codefile, "\n");
  621.    fprintf(codefile, "   rp = alcrecd(%d, (union block *)&BR%s_%s);\n",
  622.       nfields, r->prefix, name);
  623.    fprintf(codefile, "   if (rp == NULL) {\n");
  624.    fprintf(codefile, "      err_msg(307, NULL);\n");
  625.    if (err_conv)
  626.       fprintf(codefile, "      return A_Resume;\n");
  627.    fprintf(codefile, "      }\n");
  628.    fprintf(codefile, "   for (i = %d; i >= 0; i--)\n", nfields - 1);
  629.    fprintf(codefile, "      if (i < r_nargs)\n");
  630.    fprintf(codefile, "         deref(&r_args[i], &rp->fields[i]);\n");
  631.    fprintf(codefile, "      else\n");
  632.    fprintf(codefile, "         rp->fields[i] = nulldesc;\n");
  633.    fprintf(codefile, "   r_rslt->vword.bptr = (union block *)rp;\n");
  634.    fprintf(codefile, "   r_rslt->dword = D_Record;\n");
  635.    fprintf(codefile, "   return A_Continue;\n");
  636.    fprintf(codefile, "   }\n");
  637.    }
  638.  
  639. /*
  640.  * outerfnc - output code for the outer function implementing a procedure.
  641.  */
  642. novalue outerfnc(fnc)
  643. struct c_fnc *fnc;
  644.    {
  645.    char *prefix;
  646.    char *name;
  647.    char *cnt_var;
  648.    char *sep;
  649.    int ntend;
  650.    int first_arg;
  651.    int nparms;
  652.    int optim; /* optimized interface: no arg list adjustment */
  653.    int ret_flag;
  654.  
  655.    prefix = cur_proc->prefix;
  656.    name = cur_proc->name;
  657.    ntend = cur_proc->tnd_loc + num_tmp;
  658.    ChkPrefix(fnc->prefix);
  659.    optim = glookup(name)->flag & F_SmplInv;
  660.    nparms = Abs(cur_proc->nargs);
  661.    ret_flag = cur_proc->ret_flag;
  662.  
  663.    fprintf(codefile, "\n");
  664.    if (optim) {
  665.       /*
  666.        * Arg list adjustment and dereferencing are done at call site.
  667.        *  Use simplified interface. Output both function header and
  668.        *  prototype.
  669.        */
  670.       sep = "";
  671.       fprintf(inclfile, "hidden int P%s_%s Params((", prefix, name);
  672.       fprintf(codefile, "static int P%s_%s(", prefix, name);
  673.       if (nparms != 0) {
  674.          fprintf(inclfile, "dptr r_args");
  675.          fprintf(codefile, "r_args");
  676.          sep = ", ";
  677.          }
  678.       if (ret_flag & (DoesRet | DoesSusp)) {
  679.          fprintf(inclfile, "%sdptr r_rslt", sep);
  680.          fprintf(codefile, "%sr_rslt", sep);
  681.          sep = ", ";
  682.          }
  683.       if (ret_flag & DoesSusp) {
  684.          fprintf(inclfile, "%scontinuation r_s_cont", sep);
  685.          fprintf(codefile, "%sr_s_cont", sep);
  686.          sep = ", ";
  687.          }
  688.       if (*sep == '\0')
  689.          fprintf(inclfile, "noargs");
  690.       fprintf(inclfile, "));\n");
  691.       fprintf(codefile, ")\n");
  692.       if (nparms != 0)
  693.          fprintf(codefile, "dptr r_args;\n");
  694.       if (ret_flag & (DoesRet | DoesSusp))
  695.          fprintf(codefile, "dptr r_rslt;\n");
  696.       if (ret_flag & DoesSusp)
  697.          fprintf(codefile, "continuation r_s_cont;\n");
  698.       }
  699.    else {
  700.       /*
  701.        * General invocation interface. Output function header; prototype has
  702.        *  already been produced.
  703.        */
  704.       fprintf(codefile,
  705.          "static int P%s_%s(r_nargs, r_args, r_rslt, r_s_cont)\n", prefix,
  706.          name);
  707.       fprintf(codefile, "int r_nargs;\n");
  708.       fprintf(codefile, "dptr r_args;\n");
  709.       fprintf(codefile, "dptr r_rslt;\n");
  710.       fprintf(codefile, "continuation r_s_cont;\n");
  711.       }
  712.  
  713.    fprintf(codefile, "{\n");
  714.    fprintf(codefile, "   struct PF%s_%s r_frame;\n", prefix, name);
  715.    fprintf(codefile, "   register int r_signal;\n");
  716.    fprintf(codefile, "   int i;\n");
  717.    if (Type(Tree1(cur_proc->tree)) != N_Empty)
  718.       fprintf(codefile, "   static int first_time = 1;");
  719.    fprintf(codefile, "\n");
  720.    fprintf(codefile, "   r_frame.old_pfp = pfp;\n");
  721.    fprintf(codefile, "   pfp = (struct p_frame *)&r_frame;\n");
  722.    fprintf(codefile, "   r_frame.old_argp = argp;\n");
  723.    if (!optim || ret_flag & (DoesRet | DoesSusp))
  724.       fprintf(codefile, "   r_frame.rslt = r_rslt;\n");
  725.    else
  726.       fprintf(codefile, "   r_frame.rslt = NULL;\n");
  727.    if (!optim || ret_flag & DoesSusp)
  728.       fprintf(codefile, "   r_frame.succ_cont = r_s_cont;\n");
  729.    else
  730.       fprintf(codefile, "   r_frame.succ_cont = NULL;\n");
  731.    fprintf(codefile, "\n");
  732.    fprintf(codefile, "   for (i = 0; i < %d; ++i)\n", ntend);
  733.    fprintf(codefile, "      r_frame.tend.d[i] = nulldesc;\n");
  734.    if (optim) {
  735.       /*
  736.        * Dereferencing and argument list adjustment is done at the call
  737.        *  site. There is not much to do here.
  738.        */
  739.       if (nparms == 0)
  740.          fprintf(codefile, "   argp = NULL;\n");
  741.       else
  742.          fprintf(codefile, "   argp = r_args;\n");
  743.       }
  744.    else {
  745.       /*
  746.        * Dereferencing and argument list adjustment must be done by
  747.        *  the procedure itself.
  748.        */
  749.       first_arg = ntend;
  750.       ntend += nparms;
  751.       if (cur_proc->nargs < 0) {
  752.          /*
  753.           * varargs - construct a list into the last argument.
  754.           */
  755.          nparms -= 1;
  756.          if (nparms == 0)
  757.             cnt_var = "r_nargs";
  758.          else {
  759.             fprintf(codefile, "   i = r_nargs - %d;\n", nparms);
  760.             cnt_var = "i";
  761.             }
  762.          fprintf(codefile,"   if (%s <= 0)\n", cnt_var);
  763.          fprintf(codefile,"       varargs(NULL, 0, &r_frame.tend.d[%d]);\n",
  764.             first_arg + nparms);
  765.          fprintf(codefile,"   else\n");
  766.          fprintf(codefile,
  767.             "       varargs(&r_args[%d], %s, &r_frame.tend.d[%d]);\n", nparms,
  768.             cnt_var, first_arg + nparms);
  769.          }
  770.       if (nparms > 0) {
  771.          /*
  772.           * Output code to dereference argument or supply default null
  773.           *  value.
  774.           */
  775.          fprintf(codefile, "   for (i = 0; i < %d; ++i)\n", nparms);
  776.          fprintf(codefile, "      if (i < r_nargs)\n");
  777.          fprintf(codefile,
  778.             "         deref(&r_args[i], &r_frame.tend.d[i + %d]);\n",
  779.             first_arg);
  780.          fprintf(codefile, "      else\n");
  781.          fprintf(codefile, "         r_frame.tend.d[i + %d] = nulldesc;\n",
  782.             first_arg);
  783.          }
  784.       fprintf(codefile, "   argp = &r_frame.tend.d[%d];\n", first_arg);
  785.       }
  786.    fprintf(codefile, "   r_frame.tend.num = %d;\n", ntend);
  787.    fprintf(codefile, "   r_frame.tend.previous = tend;\n");
  788.    fprintf(codefile, "   tend = (struct tend_desc *)&r_frame.tend;\n");
  789.    if (line_info) {
  790.       fprintf(codefile, "   r_frame.debug.old_line = line_num;\n");
  791.       fprintf(codefile, "   r_frame.debug.old_fname = file_name;\n");
  792.       }
  793.    if (debug_info) {
  794.       fprintf(codefile, "   r_frame.debug.proc = (struct b_proc *)&BP%s_%s;\n",
  795.          prefix, name);
  796.       fprintf(codefile, "   if (k_trace) ctrace();\n");
  797.       fprintf(codefile, "   ++k_level;\n\n");
  798.       }
  799.    fprintf(codefile, "\n");
  800.  
  801.    /*
  802.     * Output definition for procedure frame.
  803.     */
  804.    prt_frame(prefix, ntend, num_itmp, num_dtmp, num_sbuf, num_cbuf);
  805.  
  806.    /*
  807.     * Output code to implement procedure body.
  808.     */
  809.    prtcode(&(fnc->cd), 1);
  810.    fprintf(codefile, "   }\n");
  811.    }
  812.  
  813. /*
  814.  * prt_fnc - output C function that implements a continuation.
  815.  */
  816. novalue prt_fnc(fnc)
  817. struct c_fnc *fnc;
  818.    {
  819.    struct code *sig;
  820.    char *name;
  821.    char *prefix;
  822.  
  823.    if (fnc->flag & CF_SigOnly) {
  824.       /*
  825.        * This function only returns a signal. A shared function is used in
  826.        *  its place. Make sure that function has been printed.
  827.        */
  828.       sig = fnc->cd.next->SigRef->sig;
  829.       if (sig->cd_id != C_Resume) {
  830.          sig = ChkBound(sig);
  831.          if (!(sig->LabFlg & FncPrtd)) {
  832.             ChkSeqNum(sig);
  833.             fprintf(inclfile, "hidden int sig_%d Params((noargs));\n",
  834.                sig->SeqNum);
  835.    
  836.             fprintf(codefile, "\n");
  837.             fprintf(codefile, "static int sig_%d()\n", sig->SeqNum);
  838.             fprintf(codefile, "   {\n");
  839.             fprintf(codefile, "   return %d; /* %s */\n", sig->SeqNum,
  840.                sig->Desc);
  841.             fprintf(codefile, "   }\n");
  842.             sig->LabFlg |= FncPrtd;
  843.             }
  844.          }
  845.       }
  846.    else {
  847.       ChkPrefix(fnc->prefix);
  848.       prefix = fnc->prefix;
  849.       name = cur_proc->name;
  850.    
  851.       fprintf(inclfile, "hidden int P%s_%s Params((noargs));\n", prefix, name);
  852.    
  853.       fprintf(codefile, "\n");
  854.       fprintf(codefile, "static int P%s_%s()\n", prefix, name);
  855.       fprintf(codefile, "   {\n");
  856.       if (fnc->flag & CF_Coexpr)
  857.          fprintf(codefile, "#ifdef Coexpr\n");
  858.    
  859.       prefix = fnc->frm_prfx;
  860.    
  861.       fprintf(codefile, "   register int r_signal;\n");
  862.       fprintf(codefile, "   register struct PF%s_%s *r_pfp;\n", prefix, name);
  863.       fprintf(codefile, "\n");
  864.       fprintf(codefile, "   r_pfp  = (struct PF%s_%s *)pfp;\n", prefix, name);
  865.       prtcode(&(fnc->cd), 0);
  866.       if (fnc->flag & CF_Coexpr) {
  867.          fprintf(codefile, "#else\t\t\t\t\t/* Coexpr */\n");
  868.          fprintf(codefile, "   fatalerr(401, NULL);\n");
  869.          fprintf(codefile, "#endif\t\t\t\t\t/* Coexpr */\n");
  870.          }
  871.       fprintf(codefile, "   }\n");
  872.       }
  873.    }
  874.  
  875. /*
  876.  * prt_frame - output the definition for a procedure frame.
  877.  */
  878. novalue prt_frame(prefix, ntend, n_itmp, n_dtmp, n_sbuf, n_cbuf)
  879. char *prefix;
  880. int ntend;
  881. int n_itmp;
  882. int n_dtmp;
  883. int n_sbuf;
  884. int n_cbuf;
  885.    {
  886.    int i;
  887.  
  888.    /*
  889.     * Output standard part of procedure frame including tended
  890.     *  descriptors.
  891.      */
  892.    fprintf(inclfile, "\n");
  893.    fprintf(inclfile, "struct PF%s_%s {\n", prefix, cur_proc->name);
  894.    fprintf(inclfile, "   struct p_frame *old_pfp;\n");
  895.    fprintf(inclfile, "   dptr old_argp;\n");
  896.    fprintf(inclfile, "   dptr rslt;\n");
  897.    fprintf(inclfile, "   continuation succ_cont;\n");
  898.    fprintf(inclfile, "   struct {\n");
  899.    fprintf(inclfile, "      struct tend_desc *previous;\n");
  900.    fprintf(inclfile, "      int num;\n");
  901.    fprintf(inclfile, "      struct descrip d[%d];\n", MinOne(ntend));
  902.    fprintf(inclfile, "      } tend;\n");
  903.  
  904.    if (line_info) {       /* must be true if debug_info is true */
  905.       fprintf(inclfile, "   struct debug debug;\n");
  906.       }
  907.  
  908.    /*
  909.     * Output declarations for the integer, double, string buffer,
  910.     *  and cset buffer work areas of the frame.
  911.     */
  912.    for (i = 0; i < n_itmp; ++i)
  913.       fprintf(inclfile, "   word i%d;\n", i);
  914.    for (i = 0; i < n_dtmp; ++i)
  915.       fprintf(inclfile, "   double d%d;\n", i);
  916.    if (n_sbuf > 0)
  917.       fprintf(inclfile, "   char sbuf[%d][MaxCvtLen];", n_sbuf);
  918.    if (n_cbuf > 0)
  919.       fprintf(inclfile, "   struct b_cset cbuf[%d];", n_cbuf);
  920.    fprintf(inclfile, "   };\n");
  921.    }
  922.  
  923. /*
  924.  * prtcode - print a list of C code.
  925.  */
  926. static novalue prtcode(cd, outer)
  927. struct code *cd;
  928. int outer;
  929.    {
  930.    struct lentry *var;
  931.    struct centry *lit;
  932.    struct code *sig;
  933.    int n;
  934.  
  935.    for ( ; cd != NULL; cd = cd->next) {
  936.       switch (cd->cd_id) {
  937.          case C_Null:
  938.             break;
  939.  
  940.          case C_NamedVar:
  941.             /*
  942.              * Construct a reference to a named variable in a result
  943.              *  location.
  944.              */
  945.             var = cd->NamedVar;
  946.             fprintf(codefile, "   ");
  947.             val_loc(cd->Rslt, outer);
  948.             fprintf(codefile, ".dword = D_Var;\n");
  949.             fprintf(codefile, "   ");
  950.             val_loc(cd->Rslt, outer);
  951.             fprintf(codefile, ".vword.descptr = &");
  952.             prt_var(var, outer);
  953.             fprintf(codefile, ";\n");
  954.             break;
  955.  
  956.          case C_CallSig:
  957.             /*
  958.              * Call to C function that returns a signal along with signal
  959.              *   handling code.
  960.              */
  961.             if (opt_sgnl)
  962.                good_clsg(cd, outer);
  963.             else
  964.                smpl_clsg(cd, outer);
  965.             break;
  966.  
  967.          case C_RetSig:
  968.             /*
  969.              * Return a signal.
  970.              */
  971.             sig = cd->SigRef->sig;
  972.             if (sig->cd_id == C_Resume)
  973.                fprintf(codefile, "   return A_Resume;\n");
  974.             else {
  975.                sig = ChkBound(sig);
  976.                ChkSeqNum(sig);
  977.                fprintf(codefile, "   return %d; /* %s */\n", sig->SeqNum,
  978.                   sig->Desc);
  979.                }
  980.             break;
  981.  
  982.          case C_Goto:
  983.             /*
  984.              * goto label.
  985.              */
  986.             ChkSeqNum(cd->Lbl);
  987.             fprintf(codefile, "   goto L%d /* %s */;\n", cd->Lbl->SeqNum, 
  988.                cd->Lbl->Desc);
  989.             break;
  990.  
  991.          case C_Label:
  992.             /*
  993.              * numbered label.
  994.              */
  995.             if (cd->RefCnt > 0) {
  996.                ChkSeqNum(cd);
  997.                fprintf(codefile, "L%d: ; /* %s */\n", cd->SeqNum, cd->Desc);
  998.                }
  999.             break;
  1000.  
  1001.          case C_Lit:
  1002.             /*
  1003.              * Assign literal value to a result location.
  1004.              */
  1005.             lit = cd->Literal;
  1006.             fprintf(codefile, "   ");
  1007.             val_loc(cd->Rslt, outer);
  1008.             switch (lit->flag) {
  1009.                case F_CsetLit:
  1010.                   fprintf(codefile, ".dword = D_Cset;\n");
  1011.                   fprintf(codefile, "   ");
  1012.                   val_loc(cd->Rslt, outer);
  1013.                   fprintf(codefile, ".vword.bptr = (union block *)&BDC%s;\n",
  1014.                      lit->prefix);
  1015.                   break;
  1016.                case F_IntLit:
  1017.                   if (lit->u.intgr == -1) {
  1018.                      /*
  1019.                       * Large integer literal - output string and convert
  1020.                       *  to integer.
  1021.                       */
  1022.                      fprintf(codefile, ".vword.sptr = \"%s\";\n", lit->image);
  1023.                      fprintf(codefile, "   ");
  1024.                      val_loc(cd->Rslt, outer);
  1025.                      fprintf(codefile, ".dword = %d;\n", strlen(lit->image));
  1026.                      fprintf(codefile, "   cnv_int(&");
  1027.                      val_loc(cd->Rslt, outer);
  1028.                      fprintf(codefile, ", &");
  1029.                      val_loc(cd->Rslt, outer);
  1030.                      fprintf(codefile, ");\n");
  1031.                      }
  1032.                   else {
  1033.                      /*
  1034.                       * Ordinary integer literal.
  1035.                       */
  1036.                      fprintf(codefile, ".dword = D_Integer;\n");
  1037.                      fprintf(codefile, "   ");
  1038.                      val_loc(cd->Rslt, outer);
  1039.                      fprintf(codefile, ".vword.integr = %ld;\n", lit->u.intgr);
  1040.                      }
  1041.                   break;
  1042.                case F_RealLit:
  1043.                   fprintf(codefile, ".dword = D_Real;\n");
  1044.                   fprintf(codefile, "   ");
  1045.                   val_loc(cd->Rslt, outer);
  1046.                   fprintf(codefile, ".vword.bptr = (union block *)&BDR%s;\n",
  1047.                      lit->prefix);
  1048.                   break;
  1049.                case F_StrLit:
  1050.                   fprintf(codefile, ".vword.sptr = ");
  1051.                   if (lit->length ==  0) {
  1052.                      /*
  1053.                       * Placing an empty string at the end of the string region
  1054.                       *  allows some concatenation optimizations at run time.
  1055.                       */
  1056.                      fprintf(codefile, "strfree;\n");
  1057.                      n = 0;
  1058.                      }
  1059.                   else {
  1060.                      fprintf(codefile, "\"");
  1061.                      n = prt_i_str(codefile, lit->image, lit->length);
  1062.                      fprintf(codefile, "\";\n");
  1063.                      }
  1064.                   fprintf(codefile, "   ");
  1065.                   val_loc(cd->Rslt, outer);
  1066.                   fprintf(codefile, ".dword = %d;\n", n);
  1067.                   break;
  1068.                }
  1069.             break;
  1070.  
  1071.          case C_PFail:
  1072.             /*
  1073.              * Procedure failure - this code occurs once near the end of
  1074.              *  the procedure.
  1075.              */
  1076.             if (debug_info) {
  1077.                fprintf(codefile, "   --k_level;\n");
  1078.                fprintf(codefile, "   if (k_trace) failtrace();\n");
  1079.                }
  1080.             fprintf(codefile, "   tend = r_frame.tend.previous;\n");
  1081.             fprintf(codefile, "   pfp = r_frame.old_pfp;\n");
  1082.             fprintf(codefile, "   argp = r_frame.old_argp;\n");
  1083.             if (line_info) {
  1084.                fprintf(codefile, "   line_num = r_frame.debug.old_line;\n");
  1085.                fprintf(codefile, "   file_name = r_frame.debug.old_fname;\n");
  1086.                }
  1087.             fprintf(codefile, "   return A_Resume;\n");
  1088.             break;
  1089.  
  1090.          case C_PRet:
  1091.             /*
  1092.              * Procedure return - this code occurs once near the end of
  1093.              *  the procedure.
  1094.              */
  1095.             if (debug_info) {
  1096.                fprintf(codefile, "   --k_level;\n");
  1097.                fprintf(codefile, "   if (k_trace) rtrace();\n");
  1098.                }
  1099.             fprintf(codefile, "   tend = r_frame.tend.previous;\n");
  1100.             fprintf(codefile, "   pfp = r_frame.old_pfp;\n");
  1101.             fprintf(codefile, "   argp = r_frame.old_argp;\n");
  1102.             if (line_info) {
  1103.                fprintf(codefile, "   line_num = r_frame.debug.old_line;\n");
  1104.                fprintf(codefile, "   file_name = r_frame.debug.old_fname;\n");
  1105.                }
  1106.             fprintf(codefile, "   return A_Continue;\n");
  1107.             break;
  1108.  
  1109.          case C_PSusp:
  1110.             /*
  1111.              * Procedure suspend - call success continuation.
  1112.              */
  1113.             prtpccall(outer);
  1114.             break;
  1115.  
  1116.          case C_Break:
  1117.             fprintf(codefile, "   break;\n");
  1118.             break;
  1119.  
  1120.          case C_If:
  1121.             /*
  1122.              * C if statement.
  1123.              */
  1124.             fprintf(codefile, "   if (");
  1125.             prt_ary(cd->Cond, outer);
  1126.             fprintf(codefile, ")\n   ");
  1127.             prtcode(cd->ThenStmt, outer);
  1128.             break;
  1129.  
  1130.          case C_CdAry:
  1131.             /*
  1132.              * Array of code fragments.
  1133.              */
  1134.             fprintf(codefile, "   ");
  1135.             prt_ary(cd, outer);
  1136.             fprintf(codefile, "\n");
  1137.             break;
  1138.  
  1139.          case C_LBrack:
  1140.             fprintf(codefile, "   {\n");
  1141.             break;
  1142.  
  1143.          case C_RBrack:
  1144.             fprintf(codefile, "   }\n");
  1145.             break;
  1146.  
  1147.          case C_Create:
  1148.             /*
  1149.              * Code to create a co-expression and assign it to a result
  1150.              *  location.
  1151.              */
  1152.             fprintf(codefile, "   ");
  1153.             val_loc(cd->Rslt, outer);
  1154.             fprintf(codefile , ".vword.bptr = (union block *)create(");
  1155.             prt_cont(cd->Cont);
  1156.             fprintf(codefile,
  1157.                ", (struct b_proc *)&BP%s_%s, %d, sizeof(word) * %d);\n",
  1158.                cur_proc->prefix, cur_proc->name, cd->NTemps, cd->WrkSize);
  1159.             fprintf(codefile, "   ");
  1160.             val_loc(cd->Rslt, outer);
  1161.             fprintf(codefile, ".dword = D_Coexpr;\n");
  1162.             break;
  1163.  
  1164.          case C_SrcLoc:
  1165.             /*
  1166.              * Update file name and line number information.
  1167.              */
  1168.             if (cd->FileName != NULL) {
  1169.                fprintf(codefile, "   file_name = \"");
  1170.                prt_i_str(codefile, cd->FileName, strlen(cd->FileName));
  1171.                fprintf(codefile, "\";\n");
  1172.                }
  1173.             if (cd->LineNum != 0)
  1174.                fprintf(codefile, "   line_num = %d;\n", cd->LineNum);
  1175.             break;
  1176.          }
  1177.       }
  1178.    }
  1179.  
  1180. /*
  1181.  * prt_var - output C code to reference an Icon named variable.
  1182.  */
  1183. static novalue prt_var(var, outer)
  1184. struct lentry *var;
  1185. int outer;
  1186.    {
  1187.    switch (var->flag) {
  1188.       case F_Global:
  1189.          fprintf(codefile, "globals[%d]", var->val.global->index);
  1190.          break;
  1191.       case F_Static:
  1192.          fprintf(codefile, "statics[%d]", var->val.index);
  1193.          break;
  1194.       case F_Dynamic:
  1195.          frame(outer);
  1196.          fprintf(codefile, ".tend.d[%d]", var->val.index);
  1197.          break;
  1198.       case F_Argument:
  1199.          fprintf(codefile, "argp[%d]", var->val.index);
  1200.          }
  1201.  
  1202.    /*
  1203.     * Include an identifying comment.
  1204.     */
  1205.    fprintf(codefile, " /* %s */", var->name);
  1206.    }
  1207.  
  1208. /*
  1209.  * prt_ary - print an array of code fragments.
  1210.  */
  1211. static novalue prt_ary(cd, outer)
  1212. struct code *cd;
  1213. int outer;
  1214.    {
  1215.    int i;
  1216.  
  1217.    for (i = 0; cd->ElemTyp(i) != A_End; ++i)
  1218.       switch (cd->ElemTyp(i)) {
  1219.          case A_Str:
  1220.             /*
  1221.              * Simple C code in a string.
  1222.              */
  1223.             fprintf(codefile, "%s", cd->Str(i));
  1224.             break;
  1225.          case A_ValLoc:
  1226.             /*
  1227.              * Value location (usually variable of some sort).
  1228.              */
  1229.             val_loc(cd->ValLoc(i), outer);
  1230.             break;
  1231.          case A_Intgr:
  1232.             /*
  1233.              * Integer.
  1234.              */
  1235.             fprintf(codefile, "%d", cd->Intgr(i));
  1236.             break;
  1237.          case A_ProcCont:
  1238.             /*
  1239.              * Current procedure call's success continuation.
  1240.              */
  1241.             if (outer)
  1242.                fprintf(codefile, "r_s_cont");
  1243.             else
  1244.                fprintf(codefile, "r_pfp->succ_cont");
  1245.             break;
  1246.          case A_SBuf:
  1247.             /*
  1248.              * One of the string buffers.
  1249.              */
  1250.             frame(outer);
  1251.             fprintf(codefile, ".sbuf[%d]", cd->Intgr(i));
  1252.             break;
  1253.          case A_CBuf:
  1254.             /*
  1255.              * One of the cset buffers.
  1256.              */
  1257.             fprintf(codefile, "&(");
  1258.             frame(outer);
  1259.             fprintf(codefile, ".cbuf[%d])", cd->Intgr(i));
  1260.             break;
  1261.          case A_Ary:
  1262.             /*
  1263.              * A subarray of code fragments.
  1264.              */
  1265.             prt_ary(cd->Array(i), outer);
  1266.             break;
  1267.          }
  1268.    }
  1269.  
  1270. /*
  1271.  * frame - access to the procedure frame. Access directly from outer function,
  1272.  *   but access through r_pfp from a continuation.
  1273.  */
  1274. static novalue frame(outer)
  1275. int outer;
  1276.    {
  1277.    if (outer)
  1278.       fprintf(codefile, "r_frame");
  1279.    else
  1280.       fprintf(codefile, "(*r_pfp)");
  1281.    }
  1282.  
  1283. /*
  1284.  * prtpccall - print procedure continuation call.
  1285.  */
  1286. static novalue prtpccall(outer)
  1287. int outer;
  1288.    {
  1289.    int first_arg;
  1290.    int optim; /* optimized interface: no arg list adjustment */
  1291.  
  1292.    first_arg = cur_proc->tnd_loc + num_tmp;
  1293.    optim = glookup(cur_proc->name)->flag & F_SmplInv;
  1294.  
  1295.    /*
  1296.     * The only signal to be handled in this procedure is
  1297.     *  resumption, the rest must be passed on.
  1298.     */
  1299.    if (cur_proc->nargs != 0 && optim && !outer) {
  1300.       fprintf(codefile, "   {\n");
  1301.       fprintf(codefile, "   dptr r_argp_sav;\n");
  1302.       fprintf(codefile, "\n");
  1303.       fprintf(codefile, "   r_argp_sav = argp;\n");
  1304.       }
  1305.    if (debug_info) {
  1306.       fprintf(codefile, "   --k_level;\n");
  1307.       fprintf(codefile, "   if (k_trace) strace();\n");
  1308.       }
  1309.    fprintf(codefile, "   pfp = ");
  1310.    frame(outer);
  1311.    fprintf(codefile, ".old_pfp;\n");
  1312.    fprintf(codefile, "   argp = ");
  1313.    frame(outer);
  1314.    fprintf(codefile, ".old_argp;\n");
  1315.    if (line_info) {
  1316.       fprintf(codefile, "   line_num = ");
  1317.       frame(outer);
  1318.       fprintf(codefile, ".debug.old_line;\n");
  1319.       fprintf(codefile, "   file_name = ");
  1320.       frame(outer);
  1321.       fprintf(codefile , ".debug.old_fname;\n");
  1322.       }
  1323.    fprintf(codefile, "   r_signal = (*");
  1324.    if (outer)
  1325.       fprintf(codefile, "r_s_cont)();\n");
  1326.    else
  1327.       fprintf(codefile, "r_pfp->succ_cont)();\n");
  1328.    fprintf(codefile, "   if (r_signal != A_Resume) {\n");
  1329.    if (outer)
  1330.       fprintf(codefile, "      tend = r_frame.tend.previous;\n");
  1331.    fprintf(codefile, "      return r_signal;\n");
  1332.    fprintf(codefile, "      }\n");
  1333.    fprintf(codefile, "   pfp = (struct p_frame *)&");
  1334.    frame(outer);
  1335.    fprintf(codefile, ";\n");
  1336.    if (cur_proc->nargs == 0)
  1337.       fprintf(codefile, "   argp = NULL;\n");
  1338.    else {
  1339.       if (optim) {
  1340.          if (outer)
  1341.             fprintf(codefile, "   argp = r_args;\n");
  1342.          else
  1343.             fprintf(codefile, "   argp = r_argp_sav;\n");
  1344.          }
  1345.       else {
  1346.          fprintf(codefile, "   argp = &");
  1347.          if (outer)
  1348.             fprintf(codefile, "r_frame.");
  1349.          else
  1350.             fprintf(codefile, "r_pfp->");
  1351.          fprintf(codefile, "tend.d[%d];\n", first_arg);
  1352.          }
  1353.       }
  1354.    if (debug_info) {
  1355.       fprintf(codefile, "   if (k_trace) atrace();\n");
  1356.       fprintf(codefile, "   ++k_level;\n");
  1357.       }
  1358.    if (cur_proc->nargs != 0 && optim && !outer)
  1359.       fprintf(codefile, "   }\n");
  1360.    }
  1361.  
  1362. /*
  1363.  * smpl_clsg - print call and signal handling code, but nothing fancy.
  1364.  */
  1365. static novalue smpl_clsg(call, outer)
  1366. struct code *call;
  1367. int outer;
  1368.    {
  1369.    struct sig_act *sa;
  1370.  
  1371.    fprintf(codefile, "   r_signal = ");
  1372.    prtcall(call, outer);
  1373.    fprintf(codefile, ";\n");
  1374.    if (call->Flags & ForeignSig)
  1375.        chkforgn(outer);
  1376.    fprintf(codefile, "   switch (r_signal) {\n");
  1377.    for (sa = call->SigActs; sa != NULL; sa = sa->next) {
  1378.       fprintf(codefile, "      case ");
  1379.       prt_cond(sa->sig);
  1380.       fprintf(codefile, ":\n      ");
  1381.       prtcode(sa->cd, outer);
  1382.       }
  1383.    fprintf(codefile, "      }\n");
  1384.    }
  1385.  
  1386. /*
  1387.  * chkforgn - produce code to see if the current signal belongs to a
  1388.  *   procedure higher up the call chain and pass it along if it does.
  1389.  */
  1390. static novalue chkforgn(outer)
  1391. int outer;
  1392.    {
  1393.    fprintf(codefile, "   if (pfp != (struct p_frame *)");
  1394.    if (outer) {
  1395.       fprintf(codefile, "&r_frame) {\n");
  1396.       fprintf(codefile, "      tend = r_frame.tend.previous;\n");
  1397.       }
  1398.    else
  1399.       fprintf(codefile, "r_pfp) {\n");
  1400.    fprintf(codefile, "      return r_signal;\n");
  1401.    fprintf(codefile, "      }\n");
  1402.    }
  1403.  
  1404. /*
  1405.  * good_clsg - print call and signal handling code and do a good job.
  1406.  */
  1407. static novalue good_clsg(call, outer)
  1408. struct code *call;
  1409. int outer;
  1410.    {
  1411.    struct sig_act *sa, *sa1, *nxt_sa;
  1412.    int ncases;   /* the number of cases - each may have multiple case labels */
  1413.    int ncaselbl; /* the number of case labels */
  1414.    int nbreak;   /* the number of cases that just break out of the switch */
  1415.    int nretsig;  /* the number of cases that just pass along signal */
  1416.    int sig_var;
  1417.    int dflt;
  1418.    struct code *cond;
  1419.    struct code *then_cd;
  1420.    
  1421.    /*
  1422.     * Decide whether to use "break;", "return r_signal;", or nothing as
  1423.     *  the default case.
  1424.     */
  1425.    nretsig = 0;
  1426.    nbreak = 0;
  1427.    for (sa = call->SigActs; sa != NULL; sa = sa->next) {
  1428.       if (sa->cd->cd_id == C_RetSig && sa->sig == sa->cd->SigRef->sig) {
  1429.          /*
  1430.           * The action returns the same signal detected by this case.
  1431.           */
  1432.          ++nretsig;
  1433.          }
  1434.       else if (sa->cd->cd_id == C_Break) {
  1435.          cond = sa->sig;   /* if there is only one break, we may want this */
  1436.          ++nbreak;
  1437.          }
  1438.       }
  1439.    dflt = DfltNone;
  1440.    ncases = 0;
  1441.    if (nbreak > 0 && nbreak >= nretsig)  {
  1442.       /*
  1443.        * There are at least as many "break;"s as "return r_signal;"s, so
  1444.        *  use "break;" for default clause.
  1445.        */
  1446.       dflt = DfltBrk;
  1447.       ncases = 1;
  1448.       }
  1449.    else if (nretsig > 1) {
  1450.       /*
  1451.        * There is more than one case that returns the same signal it
  1452.        *  detects and there are more of them than "break;"s, to make
  1453.        *  "return r_signal;" the default clause.
  1454.        */
  1455.       dflt = DfltRetSig;
  1456.       ncases = 1;
  1457.       }
  1458.  
  1459.    /*
  1460.     * Gather case labels together for each case, ignoring cases that
  1461.     *  fall under the default. This involves constructing a new
  1462.     *  improved call->SigActs list.
  1463.     */
  1464.    ncaselbl = ncases;
  1465.    sa = call->SigActs;
  1466.    call->SigActs = NULL;
  1467.    for ( ; sa != NULL; sa = nxt_sa) {
  1468.       nxt_sa = sa->next;
  1469.       /*
  1470.        * See if we have already found a case with the same action.
  1471.        */
  1472.       sa1 = call->SigActs;
  1473.       switch (sa->cd->cd_id) {
  1474.          case C_Break:
  1475.             if (dflt == DfltBrk)
  1476.                continue;
  1477.             while (sa1 != NULL && sa1->cd->cd_id != C_Break)
  1478.                sa1 = sa1->next;
  1479.             break;
  1480.          case C_RetSig:
  1481.             if (dflt == DfltRetSig && sa->cd->SigRef->sig == sa->sig)
  1482.                continue;
  1483.             while (sa1 != NULL && (sa1->cd->cd_id != C_RetSig ||
  1484.                 sa1->cd->SigRef->sig != sa->cd->SigRef->sig))
  1485.                sa1 = sa1->next;
  1486.             break;
  1487.          default: /* C_Goto */
  1488.             while (sa1 != NULL && (sa1->cd->cd_id != C_Goto ||
  1489.                 sa1->cd->Lbl != sa->cd->Lbl))
  1490.                sa1 = sa1->next;
  1491.             break;
  1492.             }
  1493.       ++ncaselbl;
  1494.       if (sa1 == NULL) {
  1495.          /*
  1496.           * First time we have seen this action, create a new case.
  1497.           */
  1498.          ++ncases;
  1499.          sa->next = call->SigActs;
  1500.          call->SigActs = sa;
  1501.          }
  1502.       else {
  1503.          /*
  1504.           * We can share the action of another case label.
  1505.           */
  1506.          sa->shar_act = sa1->shar_act;
  1507.          sa1->shar_act = sa;
  1508.          }
  1509.       }
  1510.  
  1511.    /*
  1512.     * If we might receive a "foreign" signal that belongs to a procedure
  1513.     *  further down the call chain, put the signal in "r_signal" then
  1514.     *  check for this condition.
  1515.     */
  1516.    sig_var = 0;
  1517.    if (call->Flags & ForeignSig) {
  1518.       fprintf(codefile, "   r_signal = ");
  1519.       prtcall(call, outer);
  1520.       fprintf(codefile, ";\n");
  1521.       chkforgn(outer);
  1522.       sig_var = 1;
  1523.       }
  1524.  
  1525.    /*
  1526.     * Determine the best way to handle the signal returned from the call.
  1527.     */
  1528.    if (ncases == 0) {
  1529.       /*
  1530.        * Any further signal checking has been optimized away. Execution
  1531.        *  just falls through to subsequent code. If the call has not
  1532.        *  been done, do it.
  1533.        */
  1534.       if (!sig_var) {
  1535.          fprintf(codefile, "   ");
  1536.          prtcall(call, outer);
  1537.          fprintf(codefile, ";\n");
  1538.          }
  1539.       }
  1540.    else if (ncases == 1) {
  1541.       if (dflt == DfltRetSig || ncaselbl == nretsig) {
  1542.          /*
  1543.           * All this call does is pass the signal on. See if we have
  1544.           *  done the call yet.
  1545.           */
  1546.          if (sig_var)
  1547.             fprintf(codefile, "   return r_signal;");
  1548.          else {
  1549.             fprintf(codefile, "   return ");
  1550.             prtcall(call, outer);
  1551.             fprintf(codefile, ";\n");
  1552.             }
  1553.          }
  1554.       else {
  1555.          /*
  1556.           * We know what to do without looking at the signal. Make sure
  1557.           *  we have done the call. If the action is not simply  "break"
  1558.           *  out signal checking, execute it. 
  1559.           */
  1560.          if (!sig_var) {
  1561.             fprintf(codefile, "   ");
  1562.             prtcall(call, outer);
  1563.             fprintf(codefile, ";\n");
  1564.             }
  1565.          if (dflt != DfltBrk)
  1566.             prtcode(call->SigActs->cd, outer);
  1567.          }
  1568.       }
  1569.    else {
  1570.       /*
  1571.        * We have at least two cases. If we have a default action of returning
  1572.        *  the signal without looking at it, make sure it is in "r_signal".
  1573.        */
  1574.       if (!sig_var && dflt == DfltRetSig) {
  1575.          fprintf(codefile, "   r_signal = ");
  1576.          prtcall(call, outer);
  1577.          fprintf(codefile, ";\n");
  1578.          sig_var = 1;
  1579.          }
  1580.       
  1581.       if (ncaselbl == 2) {
  1582.          /*
  1583.           * We can use an if statement. If we need the signal in "r_signal",
  1584.           *  it is already there.
  1585.           */
  1586.          fprintf(codefile, "   if (");
  1587.          if (sig_var) 
  1588.             fprintf(codefile, "r_signal");
  1589.          else
  1590.             prtcall(call, outer);
  1591.    
  1592.          cond = call->SigActs->sig;
  1593.          then_cd = call->SigActs->cd;
  1594.             
  1595.          /*
  1596.           * If the "then" clause is a no-op ("break;" from a switch),
  1597.           *  prepare to eliminate it by reversing the test in the
  1598.           *  condition.
  1599.           */
  1600.          if (then_cd->cd_id == C_Break)
  1601.             fprintf(codefile, " != ");
  1602.          else
  1603.             fprintf(codefile, " == ");
  1604.    
  1605.          prt_cond(cond);
  1606.          fprintf(codefile, ")\n   ");
  1607.    
  1608.          if (then_cd->cd_id == C_Break) {
  1609.             /*
  1610.              * We have reversed the test, so we need to use the default
  1611.              *  code. However, because a "break;" exists and it is not
  1612.              *  default, "return r_signal;" must be the default.
  1613.              */
  1614.             fprintf(codefile, "   return r_signal;\n");
  1615.             }
  1616.          else {
  1617.             /*
  1618.              * Print the "then" clause and determine what the "else" clause
  1619.              *  is.
  1620.              */
  1621.             prtcode(then_cd, outer);
  1622.             if (call->SigActs->next != NULL) {
  1623.                fprintf(codefile, "   else\n   ");
  1624.                prtcode(call->SigActs->next->cd, outer);
  1625.                }
  1626.             else if (dflt == DfltRetSig) {
  1627.                fprintf(codefile, "   else\n");
  1628.                fprintf(codefile, "       return r_signal;\n");
  1629.                }
  1630.             }
  1631.          }
  1632.       else if (ncases == 2 && nbreak == 1) {
  1633.          /*
  1634.           * We can use an if-then statement with a negated test. Note,
  1635.           *  the non-break case is not "return r_signal" or we would have
  1636.           *  ncaselbl = 2, making the last test true. This also means that
  1637.           *  break is the default (the break condition was saved).
  1638.           */
  1639.          fprintf(codefile, "   if (");
  1640.          if (sig_var) 
  1641.             fprintf(codefile, "r_signal");
  1642.          else
  1643.             prtcall(call, outer);
  1644.          fprintf(codefile, " != ");
  1645.          prt_cond(cond);
  1646.          fprintf(codefile, ") {\n   ");
  1647.          prtcode(call->SigActs->cd, outer);
  1648.          fprintf(codefile, "      }\n");
  1649.          }
  1650.       else {
  1651.          /*
  1652.           * We must use a full case statement. If we need the signal in
  1653.           *  "r_signal", it is already there.
  1654.           */
  1655.          fprintf(codefile, "   switch (");
  1656.          if (sig_var) 
  1657.             fprintf(codefile, "r_signal");
  1658.          else
  1659.             prtcall(call, outer);
  1660.          fprintf(codefile, ") {\n");
  1661.    
  1662.          /*
  1663.           * Print the cases
  1664.           */
  1665.          for (sa = call->SigActs; sa != NULL; sa = sa->next) {
  1666.             for (sa1 = sa; sa1 != NULL; sa1 = sa1->shar_act) {
  1667.                fprintf(codefile, "      case ");
  1668.                prt_cond(sa1->sig);
  1669.                fprintf(codefile, ":\n");
  1670.                }
  1671.             fprintf(codefile, "      ");
  1672.             prtcode(sa->cd, outer);
  1673.             }
  1674.       
  1675.          /*
  1676.           * If we have a default action and it is not break, print it.
  1677.           */
  1678.          if (dflt == DfltRetSig) {
  1679.             fprintf(codefile, "      default:\n");
  1680.             fprintf(codefile, "         return r_signal;\n");
  1681.             }
  1682.       
  1683.          fprintf(codefile, "      }\n");
  1684.          }
  1685.       }
  1686.    }
  1687.  
  1688. /*
  1689.  * prtcall - print call.
  1690.  */
  1691. static novalue prtcall(call, outer)
  1692. struct code *call;
  1693. int outer;
  1694.    {
  1695.    /*
  1696.     * Either the operation or the continuation may be missing, but not
  1697.     *  both.
  1698.     */
  1699.    if (call->OperName == NULL) {
  1700.       prt_cont(call->Cont);
  1701.       fprintf(codefile, "()");
  1702.       }
  1703.    else {
  1704.       fprintf(codefile, "%s(", call->OperName);
  1705.       if (call->ArgLst != NULL)
  1706.          prt_ary(call->ArgLst, outer);
  1707.       if (call->Cont == NULL) {
  1708.          if (call->Flags & NeedCont) {
  1709.             /*
  1710.              * The operation requires a continuation argument even though
  1711.              *  this call does not include one, pass the NULL pointer.
  1712.              */
  1713.             if (call->ArgLst != NULL)
  1714.                fprintf(codefile, ", ");
  1715.             fprintf(codefile, "(continuation)NULL");
  1716.             }
  1717.          }
  1718.       else {
  1719.          /*
  1720.           * Pass the success continuation.
  1721.           */
  1722.          if (call->ArgLst != NULL)
  1723.             fprintf(codefile, ", ");
  1724.          prt_cont(call->Cont);
  1725.          }
  1726.       fprintf(codefile, ")");
  1727.       }
  1728.    }
  1729.  
  1730. /*
  1731.  * prt_cont - print the name of a continuation.
  1732.  */
  1733. static novalue prt_cont(cont)
  1734. struct c_fnc *cont;
  1735.    {
  1736.    struct code *sig;
  1737.  
  1738.    if (cont->flag & CF_SigOnly) {
  1739.       /*
  1740.        * This continuation only returns a signal. All continuations
  1741.        *  returning the same signal are implemented by the same C function.
  1742.        */
  1743.       sig = cont->cd.next->SigRef->sig;
  1744.       if (sig->cd_id == C_Resume)
  1745.          fprintf(codefile, "sig_rsm");
  1746.       else {
  1747.          sig = ChkBound(sig);
  1748.          ChkSeqNum(sig);
  1749.          fprintf(codefile, "sig_%d", sig->SeqNum);
  1750.          }
  1751.       }
  1752.    else {
  1753.       /*
  1754.        * Regular continuation.
  1755.        */
  1756.       ChkPrefix(cont->prefix);
  1757.       fprintf(codefile, "P%s_%s", cont->prefix, cur_proc->name);
  1758.       }
  1759.    }
  1760.  
  1761. /*
  1762.  * val_loc - output code referencing a value location (usually variable of
  1763.  *  some sort).
  1764.  */
  1765. static novalue val_loc(loc, outer)
  1766. struct val_loc *loc;
  1767. int outer;
  1768.    {
  1769.    /*
  1770.     * See if we need to cast a block pointer to a specific block type
  1771.     *  or if we need to take the address of a location.
  1772.     */
  1773.    if (loc->mod_access == M_BlkPtr && loc->blk_name != NULL)
  1774.       fprintf(codefile, "(*(struct %s **)&", loc->blk_name);
  1775.    if (loc->mod_access == M_Addr)
  1776.       fprintf(codefile, "(&");
  1777.  
  1778.    switch (loc->loc_type) {
  1779.       case V_Ignore:
  1780.          fprintf(codefile, "trashcan");
  1781.          break;
  1782.       case V_Temp:
  1783.          /*
  1784.           * Temporary descriptor variable.
  1785.           */
  1786.          frame(outer);
  1787.          fprintf(codefile, ".tend.d[%d]", cur_proc->tnd_loc + loc->u.tmp);
  1788.          break;
  1789.       case V_ITemp:
  1790.          /*
  1791.           * Temporary C integer variable.
  1792.           */
  1793.          frame(outer);
  1794.          fprintf(codefile, ".i%d", loc->u.tmp);
  1795.          break;
  1796.       case V_DTemp:
  1797.          /*
  1798.           * Temporary C double variable.
  1799.           */
  1800.          frame(outer);
  1801.          fprintf(codefile, ".d%d", loc->u.tmp);
  1802.          break;
  1803.       case V_Const:
  1804.          /*
  1805.           * Integer constant (used for size of variable part of arg list).
  1806.           */
  1807.          fprintf(codefile, "%d", loc->u.int_const);
  1808.          break;
  1809.       case V_NamedVar:
  1810.          /*
  1811.           * Icon named variable.
  1812.           */
  1813.          prt_var(loc->u.nvar, outer);
  1814.          break;
  1815.       case V_CVar:
  1816.          /*
  1817.           * C variable from in-line code.
  1818.           */
  1819.          fprintf(codefile, "%s", loc->u.name);
  1820.          break;
  1821.       case V_PRslt:
  1822.          /*
  1823.           * Procedure result location.
  1824.           */
  1825.          if (!outer)
  1826.             fprintf(codefile, "(*r_pfp->rslt)");
  1827.          else
  1828.             fprintf(codefile, "(*r_rslt)");
  1829.          break;
  1830.        }
  1831.  
  1832.    /*
  1833.     * See if we are accessing the vword of a descriptor.
  1834.     */
  1835.    switch (loc->mod_access) {
  1836.       case M_CharPtr:
  1837.          fprintf(codefile, ".vword.sptr");
  1838.          break;
  1839.       case M_BlkPtr:
  1840.          fprintf(codefile, ".vword.bptr");
  1841.          if (loc->blk_name != NULL)
  1842.             fprintf(codefile, ")");
  1843.          break;
  1844.       case M_CInt:
  1845.          fprintf(codefile, ".vword.integr");
  1846.          break;
  1847.       case M_Addr:
  1848.          fprintf(codefile, ")");
  1849.          break;
  1850.       }
  1851.    }
  1852.  
  1853. /*
  1854.  * prt_cond - print a condition (signal number).
  1855.  */
  1856. static novalue prt_cond(cond)
  1857. struct code *cond;
  1858.    {
  1859.    if (cond == &resume)
  1860.       fprintf(codefile, "A_Resume");
  1861.    else if (cond == &contin)
  1862.       fprintf(codefile, "A_Continue");
  1863.    else if (cond == &fallthru)
  1864.       fprintf(codefile, "A_FallThru");
  1865.    else {
  1866.       cond = ChkBound(cond);
  1867.       ChkSeqNum(cond);
  1868.       fprintf(codefile, "%d /* %s */", cond->SeqNum, cond->Desc);
  1869.       }
  1870.    }
  1871.  
  1872. /*
  1873.  * initpblk - write a procedure block along with initialization up to the
  1874.  *   the array of qualifiers.
  1875.  */
  1876. static novalue initpblk(f, c, prefix, name, nquals, nparam, ndynam, nstatic,
  1877.    frststat)
  1878. FILE *f;      /* output file */
  1879. int c;        /* distinguishes procedures, functions, record constructors */
  1880. char* prefix; /* prefix for name */
  1881. char *name;   /* name of routine */
  1882. int nquals;   /* number of qualifiers at end of block */
  1883. int nparam;   /* number of parameters */
  1884. int ndynam;   /* number of dynamic locals or function/record indicator */
  1885. int nstatic;  /* number of static locals or record number */
  1886. int frststat; /* index into static array of first static local */
  1887.    {
  1888.    fprintf(f, "B_IProc(%d) B%c%s_%s = ", nquals, c, prefix, name);
  1889.    fprintf(f, "{T_Proc, %d, %c%s_%s, %d, %d, %d, %d, {", 9 + 2 * nquals, c,
  1890.       prefix, name, nparam, ndynam, nstatic, frststat);
  1891.    }
  1892.  
  1893.