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 / typinfer.c < prev   
C/C++ Source or Header  |  1996-03-22  |  153KB  |  5,135 lines
  1. /*
  2.  * typinfer.c - routines to perform type inference.
  3.  */
  4. #include "::h:gsupport.h"
  5. #include "::h:lexdef.h"
  6. #include "ctrans.h"
  7. #include "csym.h"
  8. #include "ctree.h"
  9. #include "ctoken.h"
  10. #include "cglobals.h"
  11. #include "ccode.h"
  12. #include "cproto.h"
  13. #ifdef TypTrc
  14. #ifdef HighResTime
  15. #include <sys/time.h>
  16. #include <sys/resource.h>
  17. #endif                    /* HighResTime */
  18. #endif                    /* TypTrc */
  19.  
  20. /*
  21.  * Information about co-expressions is keep on a list.
  22.  */
  23. struct t_coexpr {
  24.    nodeptr n;               /* code for co-expression */
  25.    int typ_indx;            /* relative type number (index) */
  26.    struct store *in_store;  /* store entry into co-expression via activation */
  27.    struct store *out_store; /* store at end of co-expression */
  28.    unsigned int *act_typ;   /* types passed via co-expression activation */
  29.    unsigned int *rslt_typ;  /* types resulting from "co-expression return" */
  30.    int iteration;
  31.    struct t_coexpr *next;
  32.    };
  33.  
  34. struct t_coexpr *coexp_lst;
  35.  
  36. #ifdef TypTrc
  37. extern int typealloc;        /* flag to account for allocation */
  38. extern long typespace;        /* amount of space for type inference */
  39. #endif                    /* TypTrc */
  40.  
  41. /*
  42.  * A type is a bit vector representing a union of basic types. There
  43.  *  are 3 sizes of types: first class types (Icon language types),
  44.  *  intermediate value types (first class types plus variable references), 
  45.  *  run-time routine types (intermediate value types plus internal
  46.  *  references to descriptors such as set elements). When the size of
  47.  *  the type is known from context, a simple bit vector can be used.
  48.  *  In other contexts, the size must be included.
  49.  */
  50. struct type {
  51.    int size;
  52.    unsigned int *bits;
  53.    struct type *next;
  54.    };
  55.  
  56. struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */
  57.  
  58. /*
  59.  * argtyps is the an array of types large enough to accommodate the argument
  60.  *  list of any operation.
  61.  */
  62. struct argtyps {
  63.    struct argtyps *next;
  64.    unsigned int *types[1];  /* actual size is max_prm */
  65.    };
  66.  
  67. /*
  68.  * prototypes for static functions.
  69.  */
  70. hidden novalue         abstr_new   Params((struct node *n, struct il_code *il));
  71. hidden novalue         abstr_typ   Params((struct il_code *il, struct type *typ));
  72. hidden struct store   *alloc_stor  Params((int stor_sz, int n_types));
  73. hidden unsigned int   *alloc_typ   Params((int n_types));
  74. hidden novalue         bitrange    Params((int typcd, int *frst_bit,
  75.                                    int *last_bit));
  76. hidden int             bitset      Params((unsigned int *typ, int bit));
  77. hidden novalue         clr_typ     Params((unsigned int *type,
  78.                                       unsigned int bit));
  79. hidden novalue         chk_succ    Params((int ret_flag,
  80.                                      struct store *susp_stor));
  81. hidden struct store   *cpy_store   Params((struct store *source));
  82. hidden novalue         deref_lcl   Params((unsigned int *src,
  83.                                      unsigned int *dest));
  84. hidden int             eval_cond   Params((struct il_code *il));
  85. hidden novalue         free_argtyp Params((struct argtyps *argtyps));
  86. hidden novalue         free_store  Params((struct store *store));
  87. hidden novalue         free_wktyp  Params((struct type *typ));
  88. hidden int             findloops   Params(( struct node *n, int resume,
  89.                                      unsigned int *rslt_type));
  90. hidden novalue         find_new    Params((struct node *n));
  91. hidden novalue         gen_inv     Params((unsigned int *prc_typ, nodeptr n));
  92. hidden struct argtyps *get_argtyp  Params((noargs));
  93. hidden struct store   *get_store   Params((int clear));
  94. hidden struct type    *get_wktyp   Params((noargs));
  95. hidden int             has_type    Params((unsigned int *typ, int typcd,
  96.                                      int clear));
  97. hidden novalue         infer_act   Params((nodeptr n));
  98. hidden novalue         infer_con   Params((struct rentry *rec, nodeptr n));
  99. hidden int             infer_il    Params((struct il_code *il));
  100. hidden novalue         infer_impl  Params((struct implement *impl,
  101.                                      nodeptr n, struct symtyps *symtyps,
  102.                                      unsigned int *rslt_typ));
  103. hidden novalue         infer_nd    Params((nodeptr n));
  104. hidden novalue         infer_prc   Params((struct pentry *proc, nodeptr n));
  105. hidden int             is_empty    Params((unsigned int *typ));
  106. hidden novalue         mrg_act     Params((struct t_coexpr *coexp,
  107.                                      struct store *e_store,
  108.                                      struct type *rslt_typ));
  109. hidden novalue         mrg_store   Params((struct store *source,
  110.                                      struct store *dest));
  111. hidden int             other_type  Params((unsigned int *typ, int typcd));
  112. hidden novalue         set_ret     Params((unsigned int *typ));
  113. hidden novalue         set_typ     Params((unsigned int *type, 
  114.                                      unsigned int bit));
  115. hidden novalue         side_effect Params((struct il_code *il));
  116. hidden struct symtyps *symtyps     Params((int nsyms));
  117. hidden novalue         typcd_bits  Params((int typcd, struct type *typ));
  118. hidden novalue         typ_deref   Params((unsigned int *src,
  119.                                      unsigned int *dest, int chk));
  120. #ifdef TypTrc
  121. hidden novalue         prt_d_typ   Params((FILE *file, unsigned int *typ));
  122. hidden novalue         prt_typ     Params((FILE *file, unsigned int *typ));
  123. #endif                    /* TypTrc */
  124.  
  125. /*
  126.  * CpyTyp - copy a type of the given size from one bit vector to another.
  127.  */
  128. #define CpyTyp(size,src,dest) {\
  129.    int typ_indx;\
  130.    for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\
  131.       (dest)[typ_indx] = (src)[typ_indx];}
  132.  
  133. /*
  134.  * MrgTyp - merge a type of the given size from one bit vector into another.
  135.  */
  136. #define MrgTyp(size,src,dest) {\
  137.    int typ_indx;\
  138.    for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\
  139.       (dest)[typ_indx] |= (src)[typ_indx];}
  140.  
  141. /*
  142.  * MrgTyp - merge a type of the given size from one bit vector into another,
  143.  *  updating the changed flag if the destination is changed by the merger.
  144.  */
  145. #define ChkMrgTyp(size,src,dest) {\
  146.    int typ_indx; unsigned int old;\
  147.    for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx) {\
  148.       old = (dest)[typ_indx];\
  149.       (dest)[typ_indx] |= (src)[typ_indx];\
  150.       if (old != (dest)[typ_indx]) ++changed;}}
  151.  
  152. /*
  153.  * ClrTyp - zero out the bit vector for a type.
  154.  */
  155. #define ClrTyp(size,typ) {\
  156.    int typ_indx;\
  157.    for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\
  158.       (typ)[typ_indx] = 0;}
  159.  
  160. /*
  161.  * NumInts - convert from the number of bits in a bit vector to the
  162.  *  number of integers implementing it.
  163.  */
  164. #define NumInts(n_bits) (n_bits - 1) / IntBits + 1
  165.  
  166. #define CanFail   1
  167.  
  168. /*
  169.  * cur_coexp is non-null while performing type inference on code from a
  170.  *  create expression. If it is null, the possible current co-expressions
  171.  *  must be found from cur_proc.
  172.  */
  173. struct t_coexpr *cur_coexp = NULL;
  174.  
  175. struct gentry **proc_map;    /* map procedure types to symbol table entries */
  176. struct rentry **rec_map;     /* map record types to record information */
  177. struct t_coexpr **coexp_map; /* map co-expression types to information */
  178.  
  179. /*
  180.  * Data base type codes are mapped to type inferencing information using
  181.  *  an array.
  182.  */
  183. struct typ_info {
  184.    int frst_bit;      /* first bit in bit vector allocated to this type */
  185.    int num_bits;      /* number of bits in bit vector allocated to this type */
  186.    int new_indx;      /* index into arrays of allocated types for operation */
  187.    unsigned int *typ; /* for variables: initial type */
  188.    };
  189. static struct typ_info *type_array;
  190.  
  191. static int num_new;   /* number of types supporting "new" abstract type comp */
  192.  
  193. /*
  194.  * Data base component codes are mapped to type inferencing information 
  195.  *  using an array.
  196.  */
  197. struct compnt_info {
  198.    int frst_bit;        /* first bit in bit vector allocated to component */
  199.    int num_bits;        /* number of bits allocated to this component */
  200.    struct store *store; /* maps component "reference" to the type it holds */ 
  201.    };
  202. static struct compnt_info *compnt_array;
  203.  
  204. static unsigned int frst_fld;   /* bit number of 1st record field */
  205. static unsigned int n_fld;      /* number of record fields */
  206. static unsigned int frst_gbl;   /* bit number of 1st global reference type */
  207. static unsigned int n_gbl;      /* number of global variables */
  208. static unsigned int n_nmgbl;    /* number of named global variables */
  209. static unsigned int frst_loc;   /* bit number of 1st local reference type */
  210. static unsigned int n_loc;      /* maximum number of locals in any procedure */
  211.  
  212. static unsigned int nxt_bit;    /* next unassigned bit in bit vector */
  213. static unsigned int n_icntyp;   /* number of non-variable types */
  214. static unsigned int n_intrtyp;  /* number of types in intermediate values */
  215. static unsigned int n_rttyp;    /* number of types in runtime computations */
  216. static unsigned int val_mask;   /* mask for non-var types in last int of type */
  217.  
  218. static unsigned int null_bit;   /* bit for null type */
  219. static unsigned int str_bit;    /* bit for string type */
  220. static unsigned int cset_bit;   /* bit for cset type */
  221. static unsigned int int_bit;    /* bit for integer type */
  222. static unsigned int real_bit;   /* bit for real type */
  223.  
  224. static struct store *fld_stor;   /* record fields */
  225.  
  226. static int *cur_new;      /* allocated types for current operation */
  227.  
  228. static struct store *succ_store = NULL; /* current success store */
  229. static struct store *fail_store = NULL; /* current failure store */
  230.  
  231. static struct store *dummy_stor;
  232. static struct store *store_pool = NULL; /* free list of store structs */
  233.  
  234. static struct type *type_pool = NULL;          /* free list of type structs */
  235. static struct type cur_rslt = {0, NULL, NULL}; /* result type of operation */
  236.  
  237. static struct argtyps *argtyp_pool = NULL; /* free list of arg type arrays */
  238. static struct argtyps *arg_typs = NULL;    /* current arg type array */
  239.  
  240. static int num_args; /* number of arguments for current operation */
  241. static int n_vararg; /* size of variable part of arg list to run-time routine */
  242.  
  243. static unsigned int *any_typ; /* type bit vector with all bits on */
  244.  
  245. long changed;  /* number of changes to type information in this iteration */
  246. int iteration; /* iteration number for type inferencing */
  247.  
  248. #ifdef TypTrc
  249. static FILE *trcfile = NULL;    /* output file pointer for tracing */
  250. static char *trcname = NULL;    /* output file name for tracing */
  251. static char *trc_indent = "";
  252. #endif                    /* TypTrc */
  253.  
  254. /*
  255.  * typeinfer - infer types of operands. If "do_typinfer" is set, actually
  256.  *   do abstract interpretation, otherwise assume any type for all operands.
  257.  */
  258. novalue typeinfer()
  259.    {
  260.    struct gentry *gptr;
  261.    struct lentry *lptr;
  262.    nodeptr call_main;
  263.    struct pentry *p;
  264.    struct rentry *rec;
  265.    struct t_coexpr *coexp;
  266.    struct store *init_store;
  267.    struct store *f_store;
  268.    unsigned int *type;
  269.    struct implement *ip;
  270.    struct lentry **lhash;
  271.    struct lentry **vartypmap;
  272.    int i, j, k;
  273.    int size;
  274.    int flag;
  275.  
  276. #ifdef TypTrc
  277.    /*
  278.     * Set up for type tracing.
  279.     */
  280.    long start_infer, end_infer;
  281.  
  282. #ifdef HighResTime
  283.    struct rusage rusage;
  284.  
  285.    getrusage(RUSAGE_SELF, &rusage);
  286.    start_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000;
  287. #else                    /* HighResTime */
  288.    start_infer = millisec();
  289. #endif                    /* HighResTime */
  290.  
  291.    typealloc = 1;        /* note allocation in this phase */
  292.  
  293. #ifdef EnvVars
  294.    trcname = getenv("TYPTRC");
  295. #else                    /* EnvVars */
  296.    trcname = "typtrc.out";
  297. #endif                    /* EnvVars */
  298.  
  299.    if (trcname != NULL && strlen(trcname) != 0) {
  300.  
  301. #if UNIX
  302.       if (trcname[0] == '|') {
  303.          FILE *popen();
  304.  
  305.          trcfile = popen(trcname+1, WriteText);
  306.          }
  307.       else
  308. #endif                    /* UNIX */
  309.  
  310.       trcfile = fopen(trcname, WriteText);
  311.  
  312.       if (trcfile == NULL) {
  313.          fprintf(stderr, "TYPTRC: cannot open %s\n", trcname);
  314.          fflush(stderr);
  315.          exit(ErrorExit);
  316.          }
  317.       }
  318. #endif                    /* TypTrc */
  319.  
  320.    /*
  321.     * Make sure max_prm is large enough for any run-time routine.
  322.     */
  323.    for (i = 0; i < IHSize; ++i)
  324.       for (ip = bhash[i]; ip != NULL; ip = ip->blink)
  325.          if (ip->nargs > max_prm)
  326.            max_prm = ip->nargs;
  327.    for (i = 0; i < IHSize; ++i)
  328.       for (ip = ohash[i]; ip != NULL; ip = ip->blink)
  329.          if (ip->nargs > max_prm)
  330.            max_prm = ip->nargs;
  331.  
  332.    /*
  333.     * Allocate an arrays to map data base type codes and component codes 
  334.     *  to type inferencing information.
  335.     */
  336.    type_array = (struct typ_info *)alloc((unsigned int)(num_typs *
  337.       sizeof(struct typ_info)));
  338.    compnt_array = (struct compnt_info *)alloc((unsigned int)(num_cmpnts *
  339.       sizeof(struct compnt_info)));
  340.  
  341.    /*
  342.     * Find those types that support the "new" abstract type computation
  343.     *  assign to them locations in the arrays of allocated types associated
  344.     *  with operation invocations. Also initialize the number of type bits.
  345.     *  Types with no subtypes have one bit. Types allocated with the the "new"
  346.     *  abstract have a default sub-type that is allocated here. Procedures
  347.     *  have a subtype to for string invocable operators. Co-expressions
  348.     *  have a subtype for &main. Records are handled below.
  349.     */
  350.    num_new = 0;
  351.    for (i = 0; i < num_typs; ++i) {
  352.       if (icontypes[i].support_new)
  353.          type_array[i].new_indx = num_new++;
  354.       type_array[i].num_bits = 1;   /* reserve one type bit */
  355.       }
  356.    type_array[list_typ].num_bits = 2;  /* default & list for arg to main() */
  357.  
  358.    cur_coexp = NewStruct(t_coexpr);
  359.    cur_coexp->n = NULL;
  360.    cur_coexp->next = NULL;
  361.    coexp_lst = cur_coexp;
  362.  
  363.    if (do_typinfer) {
  364.       /*
  365.        * Go through the  syntax tree for each procedure locating program
  366.        *  points that may create structures at run time. Allocate the
  367.        *  appropriate structure type(s) to each such point.
  368.        */
  369.       for (p = proc_lst; p != NULL; p = p->next) {
  370.          if (p->nargs < 0)
  371.             p->arg_lst = type_array[list_typ].num_bits++; /* list for varargs */
  372.          find_new(Tree1(p->tree));  /* initial clause */
  373.          find_new(Tree2(p->tree));  /* body of procedure */
  374.          }
  375.       }
  376.  
  377.    /*
  378.     * Allocate a type number for each record type (use record number for
  379.     *  offset) and a variable type number for each field.
  380.     */
  381.    n_fld = 0;
  382.    if (rec_lst == NULL) {
  383.       type_array[rec_typ].num_bits = 0;
  384.       rec_map = NULL;
  385.       }
  386.    else {
  387.       type_array[rec_typ].num_bits = rec_lst->rec_num + 1;
  388.       rec_map = (struct rentry **)alloc(
  389.          (unsigned int)((rec_lst->rec_num + 1)*sizeof(struct rentry *)));
  390.       for (rec = rec_lst; rec != NULL; rec = rec->next) {
  391.          rec->frst_fld = n_fld;
  392.          n_fld += rec->nfields;
  393.          rec_map[rec->rec_num] = rec;
  394.          }
  395.       }
  396.  
  397.    /*
  398.     * Allocate type numbers to global variables. Don't count those procedure
  399.     *  variables that are no longer referenced in the syntax tree. Do count
  400.     *  static variables. Also allocate types to procedures, built-in functions,
  401.     *  record constructors.
  402.     */
  403.    n_gbl = 0; 
  404.    for (i = 0; i < GHSize; i++)
  405.       for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) {
  406.          flag = gptr->flag;
  407.          if (flag & F_SmplInv)
  408.             gptr->index = -1;   /* unused: set to something not a valid type */
  409.          else {
  410.             gptr->index = n_gbl++;
  411.             if (flag & (F_Proc | F_Record | F_Builtin))
  412.                gptr->init_type = type_array[proc_typ].num_bits++;
  413.             }
  414.          if (flag & F_Proc) {
  415.             for (lptr = gptr->val.proc->statics; lptr != NULL;lptr = lptr->next)
  416.                lptr->val.index = n_gbl++;
  417.             }
  418.          }
  419.    n_nmgbl = n_gbl;
  420.  
  421.    /*
  422.     * Determine relative bit numbers for predefined variable types that
  423.     *  are treated as sets of global variables.
  424.     */
  425.    for (i = 0; i < num_typs; ++i)
  426.       if (icontypes[i].deref == DrfGlbl)
  427.          type_array[i].frst_bit = n_gbl++; /* converted to absolute later */
  428.  
  429.    proc_map = (struct gentry **)alloc(
  430.       (unsigned int)((type_array[proc_typ].num_bits)*sizeof(struct gentry *)));
  431.    proc_map[0] = NULL; /* proc type for string invocable operators */
  432.    for (i = 0; i < GHSize; i++)
  433.       for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) {
  434.          flag = gptr->flag;
  435.          if (!(flag & F_SmplInv) && (flag & (F_Proc | F_Record | F_Builtin)))
  436.             proc_map[gptr->init_type] = gptr;
  437.          }
  438.  
  439.    /*
  440.     * Allocate type numbers to local variables. The same numbers are reused
  441.     *  in different procedures.
  442.     */
  443.    n_loc = 0;
  444.    for (p = proc_lst; p != NULL; p = p->next) {
  445.       i = Abs(p->nargs);
  446.       for (lptr = p->args; lptr != NULL; lptr = lptr->next)
  447.          lptr->val.index = --i;
  448.       i = Abs(p->nargs);
  449.       for (lptr = p->dynams; lptr != NULL; lptr = lptr->next)
  450.          lptr->val.index = i++;
  451.       n_loc = Max(n_loc, i);
  452.  
  453.       /*
  454.        * produce a mapping from the variable types used in this procedure
  455.        *  to the corresponding symbol table entries.
  456.        */
  457.       if (n_gbl + n_loc == 0)
  458.          vartypmap = NULL;
  459.       else
  460.          vartypmap = (struct lentry **)alloc(
  461.             (unsigned int)((n_gbl + n_loc)*sizeof(struct lentry *)));
  462.       for (i = 0; i < n_gbl + n_loc; ++i)
  463.           vartypmap[i] = NULL; /* no entries for foreign statics */
  464.       p->vartypmap = vartypmap;
  465.       lhash = p->lhash;
  466.       for (i = 0; i < LHSize; ++i) {
  467.          for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) {
  468.             switch (lptr->flag) {
  469.                case F_Global:
  470.                   gptr = lptr->val.global;
  471.                   if (!(gptr->flag & F_SmplInv))
  472.                      vartypmap[gptr->index] = lptr;
  473.                   break;
  474.                case F_Static:
  475.                   vartypmap[lptr->val.index] = lptr;
  476.                   break;
  477.                case F_Dynamic:
  478.                case F_Argument:
  479.                   vartypmap[n_gbl + lptr->val.index] = lptr;
  480.                   }
  481.             }
  482.          }
  483.       }
  484.  
  485.    /*
  486.     * There is a component reference subtype for every subtype of the
  487.     *  associated aggregate type.
  488.     */
  489.    for (i = 0; i < num_cmpnts; ++i)
  490.       compnt_array[i].num_bits = type_array[typecompnt[i].aggregate].num_bits;
  491.  
  492.    /*
  493.     * Assign bits for non-variable (first-class) types.
  494.     */
  495.    nxt_bit = 0;
  496.    for (i = 0; i < num_typs; ++i)
  497.       if (icontypes[i].deref == DrfNone) {
  498.          type_array[i].frst_bit = nxt_bit;
  499.          nxt_bit += type_array[i].num_bits;
  500.          }
  501.  
  502.    n_icntyp = nxt_bit; /* number of first-class types */
  503.  
  504.    /*
  505.     * Load some commonly needed bit numbers into global variable.
  506.     */
  507.    null_bit = type_array[null_typ].frst_bit;
  508.    str_bit = type_array[str_typ].frst_bit;
  509.    cset_bit = type_array[cset_typ].frst_bit;
  510.    int_bit = type_array[int_typ].frst_bit;
  511.    real_bit = type_array[real_typ].frst_bit;
  512.  
  513.    /*
  514.     * Assign bits for predefined variable types that are not treated as
  515.     *   sets of globals.
  516.     */
  517.    for (i = 0; i < num_typs; ++i)
  518.       if (icontypes[i].deref == DrfCnst || icontypes[i].deref == DrfSpcl) {
  519.          type_array[i].frst_bit = nxt_bit;
  520.          nxt_bit += type_array[i].num_bits;
  521.          }
  522.  
  523.    /*
  524.     * Assign bits to aggregate compontents that are variables.
  525.     */
  526.    for (i = 0; i < num_cmpnts; ++i)
  527.       if (typecompnt[i].var) {
  528.          compnt_array[i].frst_bit = nxt_bit;
  529.          nxt_bit += compnt_array[i].num_bits;
  530.          }
  531.  
  532.    /*
  533.     * Assign bits to record fields and named variables.
  534.     */
  535.    frst_fld = nxt_bit;
  536.    nxt_bit += n_fld;
  537.    frst_gbl = nxt_bit;
  538.    nxt_bit += n_gbl;
  539.    frst_loc = nxt_bit;
  540.    nxt_bit += n_loc;
  541.  
  542.    /*
  543.     * Convert from relative to ablsolute bit numbers for predefined variable
  544.     *  types that are treated as sets of global variables.
  545.     */
  546.    for (i = 0; i < num_typs; ++i)
  547.       if (icontypes[i].deref == DrfGlbl)
  548.          type_array[i].frst_bit += frst_gbl;
  549.  
  550.    n_intrtyp = nxt_bit; /* number of types for intermediate values */
  551.  
  552.    /*
  553.     * Assign bits to aggregate compontents that are not variables. These
  554.     *  are the runtime system's internal descriptor reference types.
  555.     */
  556.    for (i = 0; i < num_cmpnts; ++i)
  557.       if (!typecompnt[i].var) {
  558.          compnt_array[i].frst_bit = nxt_bit;
  559.          nxt_bit += compnt_array[i].num_bits;
  560.          }
  561.  
  562.    n_rttyp = nxt_bit; /* total size of type system */
  563.  
  564. #ifdef TypTrc
  565.    if (trcfile != NULL) {
  566.       /*
  567.        * Output a summary of the type system.
  568.        */
  569.       for (i = 0; i < num_typs; ++i) {
  570.          fprintf(trcfile, "%s", icontypes[i].id);
  571.          if (strcmp(icontypes[i].id, icontypes[i].abrv) != 0)
  572.             fprintf(trcfile, "(%s)", icontypes[i].abrv);
  573.          fprintf(trcfile, " sub-types: %d\n", type_array[i].num_bits);
  574.          }
  575.       }
  576. #endif                    /* TypTrc */
  577.  
  578.    /*
  579.     * The division between bits for first-class types and variables types
  580.     *  generally occurs in the middle of a word. Set up a mask for extracting
  581.     *  the first-class types from this word.
  582.     */
  583.    val_mask = 0;
  584.    i = n_icntyp - (NumInts(n_icntyp) - 1) * IntBits;
  585.    while (i--)
  586.       val_mask = (val_mask << 1) | 1;
  587.  
  588.    if (do_typinfer) {
  589.       /*
  590.        * Create stores large enough for the component references. These
  591.        *  are global to the entire program, rather than being propagated
  592.        *  from node to node in the syntax tree.
  593.        */
  594.       for (i = 0; i < num_cmpnts; ++i) {
  595.          if (i == str_var)
  596.             size = n_intrtyp;
  597.          else
  598.             size = n_icntyp;
  599.          compnt_array[i].store = alloc_stor(compnt_array[i].num_bits, size);
  600.          }
  601.       fld_stor = alloc_stor(n_fld, n_icntyp);
  602.  
  603.       dummy_stor = get_store(0);
  604.  
  605.       /*
  606.        * First list is arg to main: a list of strings.
  607.        */
  608.       set_typ(compnt_array[lst_elem].store->types[1], str_typ);
  609.       }
  610.  
  611.    /*
  612.     * Set up a type bit vector with all bits on.
  613.     */
  614.    any_typ = alloc_typ(n_rttyp);
  615.    for (i = 0; i < NumInts(n_rttyp); ++i)
  616.       any_typ[i] = ~(unsigned int)0;
  617.  
  618.    /*
  619.     *  Initialize stores and return values for procedures. Also initialize
  620.     *   flag indicating whether the procedure can be executed.
  621.     */
  622.    call_main = NULL;
  623.    for (p = proc_lst; p != NULL; p = p->next) {
  624.       if (do_typinfer) {
  625.          p->iteration = 0;
  626.          p->ret_typ = alloc_typ(n_intrtyp);
  627.          p->coexprs = alloc_typ(n_icntyp);
  628.          p->in_store = alloc_stor(n_gbl + n_loc, n_icntyp);
  629.          if (p->ret_flag & DoesSusp)
  630.             p->susp_store = alloc_stor(n_gbl, n_icntyp);
  631.          else
  632.             p->susp_store = NULL;
  633.          for (i = Abs(p->nargs); i < n_loc; ++i)
  634.             set_typ(p->in_store->types[n_gbl + i], null_bit);
  635.          if (p->nargs < 0)
  636.             set_typ(p->in_store->types[n_gbl + Abs(p->nargs) - 1],
  637.                type_array[list_typ].frst_bit + p->arg_lst);
  638.          if (strcmp(p->name, "main") == 0) {
  639.             /*
  640.              * create a the initial call to main with one list argument.
  641.              */
  642.             call_main = invk_main(p);
  643.             call_main->type = alloc_typ(n_intrtyp);
  644.             Tree2(call_main)->type = alloc_typ(n_intrtyp);
  645.             set_typ(Tree2(call_main)->type, type_array[list_typ].frst_bit + 1);
  646.             call_main->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  647.             }
  648.          p->out_store = alloc_stor(n_gbl, n_icntyp);
  649.          p->reachable = 0;
  650.          }
  651.       else
  652.          p->reachable = 1;
  653.       /*
  654.        * Analyze the code of the procedure to determine where to place stores
  655.        *  that survive iterations of type inferencing. Note, both the initial
  656.        *  clause and the body of the procedure are bounded.
  657.        */
  658.       findloops(Tree1(p->tree), 0, NULL);
  659.       findloops(Tree2(p->tree), 0, NULL);
  660.       }
  661.  
  662.    /*
  663.     * If type inferencing is suppressed, we have set up very conservative
  664.     *   type information and will do no inferencing.
  665.     */
  666.    if (!do_typinfer)
  667.       return;
  668.  
  669.    if (call_main == NULL)
  670.       return;         /* no main procedure, cannot continue */
  671.    if (tfatals > 0)
  672.       return;         /* don't do inference if there are fatal errors */
  673.  
  674.    /*
  675.     * Construct mapping from co-expression types to information
  676.     *  about the co-expressions and finish initializing the information.
  677.     */
  678.    i = type_array[coexp_typ].num_bits;
  679.    coexp_map = (struct t_coexpr **)alloc(
  680.       (unsigned int)(i * sizeof(struct t_coexpr *)));
  681.    for (coexp = coexp_lst; coexp != NULL; coexp = coexp->next) {
  682.        coexp_map[--i] = coexp;
  683.        coexp->typ_indx = i;
  684.        coexp->in_store = alloc_stor(n_gbl + n_loc, n_icntyp);
  685.        coexp->out_store = alloc_stor(n_gbl + n_loc, n_icntyp);
  686.        coexp->act_typ = alloc_typ(n_intrtyp);
  687.        coexp->rslt_typ = alloc_typ(n_intrtyp);
  688.        coexp->iteration = 0;
  689.        }
  690.  
  691.    /*
  692.     * initialize globals
  693.     */
  694.    init_store = get_store(1);
  695.    for (i = 0; i < GHSize; i++)
  696.       for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) {
  697.          flag = gptr->flag;
  698.          if (!(flag & F_SmplInv)) {
  699.             type = init_store->types[gptr->index];
  700.             if (flag & (F_Proc | F_Record | F_Builtin))
  701.                set_typ(type, type_array[proc_typ].frst_bit + gptr->init_type);
  702.             else
  703.                set_typ(type, null_bit);
  704.             }
  705.          }
  706.  
  707.    /*
  708.     * Initialize types for predefined variable types.
  709.     */
  710.    for (i = 0; i < num_typs; ++i) {
  711.       type = NULL;
  712.       switch (icontypes[i].deref) {
  713.          case DrfGlbl:
  714.             /*
  715.              * Treated as a global variable.
  716.              */
  717.             type = init_store->types[type_array[i].frst_bit - frst_gbl];
  718.             break;
  719.          case DrfCnst:
  720.             /*
  721.              * Type doesn't change so keep one copy.
  722.              */
  723.             type = alloc_typ(n_intrtyp);
  724.             type_array[i].typ = type;
  725.             break;
  726.          }
  727.       if (type != NULL) {
  728.           /*
  729.            * Determine which types are in the initial type for this variable.
  730.            */
  731.           for (j = 0; j < num_typs; ++j) {
  732.              if (icontypes[i].typ[j] != '.') {
  733.                 for (k = 0; k < type_array[j].num_bits; ++k)
  734.                    set_typ(type, type_array[j].frst_bit + k);
  735.                 }
  736.              }
  737.           }
  738.       }
  739.  
  740.    f_store = get_store(1);
  741.  
  742.    /*
  743.     * Type inferencing iterates over the program until a fixed point is
  744.     *  reached.
  745.     */
  746.    changed = 1L;    /* force first iteration */
  747.    iteration = 0;
  748.    if (verbose > 1)
  749.       fprintf(stderr, "type inferencing: ");
  750.  
  751.    while (changed > 0L) {
  752.      changed = 0L;
  753.      ++iteration;
  754.  
  755. #ifdef TypTrc
  756.      if (trcfile != NULL)
  757.         fprintf(trcfile, "**** iteration %d ****\n", iteration);
  758. #endif                    /* TypTrc */
  759.  
  760.      /*
  761.       * Start at the implicit initial call to the main procedure. Inferencing
  762.       *  walks the call graph from here.
  763.       */
  764.      succ_store = cpy_store(init_store);
  765.      fail_store = f_store;
  766.      infer_nd(call_main);
  767.  
  768.      /*
  769.       * If requested, monitor the progress of inferencing.
  770.       */
  771.      switch (verbose) {
  772.         case 0:
  773.         case 1:
  774.            break;
  775.         case 2:
  776.            fprintf(stderr, ".");
  777.            break;
  778.         default: /* > 2 */
  779.            if (iteration != 1)
  780.               fprintf(stderr, ", ");
  781.            fprintf(stderr, "%ld", changed);
  782.         }
  783.      }
  784.  
  785.    /*
  786.     * Type inferencing is finished, complete any diagnostic output.
  787.     */
  788.    if (verbose > 1)
  789.       fprintf(stderr, "\n");
  790.  
  791. #ifdef TypTrc
  792.      if (trcfile != NULL) {
  793.  
  794. #ifdef HighResTime
  795.         getrusage(RUSAGE_SELF, &rusage);
  796.         end_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000;
  797. #else                    /* HighResTime */
  798.         end_infer = millisec();
  799. #endif                    /* HighResTime */
  800.         fprintf(trcfile, "\n**** inferencing time: %ld milliseconds\n", 
  801.            end_infer - start_infer);
  802.         fprintf(trcfile, "\n**** inferencing space: %ld bytes\n",typespace);
  803.         fclose(trcfile);
  804.         }
  805.    typealloc = 0;
  806. #endif                    /* TypTrc */
  807.    }
  808.  
  809. /*
  810.  * find_new - walk the syntax tree allocating structure types where
  811.  *  operations create new structures.
  812.  */
  813. static novalue find_new(n)
  814. struct node *n;
  815.    {
  816.    struct t_coexpr *coexp;
  817.    struct node *cases;
  818.    struct node *clause;
  819.    int nargs;
  820.    int i;
  821.  
  822.    n->new_types = NULL;
  823.    switch (n->n_type) {
  824.       case N_Cset:
  825.       case N_Empty:
  826.       case N_Id:
  827.       case N_Int:
  828.       case N_Next:
  829.       case N_Real:
  830.       case N_Str:
  831.          break;
  832.  
  833.       case N_Bar:
  834.       case N_Break:
  835.       case N_Field:
  836.       case N_Not:
  837.          find_new(Tree0(n));
  838.          break;
  839.  
  840.       case N_Alt:
  841.       case N_Apply:
  842.       case N_Limit:
  843.       case N_Slist:
  844.          find_new(Tree0(n));
  845.          find_new(Tree1(n));
  846.          break;
  847.  
  848.       case N_Activat:
  849.          find_new(Tree1(n));
  850.          find_new(Tree2(n));
  851.          break;
  852.  
  853.       case N_If:
  854.          find_new(Tree0(n));  /* control clause */
  855.          find_new(Tree1(n));  /* then clause */
  856.          find_new(Tree2(n));  /* else clause, may be N_Empty */
  857.          break;
  858.  
  859.       case N_Create:
  860.          /*
  861.           * Allocate a sub-type for the co-expressions created here.
  862.           */
  863.          n->new_types = (int *)alloc((unsigned int)(sizeof(int)));
  864.          n->new_types[0] = type_array[coexp_typ].num_bits++;
  865.          coexp = NewStruct(t_coexpr);
  866.          coexp->n = Tree0(n);
  867.          coexp->next = coexp_lst;
  868.          coexp_lst = coexp;
  869.          find_new(Tree0(n));
  870.          break;
  871.  
  872.       case N_Augop:
  873.          abstr_new(n, Impl0(n)->in_line);  /* assignment */
  874.          abstr_new(n, Impl1(n)->in_line);  /* the operation */
  875.          find_new(Tree2(n));              /* 1st operand */
  876.          find_new(Tree3(n));              /* 2nd operand */
  877.          break;
  878.  
  879.       case N_Case:
  880.          find_new(Tree0(n));  /* control clause */
  881.          cases = Tree1(n);
  882.          while (cases != NULL) {
  883.             if (cases->n_type == N_Ccls) {
  884.                clause = cases;
  885.                cases = NULL;
  886.                }
  887.             else {
  888.                clause = Tree1(cases);
  889.                cases = Tree0(cases);
  890.                }
  891.  
  892.             find_new(Tree0(clause));   /* value of clause */
  893.             find_new(Tree1(clause));   /* body of clause */
  894.             }
  895.          if (Tree2(n) != NULL)
  896.             find_new(Tree2(n));  /* deflt */
  897.          break;
  898.  
  899.       case N_Invok:
  900.          nargs = Val0(n);                  /* number of arguments */
  901.          find_new(Tree1(n));               /* thing being invoked */
  902.          for (i = 1; i <= nargs; ++i)
  903.             find_new(n->n_field[i+1].n_ptr); /* arg i */
  904.          break;
  905.  
  906.       case N_InvOp:
  907.          /*
  908.           * This is a call to an operation, this is what we must
  909.           *  check for "new" abstract type computation.
  910.           */
  911.          nargs = Val0(n);                    /* number of arguments */
  912.          abstr_new(n, Impl1(n)->in_line);     /* operation */
  913.          for (i = 1; i <= nargs; ++i)
  914.             find_new(n->n_field[i+1].n_ptr); /* arg i */
  915.          break;
  916.  
  917.       case N_InvProc:
  918.       case N_InvRec:
  919.          nargs = Val0(n);                    /* number of arguments */
  920.          for (i = 1; i <= nargs; ++i)
  921.             find_new(n->n_field[i+1].n_ptr); /* arg i */
  922.          break;
  923.  
  924.       case N_Loop:
  925.          switch ((int)Val0(Tree0(n))) {
  926.             case EVERY:
  927.             case SUSPEND:
  928.             case WHILE:
  929.             case UNTIL:
  930.                find_new(Tree1(n));   /* control clause */
  931.                find_new(Tree2(n));   /* do clause - may be N_Empty*/
  932.                break;
  933.  
  934.             case REPEAT:
  935.                find_new(Tree1(n));   /* clause */
  936.                break;
  937.             }
  938.  
  939.       case N_Ret:
  940.          if (Val0(Tree0(n)) == RETURN)
  941.             find_new(Tree1(n));    /* value - may be N_Empty */
  942.          break;
  943.  
  944.       case N_Scan:
  945.          if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK)
  946.             abstr_new(n, optab[asgn_loc].binary->in_line);
  947.          find_new(Tree1(n));   /* subject */ 
  948.          find_new(Tree2(n));   /* body */
  949.          break;
  950.  
  951.       case N_Sect:
  952.          abstr_new(n, Impl0(n)->in_line);     /* sectioning */
  953.          if (Impl1(n) != NULL)
  954.             abstr_new(n, Impl1(n)->in_line);  /* plus, minus, or nothing */
  955.          find_new(Tree2(n));                 /* 1st operand */
  956.          find_new(Tree3(n));                 /* 2nd operand */
  957.          find_new(Tree4(n));                 /* 3rd operand */
  958.          break;
  959.  
  960.       case N_SmplAsgn:
  961.       case N_SmplAug:
  962.          find_new(Tree3(n));
  963.          break;
  964.  
  965.       default:
  966.          fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type);
  967.          exit(ErrorExit);
  968.       }
  969.    }
  970.  
  971. /*
  972.  * abstr_new - find the abstract clauses in the implementation of an operation.
  973.  *  If they indicate that the operations creates structures, allocate a
  974.  *  type for the structures and associate it with the node in the syntax tree.
  975.  */
  976. static novalue abstr_new(n, il)
  977. struct node *n;
  978. struct il_code *il;
  979.    {
  980.    int i;
  981.    int num_cases, indx;
  982.    struct typ_info *t_info;
  983.  
  984.    if (il == NULL)
  985.       return;
  986.  
  987.    switch (il->il_type) {
  988.       case IL_New:
  989.          /*
  990.           * We have found a "new" construct in an abstract type computation.
  991.           *  Make sure an array has been created to hold the types allocated
  992.           *  to this call, then allocate the indicated type if one has not
  993.           *  already been allocated.
  994.           */
  995.          if (n->new_types == NULL) {
  996.             n->new_types = (int *)alloc((unsigned int)(num_new * sizeof(int)));
  997.             for (i = 0; i < num_new; ++i)
  998.                n->new_types[i] = -1;
  999.             }
  1000.          t_info = &type_array[il->u[0].n];     /* index by type code */
  1001.          if (n->new_types[t_info->new_indx] < 0) {
  1002.              n->new_types[t_info->new_indx] = t_info->num_bits++;
  1003. #ifdef TypTrc
  1004.              if (trcfile != NULL)
  1005.                 fprintf(trcfile, "%s (%d,%d) %s\n", n->n_file, n->n_line,
  1006.                    n->n_col, icontypes[il->u[0].n].id);
  1007. #endif                    /* TypTrc */
  1008.              }
  1009.          i = il->u[1].n;            /* num args */
  1010.          indx = 2;
  1011.          while (i--)
  1012.             abstr_new(n, il->u[indx++].fld);
  1013.          break;
  1014.  
  1015.       case IL_If1:
  1016.          abstr_new(n, il->u[1].fld);
  1017.          break;
  1018.  
  1019.       case IL_If2:
  1020.          abstr_new(n, il->u[1].fld);
  1021.          abstr_new(n, il->u[2].fld);
  1022.          break;
  1023.  
  1024.       case IL_Tcase1:
  1025.          num_cases = il->u[1].n;
  1026.          indx = 2;
  1027.          for (i = 0; i < num_cases; ++i) {
  1028.             indx += 2;                        /* skip type info */
  1029.             abstr_new(n, il->u[indx++].fld);  /* action */
  1030.             }
  1031.          break;
  1032.  
  1033.       case IL_Tcase2:
  1034.          num_cases = il->u[1].n;
  1035.          indx = 2;
  1036.          for (i = 0; i < num_cases; ++i) {
  1037.             indx += 2;                        /* skip type info */
  1038.             abstr_new(n, il->u[indx++].fld);  /* action */
  1039.             }
  1040.          abstr_new(n, il->u[indx].fld);       /* default */
  1041.          break;
  1042.  
  1043.       case IL_Lcase:
  1044.          num_cases = il->u[0].n;
  1045.          indx = 1;
  1046.          for (i = 0; i < num_cases; ++i) {
  1047.             ++indx;                      /* skip selection num */
  1048.             abstr_new(n, il->u[indx++].fld);  /* action */
  1049.             }
  1050.          abstr_new(n, il->u[indx].fld);       /* default */
  1051.          break;
  1052.  
  1053.       case IL_Acase:
  1054.          abstr_new(n, il->u[2].fld);          /* C_integer action */
  1055.          if (largeints) 
  1056.             abstr_new(n, il->u[3].fld);       /* integer action */
  1057.          abstr_new(n, il->u[4].fld);          /* C_double action */
  1058.          break;
  1059.  
  1060.       case IL_Abstr:
  1061.       case IL_Inter:
  1062.       case IL_Lst:
  1063.       case IL_TpAsgn:
  1064.       case IL_Union:
  1065.          abstr_new(n, il->u[0].fld);
  1066.          abstr_new(n, il->u[1].fld);
  1067.          break;
  1068.  
  1069.       case IL_Compnt:
  1070.       case IL_Store:
  1071.       case IL_VarTyp:
  1072.          abstr_new(n, il->u[0].fld);
  1073.          break;
  1074.  
  1075.       case IL_Block:
  1076.       case IL_Call:
  1077.       case IL_Const:  /* should have been replaced by literal node */
  1078.       case IL_Err1:
  1079.       case IL_Err2:
  1080.       case IL_IcnTyp:
  1081.       case IL_Subscr:
  1082.       case IL_Var:
  1083.          break;
  1084.  
  1085.       default:
  1086.          fprintf(stderr, "compiler error: unknown info in data base\n");
  1087.          exit(ErrorExit);
  1088.       }
  1089.    }
  1090.  
  1091. /*
  1092.  * alloc_stor - allocate a store with empty types.
  1093.  */
  1094. static struct store *alloc_stor(stor_sz, n_types)
  1095. int stor_sz;
  1096. int n_types;
  1097.    {
  1098.    struct store *stor;
  1099.    int i;
  1100.  
  1101.    /*
  1102.     * If type inferencing is disabled, we don't actually make use of
  1103.     *  any stores, but the initialization code asks for them anyway.
  1104.     */
  1105.    if (!do_typinfer)
  1106.       return NULL;
  1107.  
  1108.    stor = (struct store *)alloc((unsigned int)(sizeof(struct store) +
  1109.       ((stor_sz - 1) * sizeof(unsigned int *))));
  1110.    stor->next = NULL;
  1111.    stor->perm = 1;
  1112.    for (i = 0; i < stor_sz; ++i) {
  1113.       stor->types[i] = (unsigned int *)alloc_typ(n_types);
  1114.       }
  1115.    return stor;
  1116.    }
  1117.  
  1118. /*
  1119.  * alloc_typ - allocate a bit vector for a set of basic types.
  1120.  */
  1121. static unsigned int *alloc_typ(n_types)
  1122. int n_types;
  1123.    {
  1124.    int n_ints;
  1125.    unsigned int *typ;
  1126.    int i;
  1127.    unsigned int init = 0;
  1128.  
  1129.    n_ints = NumInts(n_types);
  1130.    typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int)));
  1131.  
  1132.    /*
  1133.     * Initialization: if we are doing inference, start out assuming no types.
  1134.     *  If we are not doing inference, assume any type.
  1135.     */
  1136.    if (!do_typinfer)
  1137.       init = ~init;
  1138.    for (i = 0; i < n_ints; ++i)
  1139.      typ[i] = init; 
  1140.    return typ;
  1141.    }
  1142.  
  1143. /*
  1144.  * set_typ - set a particular type bit in a type bit vector.
  1145.  */
  1146. static novalue set_typ(type, bit)
  1147. unsigned int *type;
  1148. unsigned int bit;
  1149.    {
  1150.    unsigned int indx;
  1151.    unsigned int mask;
  1152.  
  1153.    indx = bit / IntBits;
  1154.    mask = 1;
  1155.    mask <<= bit % IntBits;
  1156.    type[indx] |= mask;
  1157.    }
  1158.  
  1159. /*
  1160.  * clr_type - clear a particular type bit in a type bit vector.
  1161.  */
  1162. static novalue clr_typ(type, bit)
  1163. unsigned int *type;
  1164. unsigned int bit;
  1165.    {
  1166.    unsigned int indx;
  1167.    unsigned int mask;
  1168.  
  1169.    indx = bit / IntBits;
  1170.    mask = 1;
  1171.    mask <<= bit % IntBits;
  1172.    type[indx] &= ~mask;
  1173.    }
  1174.  
  1175. /*
  1176.  * findloops - find both explicit loops and implicit loops caused by
  1177.  *  goal-directed evaluation. Allocate stores for them. Determine which
  1178.  *  expressions cannot fail (used to eliminate dynamic store allocation
  1179.  *  for some bounded expressions). Allocate stores for 'if' and 'case'
  1180.  *  expressions that can be resumed. Initialize expression types.
  1181.  *  The syntax tree is walked in reverse execution order looking for
  1182.  *  failure and for generators.
  1183.  */
  1184. static int findloops(n, resume, rslt_type)
  1185. struct node *n;
  1186. int resume;
  1187. unsigned int *rslt_type;
  1188.    {
  1189.    struct loop {
  1190.       int resume;
  1191.       int can_fail;
  1192.       int every_cntrl;
  1193.       unsigned int *type;
  1194.       struct loop *prev;
  1195.       } loop_info;
  1196.    struct loop *loop_sav;
  1197.    static struct loop *cur_loop = NULL;
  1198.    struct node *cases;
  1199.    struct node *clause;
  1200.    int can_fail;
  1201.    int nargs, i;
  1202.  
  1203.    n->store = NULL;
  1204.    if (!do_typinfer)
  1205.       rslt_type = any_typ;
  1206.  
  1207.    switch (n->n_type) {
  1208.       case N_Activat:
  1209.          if (rslt_type == NULL)
  1210.             rslt_type = alloc_typ(n_intrtyp);
  1211.          n->type = rslt_type;
  1212.          /*
  1213.           * Assume activation can fail.
  1214.           */
  1215.          can_fail = findloops(Tree2(n), 1, NULL);
  1216.          can_fail = findloops(Tree1(n), can_fail, NULL);
  1217.          n->symtyps = symtyps(2);
  1218.          if (optab[Val0(Tree0(n))].tok.t_type == AUGAT)
  1219.             n->symtyps->next = symtyps(2);
  1220.          break;
  1221.  
  1222.       case N_Alt:
  1223.          if (rslt_type == NULL)
  1224.             rslt_type = alloc_typ(n_intrtyp);
  1225.          n->type = rslt_type;
  1226.  
  1227. #ifdef TypTrc
  1228.          rslt_type = NULL;    /* don't share result loc with subexpressions*/
  1229. #endif                    /* TypTrc */
  1230.  
  1231.          if (resume)
  1232.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1233.          can_fail = findloops(Tree0(n), resume, rslt_type) |
  1234.             findloops(Tree1(n), resume, rslt_type);
  1235.          break;
  1236.  
  1237.       case N_Apply:
  1238.          if (rslt_type == NULL)
  1239.             n->type = alloc_typ(n_intrtyp);
  1240.          else
  1241.             n->type = rslt_type;
  1242.          /* 
  1243.           * Assume operation can suspend or fail.
  1244.           */
  1245.          n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1246.          can_fail = findloops(Tree1(n), 1, NULL);
  1247.          can_fail = findloops(Tree0(n), can_fail, NULL);
  1248.          n->symtyps = symtyps(max_sym);
  1249.          break;
  1250.  
  1251.       case N_Augop:
  1252.          if (rslt_type == NULL)
  1253.             rslt_type = alloc_typ(n_intrtyp);
  1254.          n->type = rslt_type;
  1255.  
  1256.          can_fail = resume;
  1257.          /*
  1258.           * Impl0(n) is assignment.
  1259.           */
  1260.          if (resume && Impl0(n)->ret_flag & DoesSusp)
  1261.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1262.          if (MightFail(Impl0(n)->ret_flag))
  1263.             can_fail = 1;
  1264.          /*
  1265.           * Impl1(n) is the augmented operation.
  1266.           */
  1267.          if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL)
  1268.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1269.          if (MightFail(Impl1(n)->ret_flag))
  1270.             can_fail = 1;
  1271.          can_fail = findloops(Tree3(n), can_fail, NULL);  /* operand 2 */
  1272.          can_fail = findloops(Tree2(n), can_fail, NULL);  /* operand 1 */
  1273.          n->type = Tree2(n)->type;
  1274.          Typ4(n) = alloc_typ(n_intrtyp);
  1275.          n->symtyps = symtyps(n_arg_sym(Impl1(n)));
  1276.          n->symtyps->next = symtyps(n_arg_sym(Impl0(n)));
  1277.          break;
  1278.  
  1279.       case N_Bar:
  1280.          can_fail = findloops(Tree0(n), resume, rslt_type);
  1281.          n->type = Tree0(n)->type;
  1282.          n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1283.          break;
  1284.  
  1285.       case N_Break:
  1286.          if (cur_loop == NULL) {
  1287.             nfatal(n, "invalid context for break", NULL);
  1288.             return 0;
  1289.             }
  1290.          if (rslt_type == NULL)
  1291.             n->type = alloc_typ(n_intrtyp);
  1292.          else
  1293.             n->type = rslt_type;
  1294.          loop_sav = cur_loop;
  1295.          cur_loop = cur_loop->prev;
  1296.          loop_sav->can_fail |= findloops(Tree0(n), loop_sav->resume,
  1297.             loop_sav->type);
  1298.          cur_loop = loop_sav;
  1299.          can_fail = 0;
  1300.          break;
  1301.  
  1302.       case N_Case:
  1303.          if (rslt_type == NULL)
  1304.             rslt_type = alloc_typ(n_intrtyp);
  1305.          n->type = rslt_type;
  1306.  
  1307. #ifdef TypTrc
  1308.          rslt_type = NULL;    /* don't share result loc with subexpressions*/
  1309. #endif                    /* TypTrc */
  1310.  
  1311.          if (resume)
  1312.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1313.  
  1314.          /*
  1315.           * control clause is bounded
  1316.           */
  1317.          can_fail = findloops(Tree0(n), 0, NULL);
  1318.  
  1319.          cases = Tree1(n);
  1320.          while (cases != NULL) {
  1321.             if (cases->n_type == N_Ccls) {
  1322.                clause = cases;
  1323.                cases = NULL;
  1324.                }
  1325.             else {
  1326.                clause = Tree1(cases);
  1327.                cases = Tree0(cases);
  1328.                }
  1329.  
  1330.             /*
  1331.              * The expression being compared can be resumed.
  1332.              */
  1333.             findloops(Tree0(clause), 1, NULL);
  1334.  
  1335.             /*
  1336.              *  Body.
  1337.              */
  1338.             can_fail |= findloops(Tree1(clause), resume, rslt_type);
  1339.             }
  1340.  
  1341.          if (Tree2(n) == NULL)
  1342.             can_fail = 1;
  1343.          else
  1344.             can_fail |= findloops(Tree2(n), resume, rslt_type);  /* default */
  1345.          break;
  1346.  
  1347.       case N_Create:
  1348.          if (rslt_type == NULL)
  1349.             n->type = alloc_typ(n_intrtyp);
  1350.          else
  1351.             n->type = rslt_type;
  1352.          findloops(Tree0(n), 1, NULL);                  /* co-expression code */
  1353.         /*
  1354.          * precompute type
  1355.          */
  1356.         i= type_array[coexp_typ].frst_bit;
  1357.         if (do_typinfer)
  1358.             i += n->new_types[0];
  1359.          set_typ(n->type, i);
  1360.          can_fail = resume;
  1361.          break;
  1362.  
  1363.       case N_Cset:
  1364.          if (rslt_type == NULL)
  1365.             n->type = alloc_typ(n_intrtyp);
  1366.          else
  1367.             n->type = rslt_type;
  1368.          set_typ(n->type, type_array[cset_typ].frst_bit); /* precompute type */
  1369.          can_fail = resume;
  1370.          break;
  1371.  
  1372.       case N_Empty:
  1373.          if (rslt_type == NULL)
  1374.             n->type = alloc_typ(n_intrtyp);
  1375.          else
  1376.             n->type = rslt_type;
  1377.          set_typ(n->type, null_bit); /* precompute type */
  1378.          can_fail = resume;
  1379.          break;
  1380.  
  1381.       case N_Id: {
  1382.          struct lentry *var;
  1383.  
  1384.          if (rslt_type == NULL)
  1385.             n->type = alloc_typ(n_intrtyp);
  1386.          else
  1387.             n->type = rslt_type;
  1388.          /*
  1389.           * Precompute type
  1390.           */
  1391.          var = LSym0(n);
  1392.          if (var->flag & F_Global)
  1393.             set_typ(n->type, frst_gbl + var->val.global->index);
  1394.          else if (var->flag & F_Static)
  1395.             set_typ(n->type, frst_gbl + var->val.index);
  1396.          else
  1397.             set_typ(n->type, frst_loc + var->val.index);
  1398.          can_fail = resume;
  1399.          }
  1400.          break;
  1401.  
  1402.       case N_Field:
  1403.          if (rslt_type == NULL)
  1404.             n->type = alloc_typ(n_intrtyp);
  1405.          else
  1406.             n->type = rslt_type;
  1407.          can_fail = findloops(Tree0(n), resume, NULL);
  1408.          n->symtyps = symtyps(1);
  1409.          break;
  1410.  
  1411.       case N_If:
  1412.          if (rslt_type == NULL)
  1413.             rslt_type = alloc_typ(n_intrtyp);
  1414.          n->type = rslt_type;
  1415.  
  1416. #ifdef TypTrc
  1417.          rslt_type = NULL;    /* don't share result loc with subexpressions*/
  1418. #endif                    /* TypTrc */
  1419.          /*
  1420.           * control clause is bounded
  1421.           */
  1422.          findloops(Tree0(n), 0, NULL);
  1423.          can_fail = findloops(Tree1(n), resume, rslt_type);
  1424.          if (Tree2(n)->n_type == N_Empty)
  1425.             can_fail = 1;
  1426.          else {
  1427.             if (resume)
  1428.                n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1429.             can_fail |= findloops(Tree2(n), resume, rslt_type);
  1430.             }
  1431.          break;
  1432.  
  1433.       case N_Int:
  1434.          if (rslt_type == NULL)
  1435.             n->type = alloc_typ(n_intrtyp);
  1436.          else
  1437.             n->type = rslt_type;
  1438.          set_typ(n->type, int_bit); /* precompute type */
  1439.          can_fail = resume;
  1440.          break;
  1441.  
  1442.       case N_Invok:
  1443.          if (rslt_type == NULL)
  1444.             n->type = alloc_typ(n_intrtyp);
  1445.          else
  1446.             n->type = rslt_type;
  1447.          nargs = Val0(n);                    /* number of arguments */
  1448.          /*
  1449.           * Assume operation can suspend and fail.
  1450.           */
  1451.          if (resume)
  1452.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1453.          can_fail = 1;
  1454.          for (i = nargs; i >= 0; --i)
  1455.             can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL);
  1456.          n->symtyps = symtyps(max_sym);
  1457.          break;
  1458.  
  1459.       case N_InvOp:
  1460.          if (rslt_type == NULL)
  1461.             n->type = alloc_typ(n_intrtyp);
  1462.          else
  1463.             n->type = rslt_type;
  1464.          nargs = Val0(n);                           /* number of arguments */
  1465.          if (resume && Impl1(n)->ret_flag & DoesSusp)
  1466.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1467.          if (MightFail(Impl1(n)->ret_flag))
  1468.             can_fail = 1;
  1469.          else
  1470.             can_fail = resume;
  1471.          for (i = nargs; i >= 1; --i)
  1472.             can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL);
  1473.          n->symtyps = symtyps(n_arg_sym(Impl1(n)));
  1474.          break;
  1475.  
  1476.       case N_InvProc:
  1477.          if (rslt_type == NULL)
  1478.             n->type = alloc_typ(n_intrtyp);
  1479.          else
  1480.             n->type = rslt_type;
  1481.          nargs = Val0(n);             /* number of arguments */
  1482.          if (resume && Proc1(n)->ret_flag & DoesSusp)
  1483.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1484.          if (Proc1(n)->ret_flag & DoesFail)
  1485.             can_fail = 1;
  1486.          else
  1487.             can_fail = resume;
  1488.          for (i = nargs; i >= 1; --i)
  1489.             can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL);
  1490.          break;
  1491.  
  1492.       case N_InvRec:
  1493.          if (rslt_type == NULL)
  1494.             n->type = alloc_typ(n_intrtyp);
  1495.          else
  1496.             n->type = rslt_type;
  1497.          nargs = Val0(n);                               /* number of args */
  1498.          if (err_conv)
  1499.             can_fail = 1;
  1500.          else
  1501.             can_fail = resume;
  1502.          for (i = nargs; i >= 1; --i)
  1503.             can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL);
  1504.          break;
  1505.  
  1506.       case N_Limit:
  1507.          findloops(Tree0(n), resume, rslt_type);
  1508.          can_fail = findloops(Tree1(n), 1, NULL);
  1509.          n->type = Tree0(n)->type;
  1510.          n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1511.          n->symtyps = symtyps(1);
  1512.          break;
  1513.  
  1514.       case N_Loop: {
  1515.          if (rslt_type == NULL)
  1516.             n->type = alloc_typ(n_intrtyp);
  1517.          else
  1518.             n->type = rslt_type;
  1519.          loop_info.prev = cur_loop;
  1520.          loop_info.resume = resume;
  1521.          loop_info.can_fail = 0;
  1522.          loop_info.every_cntrl = 0;
  1523.          loop_info.type = n->type;
  1524.          cur_loop = &loop_info;
  1525.          switch ((int)Val0(Tree0(n))) {
  1526.             case EVERY:
  1527.             case SUSPEND:
  1528.                /*
  1529.                 * The control clause can be resumed. The body is bounded.
  1530.                 */
  1531.                loop_info.every_cntrl = 1;
  1532.                can_fail = findloops(Tree1(n), 1, NULL);
  1533.                loop_info.every_cntrl = 0;
  1534.                findloops(Tree2(n), 0, NULL);
  1535.                break;
  1536.  
  1537.             case REPEAT:
  1538.                /*
  1539.                 * The loop needs a saved store. The body is bounded.
  1540.                 */
  1541.                findloops(Tree1(n), 0, NULL);
  1542.                can_fail = 0;
  1543.                break;
  1544.  
  1545.             case WHILE:
  1546.                /*
  1547.                 * The loop needs a saved store. The control
  1548.                 *  clause and the body are each bounded.
  1549.                 */
  1550.                can_fail = findloops(Tree1(n), 0, NULL);
  1551.                findloops(Tree2(n), 0, NULL);
  1552.                break;
  1553.  
  1554.             case UNTIL:
  1555.                /*
  1556.                 * The loop needs a saved store. The control
  1557.                 *  clause and the body are each bounded.
  1558.                 */
  1559.                findloops(Tree1(n), 0, NULL);
  1560.                findloops(Tree2(n), 0, NULL);
  1561.                can_fail = 1;
  1562.                break;
  1563.             }
  1564.          n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1565.          if (do_typinfer && resume)
  1566.             n->store->next = alloc_stor(n_gbl + n_loc, n_icntyp);
  1567.          can_fail |= cur_loop->can_fail;
  1568.          cur_loop = cur_loop->prev;
  1569.          }
  1570.          break;
  1571.  
  1572.       case N_Next:
  1573.          if (cur_loop == NULL) {
  1574.             nfatal(n, "invalid context for next", NULL);
  1575.             return 1;
  1576.             }
  1577.          if (rslt_type == NULL)
  1578.             n->type = alloc_typ(n_intrtyp);
  1579.          else
  1580.             n->type = rslt_type;
  1581.          can_fail = cur_loop->every_cntrl;
  1582.          break;
  1583.  
  1584.       case N_Not:
  1585.          if (rslt_type == NULL)
  1586.             n->type = alloc_typ(n_intrtyp);
  1587.          else
  1588.             n->type = rslt_type;
  1589.          set_typ(n->type, null_bit); /* precompute type */
  1590.          /*
  1591.           * The expression is bounded.
  1592.           */
  1593.          findloops(Tree0(n), 0, NULL);
  1594.          can_fail = 1;
  1595.          break;
  1596.  
  1597.       case N_Real:
  1598.          if (rslt_type == NULL)
  1599.             n->type = alloc_typ(n_intrtyp);
  1600.          else
  1601.             n->type = rslt_type;
  1602.          set_typ(n->type, real_bit); /* precompute type */
  1603.          can_fail = resume;
  1604.          break;
  1605.  
  1606.       case N_Ret:
  1607.          if (rslt_type == NULL)
  1608.             n->type = alloc_typ(n_intrtyp);
  1609.          else
  1610.             n->type = rslt_type;
  1611.          if (Val0(Tree0(n)) == RETURN)  {
  1612.             /*
  1613.              * The expression is bounded.
  1614.              */
  1615.             findloops(Tree1(n), 0, NULL);
  1616.             }
  1617.          can_fail = 0;
  1618.          break;
  1619.  
  1620.       case N_Scan: {
  1621.          struct implement *asgn_impl;
  1622.  
  1623.          if (rslt_type == NULL)
  1624.             n->type = alloc_typ(n_intrtyp);
  1625.          else
  1626.             n->type = rslt_type;
  1627.          n->symtyps = symtyps(1);
  1628.          can_fail = resume;
  1629.          if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) {
  1630.             asgn_impl = optab[asgn_loc].binary;
  1631.             if (resume && asgn_impl->ret_flag & DoesSusp)
  1632.                n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1633.             if (MightFail(asgn_impl->ret_flag))
  1634.                can_fail = 1;
  1635.             n->symtyps->next = symtyps(n_arg_sym(asgn_impl));
  1636.             }
  1637.          can_fail = findloops(Tree2(n), can_fail, NULL);  /* body */
  1638.          can_fail = findloops(Tree1(n), can_fail, NULL);  /* subject */ 
  1639.          }
  1640.          break;
  1641.  
  1642.       case N_Sect:
  1643.          if (rslt_type == NULL)
  1644.             n->type = alloc_typ(n_intrtyp);
  1645.          else
  1646.             n->type = rslt_type;
  1647.          can_fail = resume;
  1648.          /*
  1649.           * Impl0(n) is sectioning.
  1650.           */
  1651.          if (resume && Impl0(n)->ret_flag & DoesSusp)
  1652.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1653.          if (MightFail(Impl0(n)->ret_flag))
  1654.             can_fail = 1;
  1655.          n->symtyps = symtyps(n_arg_sym(Impl0(n)));
  1656.          if (Impl1(n) != NULL) {
  1657.             /*
  1658.              * Impl1(n) is plus or minus
  1659.              */
  1660.             if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL)
  1661.                n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1662.             if (MightFail(Impl1(n)->ret_flag))
  1663.                can_fail = 1;
  1664.             n->symtyps->next = symtyps(n_arg_sym(Impl1(n)));
  1665.             }
  1666.          can_fail = findloops(Tree4(n), can_fail, NULL); /* operand 3 */
  1667.          can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */
  1668.          can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */
  1669.          break;
  1670.  
  1671.       case N_Slist:
  1672.          /*
  1673.           * 1st expression is bounded.
  1674.           */
  1675.          findloops(Tree0(n), 0, NULL);
  1676.          can_fail = findloops(Tree1(n), resume, rslt_type);
  1677.          n->type = Tree1(n)->type;
  1678.          break;
  1679.  
  1680.       case N_SmplAsgn:
  1681.          can_fail = findloops(Tree3(n), resume, NULL);  /* 2nd operand */
  1682.          findloops(Tree2(n), can_fail, rslt_type);      /* variable */
  1683.          n->type = Tree2(n)->type;
  1684.          break;
  1685.  
  1686.       case N_SmplAug:
  1687.          can_fail = resume;
  1688.          /*
  1689.           * Impl1(n) is the augmented operation.
  1690.           */
  1691.          if (resume && Impl1(n)->ret_flag & DoesSusp)
  1692.             n->store = alloc_stor(n_gbl + n_loc, n_icntyp);
  1693.          if (MightFail(Impl1(n)->ret_flag))
  1694.             can_fail = 1;
  1695.          can_fail = findloops(Tree3(n), can_fail, NULL); /* 2nd operand */
  1696.          findloops(Tree2(n), can_fail, rslt_type);       /* variable */
  1697.          n->symtyps = symtyps(n_arg_sym(Impl1(n)));
  1698.          n->type = Tree2(n)->type;
  1699.          Typ4(n) = alloc_typ(n_intrtyp);
  1700.          break;
  1701.  
  1702.       case N_Str:
  1703.          if (rslt_type == NULL)
  1704.             n->type = alloc_typ(n_intrtyp);
  1705.          else
  1706.             n->type = rslt_type;
  1707.          set_typ(n->type, str_bit); /* precompute type */
  1708.          can_fail = resume;
  1709.          break;
  1710.  
  1711.       default:
  1712.          fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type);
  1713.          exit(ErrorExit);
  1714.       }
  1715.    if (can_fail)
  1716.       n->flag = CanFail;
  1717.    else
  1718.       n->flag = 0;
  1719.    return can_fail;
  1720.    }
  1721.  
  1722. /*
  1723.  * symtyps - determine the number of entries needed for a symbol table
  1724.  *  that maps argument indexes to types for an operation in the
  1725.  *  data base. Allocate the symbol table.
  1726.  */
  1727. static struct symtyps *symtyps(nsyms)
  1728. int nsyms;
  1729.    {
  1730.    struct symtyps *tab;
  1731.  
  1732.    if (nsyms == 0)
  1733.       return NULL;
  1734.    tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) +
  1735.       (nsyms - 1) * sizeof(int *)));
  1736.    tab->nsyms = nsyms;
  1737.    tab->next = NULL;
  1738.    while (nsyms)
  1739.       tab->types[--nsyms] = alloc_typ(n_intrtyp);
  1740.    return tab;
  1741.    }
  1742.  
  1743. /*
  1744.  * infer_proc - perform type inference on a call to an Icon procedure.
  1745.  */
  1746. static novalue infer_prc(proc, n)
  1747. struct pentry *proc;
  1748. nodeptr n;
  1749.    {
  1750.    struct store *s_store;
  1751.    struct store *f_store;
  1752.    struct store *store;
  1753.    struct pentry *sv_proc;
  1754.    struct t_coexpr *sv_coexp;
  1755.    struct lentry *lptr;
  1756.    nodeptr n1;
  1757.    int i;
  1758.    int nparams;
  1759.    int coexp_bit;
  1760.  
  1761.    /*
  1762.     * Determine what co-expressions the procedure might be called from.
  1763.     */
  1764.    if (cur_coexp == NULL)
  1765.       ChkMrgTyp(n_icntyp, cur_proc->coexprs, proc->coexprs)
  1766.    else {
  1767.       coexp_bit = type_array[coexp_typ].frst_bit + cur_coexp->typ_indx;
  1768.       if (!bitset(proc->coexprs, coexp_bit)) {
  1769.          ++changed;
  1770.          set_typ(proc->coexprs, coexp_bit);
  1771.          }
  1772.       }
  1773.  
  1774.    proc->reachable = 1; /* this procedure can be called */
  1775.  
  1776.    /*
  1777.     * If this procedure can suspend, there may be backtracking paths
  1778.     *  to this invocation. If so, propagate types of globals from the
  1779.     *  backtracking paths to the suspends of the procedure and propagate
  1780.     *  types of locals to the success store of the call.
  1781.     */
  1782.    if (proc->ret_flag & DoesSusp && n->store != NULL) {
  1783.       for (i = 0; i < n_gbl; ++i)
  1784.          ChkMrgTyp(n_icntyp, n->store->types[i], proc->susp_store->types[i])
  1785.       for (i = 0; i < n_loc; ++i)
  1786.          MrgTyp(n_icntyp, n->store->types[n_gbl + i], succ_store->types[n_gbl +
  1787.             i])
  1788.       }
  1789.  
  1790.    /*
  1791.     * Merge the types of global variables into the "in store" of the
  1792.     *  procedure. Because the body of the procedure may already have
  1793.     *  been processed for this pass, the "changed" flag must be set if
  1794.     *  there is a change of type in the store. This will insure that
  1795.     *  there will be another iteration in which to propagate the change
  1796.     *  into the body.
  1797.     */
  1798.    store = proc->in_store;
  1799.    for (i = 0; i < n_gbl; ++i)
  1800.       ChkMrgTyp(n_icntyp, succ_store->types[i], store->types[i])
  1801.  
  1802. #ifdef TypTrc
  1803.    /*
  1804.     * Trace the call.
  1805.     */
  1806.    if (trcfile != NULL)
  1807.       fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col,
  1808.          trc_indent, proc->name);
  1809. #endif                    /* TypTrc */
  1810.  
  1811.    /*
  1812.     * Get the types of the arguments, starting with the non-varargs part.
  1813.     */
  1814.    nparams = proc->nargs;               /* number of parameters */
  1815.    if (nparams < 0)
  1816.       nparams = -nparams - 1;
  1817.    for (i = 0; i < num_args && i < nparams; ++i) {
  1818.       typ_deref(arg_typs->types[i], store->types[n_gbl + i], 1);
  1819.  
  1820. #ifdef TypTrc
  1821.       if (trcfile != NULL) {
  1822.          /*
  1823.           * Trace the argument type to the call.
  1824.           */
  1825.          if (i > 0)
  1826.             fprintf(trcfile, ", ");
  1827.          prt_d_typ(trcfile, arg_typs->types[i]);
  1828.          }
  1829. #endif                    /* TypTrc */
  1830.  
  1831.       }
  1832.  
  1833.    /*
  1834.     * Get the type of the varargs part of the argument list.
  1835.     */
  1836.    if (proc->nargs < 0)
  1837.       while (i < num_args) {
  1838.          typ_deref(arg_typs->types[i],
  1839.             compnt_array[lst_elem].store->types[proc->arg_lst], 1);
  1840.  
  1841. #ifdef TypTrc
  1842.          if (trcfile != NULL) {
  1843.             /*
  1844.              * Trace the argument type to the call.
  1845.              */
  1846.             if (i > 0)
  1847.                fprintf(trcfile, ", ");
  1848.             prt_d_typ(trcfile, arg_typs->types[i]);
  1849.             }
  1850. #endif                    /* TypTrc */
  1851.  
  1852.          ++i;
  1853.          }
  1854.  
  1855.    /*
  1856.     * Missing arguments have the null type.
  1857.     */
  1858.    while (i < nparams) {
  1859.       set_typ(store->types[n_gbl + i], null_bit);
  1860.       ++i;
  1861.       }
  1862.  
  1863. #ifdef TypTrc
  1864.    if (trcfile != NULL)
  1865.       fprintf(trcfile, ")\n");
  1866.    {
  1867.       char *trc_ind_sav = trc_indent;
  1868.       trc_indent = "";  /* staring a new procedure, don't indent tracing */
  1869. #endif                    /* TypTrc */
  1870.  
  1871.    /*
  1872.     * only perform type inference on the body of a procedure
  1873.     *  once per iteration
  1874.     */
  1875.    if (proc->iteration < iteration) {
  1876.       proc->iteration = iteration;
  1877.       s_store = succ_store;
  1878.       f_store = fail_store;
  1879.       sv_proc = cur_proc;
  1880.       succ_store = cpy_store(proc->in_store);
  1881.       cur_proc = proc;
  1882.       sv_coexp = cur_coexp;
  1883.       cur_coexp = NULL;     /* we are not in a create expression */
  1884.       /*
  1885.        * Perform type inference on the initial clause. Static variables
  1886.        *  are initialized to null on this path.
  1887.        */
  1888.       for (lptr = proc->statics; lptr != NULL; lptr = lptr->next)
  1889.          set_typ(succ_store->types[lptr->val.index], null_bit);
  1890.       n1 = Tree1(proc->tree);
  1891.       if (n1->flag & CanFail) {
  1892.          /*
  1893.           * The initial clause can fail. Because it is bounded, we need
  1894.           *  a new failure store that we can merge into the success store
  1895.           *  at the end of the clause.
  1896.           */
  1897.          store = get_store(1);
  1898.          fail_store = store;
  1899.          infer_nd(n1);
  1900.          mrg_store(store, succ_store);
  1901.          free_store(store);
  1902.          }
  1903.       else
  1904.          infer_nd(n1);
  1905.       /*
  1906.        * Perform type inference on the body of procedure. Execution may
  1907.        *  pass directly to it without executing initial clause.
  1908.        */
  1909.       mrg_store(proc->in_store, succ_store);
  1910.       n1 = Tree2(proc->tree);
  1911.       if (n1->flag & CanFail) {
  1912.          /*
  1913.           * The body can fail. Because it is bounded, we need a new failure
  1914.           *  store that we can merge into the success store at the end of
  1915.           *  the procedure.
  1916.           */
  1917.          store = get_store(1);
  1918.          fail_store = store;
  1919.          infer_nd(n1);
  1920.          mrg_store(store, succ_store);
  1921.          free_store(store);
  1922.          }
  1923.       else
  1924.          infer_nd(n1);
  1925.       set_ret(NULL);  /* implicit fail */
  1926.       free_store(succ_store);
  1927.       succ_store = s_store;
  1928.       fail_store = f_store;
  1929.       cur_proc = sv_proc;
  1930.       cur_coexp = sv_coexp;
  1931.       }
  1932.  
  1933. #ifdef TypTrc
  1934.       trc_indent = trc_ind_sav;
  1935.    }
  1936. #endif                    /* TypTrc */
  1937.  
  1938.    /*
  1939.     * Get updated types for global variables at the end of the call.
  1940.     */
  1941.    store = proc->out_store;
  1942.    for (i = 0; i < n_gbl; ++i)
  1943.       CpyTyp(n_icntyp, store->types[i], succ_store->types[i]);
  1944.  
  1945.    /*
  1946.     * If the procedure can fail, merge variable types into the failure
  1947.     *  store.
  1948.     */
  1949.    if (proc->ret_flag & DoesFail)
  1950.       mrg_store(succ_store, fail_store);
  1951.  
  1952.    /*
  1953.     * The return type of the procedure is the result type of the call.
  1954.     */
  1955.    MrgTyp(n_intrtyp, proc->ret_typ, n->type);
  1956.    }
  1957.  
  1958. /*
  1959.  * cpy_store - make a copy of a store.
  1960.  */
  1961. static struct store *cpy_store(source)
  1962. struct store *source;
  1963.    {
  1964.    struct store *dest;
  1965.    int stor_sz;
  1966.    int i;
  1967.  
  1968.    if (source == NULL) 
  1969.       dest = get_store(1);
  1970.    else {
  1971.       stor_sz = n_gbl + n_loc;
  1972.       dest = get_store(0);
  1973.       for (i = 0; i < stor_sz; ++i)
  1974.          CpyTyp(n_icntyp, source->types[i], dest->types[i])
  1975.       }
  1976.    return dest;
  1977.    }
  1978.  
  1979. /*
  1980.  * mrg_store - merge the source store into the destination store.
  1981.  */
  1982. static novalue mrg_store(source, dest)
  1983. struct store *source;
  1984. struct store *dest;
  1985.    {
  1986.    int i;
  1987.  
  1988.    if (source == NULL)
  1989.       return;
  1990.  
  1991.    /*
  1992.     * Is this store included in the state that must be checked for a fixed
  1993.     *  point?
  1994.     */
  1995.    if (dest->perm) {
  1996.       for (i = 0; i < n_gbl + n_loc; ++i)
  1997.          ChkMrgTyp(n_icntyp, source->types[i], dest->types[i])
  1998.       }
  1999.    else {
  2000.       for (i = 0; i < n_gbl + n_loc; ++i)
  2001.          MrgTyp(n_icntyp, source->types[i], dest->types[i])
  2002.       }
  2003.    }
  2004.  
  2005. /*
  2006.  * set_ret - Save return type and the store for global variables.
  2007.  */
  2008. static novalue set_ret(typ)
  2009. unsigned int *typ;
  2010.    {
  2011.    int i;
  2012.  
  2013.    /*
  2014.     * Merge the return type into the type of the procedure, dereferencing
  2015.     *  locals in the process.
  2016.     */
  2017.    if (typ != NULL)
  2018.       deref_lcl(typ, cur_proc->ret_typ);
  2019.  
  2020.    /*
  2021.     * Update the types that variables may have upon exit of the procedure.
  2022.     */
  2023.    for (i = 0; i < n_gbl; ++i)
  2024.       MrgTyp(n_icntyp, succ_store->types[i], cur_proc->out_store->types[i]);
  2025.    }
  2026.  
  2027. /*
  2028.  * deref_lcl - dereference local variable sub-types.
  2029.  */
  2030. static novalue deref_lcl(src, dest)
  2031. unsigned int *src;
  2032. unsigned int *dest;
  2033.    {
  2034.    int i, j;
  2035.    int ref_gbl;
  2036.    int frst_stv;
  2037.    int num_stv;
  2038.    struct store *stv_stor;
  2039.    struct type *wktyp;
  2040.  
  2041.    /*
  2042.     * Make a copy of the type to be dereferenced.
  2043.     */
  2044.    wktyp = get_wktyp();
  2045.    CpyTyp(n_intrtyp, src, wktyp->bits);
  2046.  
  2047.    /*
  2048.     * Determine which variable types must be dereferenced.  Merge the
  2049.     *  dereferenced type into the return type and delete the variable
  2050.     *  type. Start with simple local variables.
  2051.     */
  2052.    for (i = 0; i < n_loc; ++i)
  2053.       if (bitset(wktyp->bits, frst_loc + i)) {
  2054.          MrgTyp(n_icntyp, succ_store->types[n_gbl + i], wktyp->bits)
  2055.          clr_typ(wktyp->bits, frst_loc + i);
  2056.          }
  2057.  
  2058.    /*
  2059.     * Check for substring trapped variables. If a sub-string trapped
  2060.     *  variable references a local, add "string" to the return type.
  2061.     *  If a sub-string trapped variable references a global, leave the
  2062.     *  trapped variable in the return type.
  2063.     * It is theoretically possible for a sub-string trapped variable type to
  2064.     *  reference both a local and a global. When the trapped variable type
  2065.     *  is returned to the calling procedure, the local is re-interpreted
  2066.     *  as a local of that procedure. This is a "valid" overestimate of
  2067.     *  of the semantics of the return. Because this is unlikely to occur
  2068.     *  in real programs, the overestimate is of no practical consequence.
  2069.     */
  2070.    num_stv = type_array[stv_typ].num_bits;
  2071.    frst_stv = type_array[stv_typ].frst_bit;
  2072.    stv_stor = compnt_array[str_var].store;
  2073.    for (i = 0; i < num_stv; ++i) {
  2074.       if (bitset(wktyp->bits, frst_stv + i)) {
  2075.          /*
  2076.           * We have found substring trapped variable i, see whether it
  2077.           *  references locals or globals. Globals include structure
  2078.           *  element references.
  2079.           */
  2080.          for (j = 0; j < n_loc; ++j)
  2081.             if (bitset(stv_stor->types[i], frst_loc + j)) {
  2082.                set_typ(wktyp->bits, str_bit);
  2083.                break;
  2084.                }
  2085.          ref_gbl = 0;
  2086.          for (j = n_icntyp; j < frst_loc; ++j)
  2087.             if (bitset(stv_stor->types[i], j)) {
  2088.                ref_gbl = 1;
  2089.                break;
  2090.                }
  2091.          /*
  2092.           * Keep the trapped variable only if it references globals.
  2093.           */
  2094.          if (!ref_gbl)
  2095.             clr_typ(wktyp->bits, frst_stv + i);
  2096.          }
  2097.       }
  2098.  
  2099.    /*
  2100.     * Merge the types into the destination.
  2101.     */
  2102.    MrgTyp(n_intrtyp, wktyp->bits, dest);
  2103.  
  2104. #ifdef TypTrc
  2105.    if (trcfile != NULL) {
  2106.       prt_typ(trcfile, wktyp->bits);
  2107.       fprintf(trcfile, "\n");
  2108.       }
  2109. #endif                    /* TypTrc */
  2110.  
  2111.    free_wktyp(wktyp);
  2112.    }
  2113.  
  2114. /*
  2115.  * get_store - get a store large enough to hold globals and locals.
  2116.  */
  2117. static struct store *get_store(clear)
  2118. int clear;
  2119.    {
  2120.    struct store *store;
  2121.    int store_sz;
  2122.    int i;
  2123.  
  2124.    /*
  2125.     * Warning, stores for all procedures must be the same size. In some
  2126.     *  situations involving sub-string trapped variables (for example
  2127.     *  when using the "default" trapped variable) a referenced local variable
  2128.     *  type may be interpreted in a procedure to which it does not belong.
  2129.     *  This represents an impossible execution and type inference may
  2130.     *  "legally" produce any results for this part of the abstract
  2131.     *  interpretation. As long as the store is large enough to include any
  2132.     *  such "impossible" variables, type inference will do something legal.
  2133.     *  Note that n_loc is the maximum number of locals in any procedure,
  2134.     *  so store_sz is large enough.
  2135.     */
  2136.    store_sz = n_gbl + n_loc;
  2137.    if ((store = store_pool) == NULL) {
  2138.      store = alloc_stor(store_sz, n_icntyp);
  2139.      store->perm = 0;
  2140.      }
  2141.    else {
  2142.       store_pool = store_pool->next;
  2143.       /*
  2144.        * See if the variables in the store should be initialized to the
  2145.        *  empty type.
  2146.        */
  2147.       if (clear)
  2148.          for (i = 0; i < store_sz; ++i)
  2149.             ClrTyp(n_icntyp, store->types[i]);
  2150.       }
  2151.    return store;
  2152.    }
  2153.  
  2154. static novalue free_store(store)
  2155. struct store *store;
  2156.    {
  2157.    store->next = store_pool;
  2158.    store_pool = store;
  2159.    }
  2160.  
  2161. /*
  2162.  * infer_nd - perform type inference on a subtree of the syntax tree.
  2163.  */
  2164. static novalue infer_nd(n)
  2165. nodeptr n;
  2166.    {
  2167.    struct node *cases;
  2168.    struct node *clause;
  2169.    struct store *s_store;
  2170.    struct store *f_store;
  2171.    struct store *store;
  2172.    struct loop {
  2173.       struct store *succ_store;
  2174.       struct store *fail_store;
  2175.       struct store *next_store;
  2176.       struct store *susp_store;
  2177.       struct loop *prev;
  2178.       } loop_info;
  2179.    struct loop *loop_sav;
  2180.    static struct loop *cur_loop;
  2181.    struct argtyps *sav_argtyp;
  2182.    int sav_nargs;
  2183.    struct type *wktyp;
  2184.    int i;
  2185.  
  2186.    switch (n->n_type) {
  2187.       case N_Activat:
  2188.          infer_act(n);
  2189.          break;
  2190.  
  2191.       case N_Alt:
  2192.          f_store = fail_store;
  2193.          store = get_store(1);
  2194.          fail_store = store;
  2195.          infer_nd(Tree0(n));              /* 1st alternative */
  2196.  
  2197.          /*
  2198.           * "Correct" type inferencing of alternation has a performance
  2199.           *  problem. Propagating stores through nested alternation
  2200.           *  requires as many iterations as the depth of the nesting.
  2201.           *  This is solved by adding two edges to the flow graph. These
  2202.           *  represent impossible execution paths but this does not
  2203.           *  affect the soundness of type inferencing and, in "real"
  2204.           *  programs, does not affect the preciseness of its inference.
  2205.           *  One edge is directly from the 1st alternative to the 2nd.
  2206.           *  The other is a backtracking edge immediately back into
  2207.           *  the alternation from the 1st alternative.
  2208.           */
  2209.          mrg_store(succ_store, store); /* imaginary edge to 2nd alternative */
  2210.  
  2211.          if (n->store != NULL) {
  2212.             mrg_store(succ_store, n->store); /* imaginary backtracking edge */
  2213.             mrg_store(n->store, fail_store);
  2214.             }
  2215.          s_store = succ_store;
  2216.          succ_store = store;
  2217.          fail_store = f_store;
  2218.          infer_nd(Tree1(n));              /* 2nd alternative */
  2219.          mrg_store(s_store, succ_store);
  2220.          free_store(s_store);
  2221.          if (n->store != NULL)
  2222.             mrg_store(n->store, fail_store);
  2223.          fail_store = n->store;
  2224. #ifdef TypTrc
  2225.          MrgTyp(n_intrtyp, Tree0(n)->type, n->type);
  2226.          MrgTyp(n_intrtyp, Tree1(n)->type, n->type);
  2227. #else                    /* TypTrc */
  2228.          /*
  2229.           * Type is computed by sub-expressions directly into n->type.
  2230.           */
  2231. #endif                    /* TypTrc */
  2232.          break;
  2233.  
  2234.       case N_Apply: {
  2235.          struct type *lst_types;
  2236.          int frst_lst;
  2237.          int num_lst;
  2238.          struct store *lstel_stor;
  2239.  
  2240.          infer_nd(Tree0(n));          /* thing being invoked */
  2241.          infer_nd(Tree1(n));          /* list */
  2242.  
  2243.          frst_lst = type_array[list_typ].frst_bit;
  2244.          num_lst = type_array[list_typ].num_bits;
  2245.          lstel_stor = compnt_array[lst_elem].store;
  2246.  
  2247.          /*
  2248.           * All that is available is a "summary" of the types of the
  2249.           *  elements of the list. Each argument to the invocation
  2250.           *  could be any type in the summary. Set up a maximum length
  2251.           *  argument list.
  2252.           */
  2253.          lst_types = get_wktyp();
  2254.          typ_deref(Tree1(n)->type, lst_types->bits, 0);
  2255.          wktyp = get_wktyp();
  2256.          for (i = 0; i < num_lst; ++i)
  2257.             if (bitset(lst_types->bits, frst_lst + i))
  2258.                MrgTyp(n_icntyp, lstel_stor->types[i], wktyp->bits);
  2259.          bitset(wktyp->bits, null_bit); /* arg list extension might be done */
  2260.  
  2261.          sav_nargs = num_args;
  2262.          sav_argtyp = arg_typs;
  2263.          num_args = max_prm;
  2264.          arg_typs = get_argtyp();
  2265.          for (i = 0; i < max_prm; ++i)
  2266.             arg_typs->types[i] = wktyp->bits;
  2267.          gen_inv(Tree0(n)->type, n);   /* inference on general invocation */
  2268.  
  2269.          free_wktyp(wktyp);
  2270.          free_wktyp(lst_types);
  2271.          free_argtyp(arg_typs);
  2272.          arg_typs = sav_argtyp;
  2273.          num_args = sav_nargs;
  2274.          }
  2275.          break;
  2276.  
  2277.       case N_Augop:
  2278.          infer_nd(Tree2(n));   /* 1st operand */
  2279.          infer_nd(Tree3(n));   /* 2nd operand */
  2280.          /*
  2281.           * Perform type inference on the operation.
  2282.           */
  2283.          sav_argtyp = arg_typs;
  2284.          sav_nargs = num_args;
  2285.          arg_typs = get_argtyp();
  2286.          num_args = 2;
  2287.          arg_typs->types[0] = Tree2(n)->type;
  2288.          arg_typs->types[1] = Tree3(n)->type;
  2289.          infer_impl(Impl1(n), n, n->symtyps, Typ4(n));
  2290.          chk_succ(Impl1(n)->ret_flag, n->store);
  2291.          /*
  2292.           * Perform type inference on the assignment.
  2293.           */
  2294.          arg_typs->types[1] = Typ4(n);
  2295.          infer_impl(Impl0(n), n, n->symtyps->next, n->type);
  2296.          chk_succ(Impl0(n)->ret_flag, n->store);
  2297.  
  2298.          free_argtyp(arg_typs);
  2299.          arg_typs = sav_argtyp;
  2300.          num_args = sav_nargs;
  2301.          break;
  2302.  
  2303.       case N_Bar:
  2304.          /*
  2305.           * This operation intercepts failure and has an associated
  2306.           *  resumption store.  If backtracking reaches this operation
  2307.           *  execution may either continue backward or proceed forward
  2308.           *  again.
  2309.           */ 
  2310.          mrg_store(n->store, fail_store);
  2311.          mrg_store(n->store, succ_store);
  2312.          fail_store = n->store;
  2313.          infer_nd(Tree0(n));
  2314.          /*
  2315.           * Type is computed by operand.
  2316.           */
  2317.         break;
  2318.  
  2319.       case N_Break:
  2320.          /*
  2321.           * The success and failure stores for the operand of break are
  2322.           *  those associated with the enclosing loop.
  2323.           */
  2324.          fail_store = cur_loop->fail_store;
  2325.          loop_sav = cur_loop;
  2326.          cur_loop = cur_loop->prev;
  2327.          infer_nd(Tree0(n));
  2328.          cur_loop = loop_sav;
  2329.          mrg_store(succ_store, cur_loop->succ_store);
  2330.          if (cur_loop->susp_store != NULL)
  2331.             mrg_store(cur_loop->susp_store, fail_store);
  2332.          free_store(succ_store);
  2333.          succ_store = get_store(1);  /* empty store says: can't get past here */
  2334.          fail_store = dummy_stor;    /* shouldn't be used */
  2335.          /*
  2336.           * Result of break is empty type. Result type of expression
  2337.           *  is computed directly into result type of loop.
  2338.           */
  2339.          break;
  2340.  
  2341.       case N_Case:
  2342.          f_store = fail_store;
  2343.          s_store = get_store(1);
  2344.          infer_nd(Tree0(n));     /* control clause */
  2345.          cases = Tree1(n);
  2346.          while (cases != NULL) {
  2347.             if (cases->n_type == N_Ccls) {
  2348.                clause = cases;
  2349.                cases = NULL;
  2350.                }
  2351.             else {
  2352.                clause = Tree1(cases);
  2353.                cases = Tree0(cases);
  2354.                }
  2355.  
  2356.             /*
  2357.              * Set up a failure store to capture the effects of failure
  2358.              *  of the selection clause.
  2359.              */
  2360.             store = get_store(1);
  2361.             fail_store = store;
  2362.             infer_nd(Tree0(clause));             /* value of clause */
  2363.  
  2364.             /*
  2365.              * Create the effect of the possible failure of the comparison
  2366.              *  of the selection value to the control value.
  2367.              */
  2368.             mrg_store(succ_store, fail_store);
  2369.  
  2370.             /*
  2371.              * The success and failure stores and the result of the body
  2372.              *  of the clause are those of the whole case expression.
  2373.              */
  2374.             fail_store = f_store;
  2375.             infer_nd(Tree1(clause));             /* body of clause */
  2376.             mrg_store(succ_store, s_store);
  2377.             free_store(succ_store);
  2378.             succ_store = store;
  2379.             if (n->store != NULL)
  2380.                mrg_store(n->store, fail_store);  /* 'case' can be resumed */
  2381. #ifdef TypTrc
  2382.             MrgTyp(n_intrtyp, Tree1(clause)->type, n->type);
  2383. #else                    /* TypTrc */
  2384.             /*
  2385.              * Type is computed by case clause directly into n->type.
  2386.             */
  2387. #endif                    /* TypTrc */
  2388.             }
  2389.  
  2390.          /*
  2391.           * Check for default clause.
  2392.           */
  2393.          if (Tree2(n) == NULL)
  2394.             mrg_store(succ_store, f_store);
  2395.          else {
  2396.             fail_store = f_store;
  2397.             infer_nd(Tree2(n));                  /* default */
  2398.             mrg_store(succ_store, s_store);
  2399.             if (n->store != NULL)
  2400.                mrg_store(n->store, fail_store);  /* 'case' can be resumed */
  2401. #ifdef TypTrc
  2402.             MrgTyp(n_intrtyp, Tree2(n)->type, n->type);
  2403. #else                    /* TypTrc */
  2404.             /*
  2405.              * Type is computed by default clause directly into n->type.
  2406.              */
  2407. #endif                    /* TypTrc */
  2408.             }
  2409.          free_store(succ_store);
  2410.          succ_store = s_store;
  2411.          if (n->store != NULL)
  2412.             fail_store = n->store;
  2413.          break;
  2414.  
  2415.       case N_Create:
  2416.          /*
  2417.           * Record initial values of local variables for coexpression.
  2418.           */
  2419.          store = coexp_map[n->new_types[0]]->in_store;
  2420.          for (i = 0; i < n_loc; ++i)
  2421.             ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i],
  2422.                store->types[n_gbl + i])
  2423.          /*
  2424.           * Type is precomputed.
  2425.           */
  2426.          break;
  2427.  
  2428.       case N_Cset:
  2429.       case N_Empty:
  2430.       case N_Id:
  2431.       case N_Int:
  2432.       case N_Real:
  2433.       case N_Str:
  2434.          /*
  2435.           * Type is precomputed.
  2436.           */
  2437.          break;
  2438.  
  2439.       case N_Field: {
  2440.          struct fentry *fp;
  2441.          struct par_rec *rp;
  2442.          int frst_rec;
  2443.  
  2444.          if ((fp = flookup(Str0(Tree1(n)))) == NULL) {
  2445.             break;  /* error message printed elsewhere */
  2446.             }
  2447.  
  2448.          /*
  2449.           * Determine the record types.
  2450.           */
  2451.          infer_nd(Tree0(n));
  2452.          typ_deref(Tree0(n)->type, n->symtyps->types[0], 0);
  2453.  
  2454.          /*
  2455.           * For each record containing this field, get the tupe of
  2456.           *  the field in that record.
  2457.           */
  2458.          frst_rec = type_array[rec_typ].frst_bit;
  2459.          for (rp = fp->rlist; rp != NULL; rp = rp->next) {
  2460.             if (bitset(n->symtyps->types[0], frst_rec + rp->rec->rec_num))
  2461.                set_typ(n->type, frst_fld + rp->rec->frst_fld + rp->offset);
  2462.             }
  2463.          }
  2464.          break;
  2465.  
  2466.       case N_If:
  2467.          f_store = fail_store;
  2468.          if (Tree2(n)->n_type != N_Empty) {
  2469.             /*
  2470.              * If there is an else clause, we must set up a failure store
  2471.              *  to capture the effects of failure of the control clause.
  2472.              */
  2473.             store = get_store(1);
  2474.             fail_store = store;
  2475.             }
  2476.  
  2477.          infer_nd(Tree0(n));           /* control clause */
  2478.  
  2479.          /*
  2480.           * If the control clause succeeds, execution passes into the
  2481.           *  then clause with the failure store for the entire if expression.
  2482.           */
  2483.          fail_store = f_store;
  2484.          infer_nd(Tree1(n));           /* then clause */
  2485.  
  2486.          if (Tree2(n)->n_type != N_Empty) {
  2487.             if (n->store != NULL)
  2488.                mrg_store(n->store, fail_store); /* 'if' expr can be resumed */
  2489.             s_store = succ_store;
  2490.  
  2491.             /*
  2492.              * The entering success store of the else clause is the failure
  2493.              *  store of the control clause. The failure store is that of
  2494.              *  the entire if expression.
  2495.              */
  2496.             succ_store = store;
  2497.             fail_store = f_store;
  2498.             infer_nd(Tree2(n));        /* else clause */
  2499.  
  2500.             if (n->store != NULL) {
  2501.                mrg_store(n->store, fail_store); /* 'if' expr can be resumed */
  2502.                fail_store = n->store;
  2503.                }
  2504.  
  2505.             /*
  2506.              * Join the exiting success stores of the then and else clauses.
  2507.              */
  2508.             mrg_store(s_store, succ_store);
  2509.             free_store(s_store);
  2510.             }
  2511.  
  2512. #ifdef TypTrc
  2513.          MrgTyp(n_intrtyp, Tree1(n)->type, n->type);
  2514.          if (Tree2(n)->n_type != N_Empty)
  2515.             MrgTyp(n_intrtyp, Tree2(n)->type, n->type);
  2516. #else                    /* TypTrc */
  2517.          /*
  2518.           * Type computed by 'then' and 'else' clauses directly into n->type.
  2519.           */
  2520. #endif                    /* TypTrc */
  2521.          break;
  2522.  
  2523.       case N_Invok:
  2524.          /*
  2525.           * General invocation.
  2526.           */
  2527.          infer_nd(Tree1(n));          /* thing being invoked */
  2528.  
  2529.          /*
  2530.           * Perform type inference on all the arguments and copy the
  2531.           *  results into the argument type array.
  2532.           */
  2533.          sav_argtyp = arg_typs;
  2534.          sav_nargs = num_args;
  2535.          arg_typs = get_argtyp();
  2536.          num_args = Val0(n);          /* number of arguments */
  2537.          for (i = 0; i < num_args; ++i) {
  2538.             infer_nd(n->n_field[i+2].n_ptr);           /* arg i */
  2539.             arg_typs->types[i] = n->n_field[i+2].n_ptr->type;
  2540.             }
  2541.  
  2542.          /*
  2543.           * If this is mutual evaluation, get the type of the last argument,
  2544.           *  otherwise do inference on general invocation.
  2545.           */
  2546.          if (Tree1(n)->n_type == N_Empty) {
  2547.             MrgTyp(n_intrtyp, arg_typs->types[num_args - 1], n->type);
  2548.             }
  2549.          else
  2550.             gen_inv(Tree1(n)->type, n);
  2551.  
  2552.          free_argtyp(arg_typs);
  2553.          arg_typs = sav_argtyp;
  2554.          num_args = sav_nargs;
  2555.          break;
  2556.  
  2557.       case N_InvOp:
  2558.          /*
  2559.           * Invocation of a run-time operation. Perform inference on all
  2560.           *  the arguments, copying the results into the argument type
  2561.           *  array.
  2562.           */
  2563.          sav_argtyp = arg_typs;
  2564.          sav_nargs = num_args;
  2565.          arg_typs = get_argtyp();
  2566.          num_args = Val0(n);                          /* number of arguments */
  2567.          for (i = 0; i < num_args; ++i) {
  2568.             infer_nd(n->n_field[i+2].n_ptr);           /* arg i */
  2569.             arg_typs->types[i] = n->n_field[i+2].n_ptr->type;
  2570.             }
  2571.  
  2572.          /*
  2573.           * Perform inference on operation invocation.
  2574.           */
  2575.          infer_impl(Impl1(n), n, n->symtyps, n->type);
  2576.          chk_succ(Impl1(n)->ret_flag, n->store);
  2577.  
  2578.          free_argtyp(arg_typs);
  2579.          arg_typs = sav_argtyp;
  2580.          num_args = sav_nargs;
  2581.          break;
  2582.  
  2583.       case N_InvProc:
  2584.          /*
  2585.           * Invocation of a procedure. Perform inference on all
  2586.           *  the arguments, copying the results into the argument type
  2587.           *  array.
  2588.           */
  2589.          sav_argtyp = arg_typs;
  2590.          sav_nargs = num_args;
  2591.          arg_typs = get_argtyp();
  2592.          num_args = Val0(n);                          /* number of arguments */
  2593.          for (i = 0; i < num_args; ++i) {
  2594.             infer_nd(n->n_field[i+2].n_ptr);           /* arg i */
  2595.             arg_typs->types[i] = n->n_field[i+2].n_ptr->type;
  2596.             }
  2597.  
  2598.          /*
  2599.           * Perform inference on the procedure invocation.
  2600.           */
  2601.          infer_prc(Proc1(n), n);
  2602.          chk_succ(Proc1(n)->ret_flag, n->store);
  2603.  
  2604.          free_argtyp(arg_typs);
  2605.          arg_typs = sav_argtyp;
  2606.          num_args = sav_nargs;
  2607.          break;
  2608.  
  2609.       case N_InvRec:
  2610.          /*
  2611.           * Invocation of a record constructor. Perform inference on all
  2612.           *  the arguments, copying the results into the argument type
  2613.           *  array.
  2614.           */
  2615.          sav_argtyp = arg_typs;
  2616.          sav_nargs = num_args;
  2617.          arg_typs = get_argtyp();
  2618.          num_args = Val0(n);                          /* number of arguments */
  2619.          for (i = 0; i < num_args; ++i) {
  2620.             infer_nd(n->n_field[i+2].n_ptr);           /* arg i */
  2621.             arg_typs->types[i] = n->n_field[i+2].n_ptr->type;
  2622.             }
  2623.  
  2624.          infer_con(Rec1(n), n); /* inference on constructor invocation */
  2625.  
  2626.          free_argtyp(arg_typs);
  2627.          arg_typs = sav_argtyp;
  2628.          num_args = sav_nargs;
  2629.          break;
  2630.  
  2631.       case N_Limit:
  2632.          infer_nd(Tree1(n));                 /* limit */
  2633.          typ_deref(Tree1(n)->type, n->symtyps->types[0], 0);
  2634.          mrg_store(succ_store, fail_store);  /* limit might be 0 */
  2635.          mrg_store(n->store, fail_store);    /* resumption may bypass expr */
  2636.          infer_nd(Tree0(n));                 /* expression */
  2637.          if (fail_store != NULL)
  2638.             mrg_store(n->store, fail_store); /* expression may be resumed */
  2639.          fail_store = n->store;
  2640.          /*
  2641.           * Type is computed by expression being limited.
  2642.           */
  2643.          break;
  2644.  
  2645.       case N_Loop: {
  2646.          /*
  2647.           * Establish stores used by break and next.
  2648.           */
  2649.          loop_info.prev = cur_loop;
  2650.          loop_info.succ_store = get_store(1);
  2651.          loop_info.fail_store = fail_store;
  2652.          loop_info.next_store = NULL;
  2653.          loop_info.susp_store = n->store->next;
  2654.          cur_loop = &loop_info;
  2655.  
  2656.          switch ((int)Val0(Tree0(n))) {
  2657.             case EVERY:
  2658.                infer_nd(Tree1(n));              /* control clause */
  2659.                f_store = fail_store;
  2660.  
  2661.                /*
  2662.                 * Next in the do clause resumes the control clause as
  2663.                 *  does success of the do clause.
  2664.                 */
  2665.                loop_info.next_store = fail_store;
  2666.                infer_nd(Tree2(n));              /* do clause  */
  2667.                mrg_store(succ_store, f_store);
  2668.                break;
  2669.  
  2670.             case REPEAT:
  2671.                /*
  2672.                 * The body of the loop can be entered by entering the
  2673.                 *  loop, by executing a next in the body, or by having
  2674.                 *  the loop succeed or fail. n->store captures all but
  2675.                 *  the first case, which is covered by the initial success
  2676.                 *  store.
  2677.                 */
  2678.                fail_store = n->store;
  2679.                mrg_store(n->store, succ_store);
  2680.                loop_info.next_store = n->store;
  2681.                infer_nd(Tree1(n));
  2682.                mrg_store(succ_store, n->store);
  2683.                break;
  2684.  
  2685.             case SUSPEND:
  2686.                infer_nd(Tree1(n));              /* value */
  2687. #ifdef TypTrc
  2688.               if (trcfile != NULL)
  2689.                   fprintf(trcfile, "%s (%d,%d) suspend ", n->n_file, n->n_line,
  2690.                      n->n_col);
  2691. #endif                    /* TypTrc */
  2692.  
  2693.                set_ret(Tree1(n)->type); /* set return type of procedure */
  2694.  
  2695.                /*
  2696.                 * Get changes to types of global variables from
  2697.                 *  resumption.
  2698.                 */
  2699.                store = cur_proc->susp_store;
  2700.                for (i = 0; i < n_gbl; ++i)
  2701.                   CpyTyp(n_icntyp, store->types[i], succ_store->types[i]);
  2702.  
  2703.                /*
  2704.                 * Next in the do clause resumes the control clause as
  2705.                 *  does success of the do clause.
  2706.                 */
  2707.                f_store = fail_store;
  2708.                loop_info.next_store = fail_store;
  2709.                infer_nd(Tree2(n));              /* do clause  */
  2710.                mrg_store(succ_store, f_store);
  2711.                break;
  2712.  
  2713.             case WHILE:
  2714.                /*
  2715.                 * The control clause can be entered by entering the loop,
  2716.                 *  executing a next expression, or by having the do clause
  2717.                 *  succeed or fail. n->store captures all but the first case,
  2718.                 *  which is covered by the initial success store.
  2719.                 */
  2720.                mrg_store(n->store, succ_store);
  2721.                loop_info.next_store = n->store;
  2722.                infer_nd(Tree1(n));              /* control clause */
  2723.                fail_store = n->store;
  2724.                infer_nd(Tree2(n));              /* do clause  */
  2725.                mrg_store(succ_store, n->store);
  2726.                break;
  2727.  
  2728.             case UNTIL:
  2729.                /*
  2730.                 * The control clause can be entered by entering the loop,
  2731.                 *  executing a next expression, or by having the do clause
  2732.                 *  succeed or fail. n->store captures all but the first case,
  2733.                 *  which is covered by the initial success store.
  2734.                 */
  2735.                mrg_store(n->store, succ_store);
  2736.                loop_info.next_store = n->store;
  2737.                f_store = fail_store;
  2738.                /*
  2739.                 * Set up a failure store to capture the effects of failure
  2740.                 *  of the control clause.
  2741.                 */
  2742.                store = get_store(1);
  2743.                fail_store = store;
  2744.                infer_nd(Tree1(n));              /* control clause */
  2745.                mrg_store(succ_store, f_store);
  2746.                free_store(succ_store);
  2747.                succ_store = store;
  2748.                fail_store = n->store;
  2749.                infer_nd(Tree2(n));              /* do clause  */
  2750.                mrg_store(succ_store, n->store);
  2751.                break;
  2752.             }
  2753.          free_store(succ_store);
  2754.          succ_store = loop_info.succ_store;
  2755.          if (n->store->next != NULL)
  2756.              fail_store = n->store->next;
  2757.          cur_loop = cur_loop->prev;
  2758.          /*
  2759.           * Type is computed by break expressions.
  2760.           */
  2761.          }
  2762.          break;
  2763.  
  2764.       case N_Next:
  2765.          if (cur_loop->next_store == NULL)
  2766.             mrg_store(succ_store, fail_store);   /* control clause of every */
  2767.          else
  2768.             mrg_store(succ_store, cur_loop->next_store);
  2769.          free_store(succ_store);
  2770.          succ_store = get_store(1);  /* empty store says: can't get past here */
  2771.          fail_store = dummy_stor;    /* shouldn't be used */
  2772.          /*
  2773.           * Result is empty type.
  2774.           */
  2775.          break;
  2776.  
  2777.       case N_Not:
  2778.          /*
  2779.           * Set up a failure store to capture the effects of failure
  2780.           *  of the negated expression, it becomes the success store
  2781.           *  of the entire expression.
  2782.           */
  2783.          f_store = fail_store;
  2784.          store = get_store(1);
  2785.          fail_store = store;
  2786.          infer_nd(Tree0(n));
  2787.          mrg_store(succ_store, f_store); /* if success, then fail */
  2788.          free_store(succ_store);
  2789.          succ_store = store;
  2790.          fail_store = f_store;
  2791.          /*
  2792.           * Type is precomputed.
  2793.           */
  2794.          break;
  2795.  
  2796.       case N_Ret:
  2797.          if (Val0(Tree0(n)) == RETURN) {
  2798.             if (Tree1(n)->flag & CanFail) {
  2799.                /*
  2800.                 * Set up a failure store to capture the effects of failure
  2801.                 *  of the returned expression and the corresponding procedure
  2802.                 *  failure.
  2803.                 */
  2804.                store = get_store(1);
  2805.                fail_store = store;
  2806.                infer_nd(Tree1(n));    /* return value */
  2807.                mrg_store(store, succ_store);
  2808.                free_store(store);
  2809.                }
  2810.             else
  2811.                infer_nd(Tree1(n));    /* return value */
  2812.  
  2813. #ifdef TypTrc
  2814.            if (trcfile != NULL)
  2815.                fprintf(trcfile, "%s (%d,%d) return ", n->n_file, n->n_line,
  2816.                n->n_col);
  2817. #endif                    /* TypTrc */
  2818.  
  2819.             set_ret(Tree1(n)->type);
  2820.             }
  2821.          else {  /* fail */
  2822.             set_ret(NULL);
  2823.  
  2824. #ifdef TypTrc
  2825.            if (trcfile != NULL) 
  2826.                fprintf(trcfile, "%s (%d,%d) fail\n", n->n_file, n->n_line,
  2827.                n->n_col);
  2828. #endif                    /* TypTrc */
  2829.  
  2830.             }
  2831.          free_store(succ_store);
  2832.          succ_store = get_store(1);  /* empty store says: can't get past here */
  2833.          fail_store = dummy_stor;    /* shouldn't be used */
  2834.          /*
  2835.           * Empty type.
  2836.           */
  2837.          break;
  2838.  
  2839.       case N_Scan: {
  2840.          struct implement *asgn_impl;
  2841.  
  2842.          infer_nd(Tree1(n));   /* subject */ 
  2843.          typ_deref(Tree1(n)->type, n->symtyps->types[0], 0);
  2844.          infer_nd(Tree2(n));   /* body */
  2845.  
  2846.          if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) {
  2847.             /*
  2848.              * Perform type inference on the assignment.
  2849.              */
  2850.             asgn_impl = optab[asgn_loc].binary;
  2851.             sav_argtyp = arg_typs;
  2852.             sav_nargs = num_args;
  2853.             arg_typs = get_argtyp();
  2854.             num_args = 2;
  2855.             arg_typs->types[0] = Tree1(n)->type;
  2856.             arg_typs->types[1] = Tree2(n)->type;
  2857.             infer_impl(asgn_impl, n, n->symtyps->next, n->type);
  2858.             chk_succ(asgn_impl->ret_flag, n->store);
  2859.             free_argtyp(arg_typs);
  2860.             arg_typs = sav_argtyp;
  2861.             num_args = sav_nargs;
  2862.             }
  2863.          else
  2864.             MrgTyp(n_intrtyp, Tree2(n)->type, n->type);
  2865.          }
  2866.          break;
  2867.  
  2868.       case N_Sect:
  2869.          infer_nd(Tree2(n));     /* 1st operand */
  2870.          infer_nd(Tree3(n));     /* 2nd operand */
  2871.          infer_nd(Tree4(n));     /* 3rd operand */
  2872.          sav_argtyp = arg_typs;
  2873.          sav_nargs = num_args;
  2874.          arg_typs = get_argtyp();
  2875.          if (Impl1(n) != NULL) {
  2876.             /*
  2877.              * plus or minus.
  2878.              */
  2879.             num_args = 2;
  2880.             arg_typs->types[0] = Tree3(n)->type;
  2881.             arg_typs->types[1] = Tree4(n)->type;
  2882.             wktyp = get_wktyp();
  2883.             infer_impl(Impl1(n), n, n->symtyps->next, wktyp->bits);
  2884.             chk_succ(Impl1(n)->ret_flag, n->store);
  2885.             arg_typs->types[2] = wktyp->bits;
  2886.             }
  2887.          else
  2888.             arg_typs->types[2] = Tree4(n)->type;
  2889.          num_args = 3;
  2890.          arg_typs->types[0] = Tree2(n)->type;
  2891.          arg_typs->types[1] = Tree3(n)->type;
  2892.          /*
  2893.           * sectioning 
  2894.           */
  2895.          infer_impl(Impl0(n), n, n->symtyps, n->type);
  2896.          chk_succ(Impl0(n)->ret_flag, n->store);
  2897.          if (Impl1(n) != NULL)
  2898.            free_wktyp(wktyp);
  2899.          free_argtyp(arg_typs);
  2900.          arg_typs = sav_argtyp;
  2901.          num_args = sav_nargs;
  2902.          break;
  2903.  
  2904.       case N_Slist:
  2905.          f_store = fail_store;
  2906.          if (Tree0(n)->flag & CanFail) {
  2907.             /*
  2908.              * Set up a failure store to capture the effects of failure
  2909.              *  of the first operand; this is merged into the
  2910.              *  incoming success store of the second operand.
  2911.              */
  2912.             store = get_store(1);
  2913.             fail_store = store;
  2914.             infer_nd(Tree0(n));
  2915.             mrg_store(store, succ_store);
  2916.             free_store(store);
  2917.             }
  2918.          else
  2919.             infer_nd(Tree0(n));
  2920.          fail_store = f_store;
  2921.          infer_nd(Tree1(n));
  2922.          /*
  2923.           * Type is computed by second operand.
  2924.           */
  2925.          break;
  2926.  
  2927.       case N_SmplAsgn: {
  2928.          /*
  2929.           * Optimized assignment to a named variable.
  2930.           */
  2931.          struct lentry *var;
  2932.          int indx;
  2933.  
  2934.          infer_nd(Tree3(n));
  2935.          var = LSym0(Tree2(n));
  2936.          if (var->flag & F_Global)
  2937.             indx = var->val.global->index;
  2938.          else if (var->flag & F_Static)
  2939.             indx = var->val.index;
  2940.          else
  2941.             indx = n_gbl + var->val.index;
  2942.          ClrTyp(n_icntyp, succ_store->types[indx]);
  2943.          typ_deref(Tree3(n)->type, succ_store->types[indx], 0);
  2944.  
  2945. #ifdef TypTrc
  2946.          /*
  2947.           * Trace assignment.
  2948.           */
  2949.          if (trcfile != NULL) {
  2950.             fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line,
  2951.                n->n_col, trc_indent, var->name);
  2952.             prt_d_typ(trcfile, Tree3(n)->type);
  2953.             fprintf(trcfile, "\n");
  2954.             }
  2955. #endif                    /* TypTrc */
  2956.          /*
  2957.           * Type is precomputed.
  2958.           */
  2959.          }
  2960.          break;
  2961.  
  2962.       case N_SmplAug: {
  2963.          /*
  2964.           * Optimized augmented assignment to a named variable.
  2965.           */
  2966.          struct lentry *var;
  2967.          int indx;
  2968.  
  2969.          /*
  2970.           * Perform type inference on the operation.
  2971.           */
  2972.          infer_nd(Tree3(n));            /* 2nd operand */
  2973.  
  2974.          /*
  2975.           * Set up type array for arguments of operation.
  2976.           */
  2977.          sav_argtyp = arg_typs;
  2978.          sav_nargs = num_args;
  2979.          arg_typs = get_argtyp();
  2980.          num_args = 2;
  2981.          arg_typs->types[0] = Tree2(n)->type;  /* type was precomputed */
  2982.          arg_typs->types[1] = Tree3(n)->type;
  2983.  
  2984.          /*
  2985.           * Perform inference on the operation.
  2986.           */
  2987.          infer_impl(Impl1(n), n, n->symtyps, Typ4(n));
  2988.          chk_succ(Impl1(n)->ret_flag, n->store);
  2989.  
  2990.          /*
  2991.           * Perform assignment to the variable.
  2992.           */
  2993.          var = LSym0(Tree2(n));
  2994.          if (var->flag & F_Global)
  2995.             indx = var->val.global->index;
  2996.          else if (var->flag & F_Static)
  2997.             indx = var->val.index;
  2998.          else
  2999.             indx = n_gbl + var->val.index;
  3000.          ClrTyp(n_icntyp, succ_store->types[indx]);
  3001.          typ_deref(Typ4(n), succ_store->types[indx], 0);
  3002.  
  3003. #ifdef TypTrc
  3004.          /*
  3005.           * Trace assignment.
  3006.           */
  3007.          if (trcfile != NULL) {
  3008.             fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line,
  3009.                n->n_col, trc_indent, var->name);
  3010.             prt_d_typ(trcfile, Typ4(n));
  3011.             fprintf(trcfile, "\n");
  3012.             }
  3013. #endif                    /* TypTrc */
  3014.  
  3015.          free_argtyp(arg_typs);
  3016.          arg_typs = sav_argtyp;
  3017.          num_args = sav_nargs;
  3018.  
  3019.          /*
  3020.           * Type is precomputed.
  3021.           */
  3022.          }
  3023.          break;
  3024.  
  3025.       default:
  3026.          fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type);
  3027.          exit(ErrorExit);
  3028.       }
  3029.    }
  3030.  
  3031. /*
  3032.  * infer_con - perform type inference for the invocation of a record
  3033.  *  constructor.
  3034.  */
  3035. static novalue infer_con(rec, n)
  3036. struct rentry *rec;
  3037. nodeptr n;
  3038.    {
  3039.    int fld_indx;
  3040.    int nfields;
  3041.    int i;
  3042.  
  3043. #ifdef TypTrc
  3044.    if (trcfile != NULL)
  3045.       fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col,
  3046.          trc_indent, rec->name);
  3047. #endif                    /* TypTrc */
  3048.  
  3049.    /*
  3050.     * Dereference argument types into appropriate entries of field store.
  3051.     */
  3052.    fld_indx = rec->frst_fld;
  3053.    nfields = rec->nfields;
  3054.    for (i = 0; i < num_args && i < nfields; ++i) {
  3055.       typ_deref(arg_typs->types[i], fld_stor->types[fld_indx++], 1);
  3056.  
  3057. #ifdef TypTrc
  3058.       if (trcfile != NULL) {
  3059.          if (i > 0)
  3060.             fprintf(trcfile, ", ");
  3061.          prt_d_typ(trcfile, arg_typs->types[i]);
  3062.          }
  3063. #endif                    /* TypTrc */
  3064.  
  3065.       }
  3066.  
  3067.    /*
  3068.     * If there are too few arguments, add null type to appropriate entries
  3069.     *  of field store.
  3070.     */
  3071.    while (i < nfields) {
  3072.       if (!bitset(fld_stor->types[fld_indx], null_bit)) {
  3073.          ++changed;
  3074.          set_typ(fld_stor->types[fld_indx], null_bit);
  3075.          }
  3076.       ++fld_indx;
  3077.       ++i;
  3078.       }
  3079.  
  3080.    /*
  3081.     * return record type
  3082.     */
  3083.    set_typ(n->type, type_array[rec_typ].frst_bit + rec->rec_num);
  3084.  
  3085. #ifdef TypTrc
  3086.    if (trcfile != NULL) {
  3087.       fprintf(trcfile, ")  =>>  ");
  3088.       prt_typ(trcfile, n->type);
  3089.       fprintf(trcfile, "\n");
  3090.       }
  3091. #endif                    /* TypTrc */
  3092.    }
  3093.  
  3094. /*
  3095.  * infer_act - perform type inference on coexpression activation.
  3096.  */
  3097. static novalue infer_act(n)
  3098. nodeptr n;
  3099.    {
  3100.    struct implement *asgn_impl;
  3101.    struct store *s_store;
  3102.    struct store *f_store;
  3103.    struct store *e_store;
  3104.    struct store *store;
  3105.    struct t_coexpr *sv_coexp;
  3106.    struct t_coexpr *coexp;
  3107.    struct type *rslt_typ;
  3108.    struct argtyps *sav_argtyp;
  3109.    int frst_coexp;
  3110.    int num_coexp;
  3111.    int sav_nargs;
  3112.    int i;
  3113.    int j;
  3114.  
  3115. #ifdef TypTrc
  3116.    FILE *trc_save;
  3117. #endif                    /* TypTrc */
  3118.  
  3119.    num_coexp = type_array[coexp_typ].num_bits;
  3120.    frst_coexp = type_array[coexp_typ].frst_bit;
  3121.  
  3122.    infer_nd(Tree1(n));   /* value to transmit */ 
  3123.    infer_nd(Tree2(n));   /* coexpression */
  3124.  
  3125.    /*
  3126.     * Dereference the two arguments. Note that only locals in the
  3127.     *  transmitted value are dereferenced.
  3128.     */
  3129.  
  3130. #ifdef TypTrc
  3131.    trc_save = trcfile;
  3132.    trcfile = NULL;  /* don't trace value during dereferencing */
  3133. #endif                    /* TypTrc */
  3134.  
  3135.    deref_lcl(Tree1(n)->type, n->symtyps->types[0]);
  3136.  
  3137. #ifdef TypTrc
  3138.    trcfile = trc_save;
  3139. #endif                    /* TypTrc */
  3140.  
  3141.    typ_deref(Tree2(n)->type, n->symtyps->types[1], 0);
  3142.  
  3143.    rslt_typ = get_wktyp();
  3144.  
  3145.    /*
  3146.     * Set up a store for the end of the activation and propagate local
  3147.     *  variables across the activation; the activation may succeed or
  3148.     *  fail.
  3149.     */
  3150.    e_store = get_store(1);
  3151.    for (i = 0; i < n_loc; ++i)
  3152.       CpyTyp(n_icntyp, succ_store->types[n_gbl + i], e_store->types[n_gbl + i])
  3153.    if (fail_store->perm) {
  3154.       for (i = 0; i < n_loc; ++i)
  3155.          ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i],
  3156.             fail_store->types[n_gbl + i])
  3157.          }
  3158.     else {
  3159.       for (i = 0; i < n_loc; ++i)
  3160.          MrgTyp(n_icntyp, succ_store->types[n_gbl + i],
  3161.             fail_store->types[n_gbl + i])
  3162.       }
  3163.  
  3164.  
  3165.    /*
  3166.     * Go through all the co-expressions that might be activated,
  3167.     *  perform type inference on them, and transmit stores along
  3168.     *  the execution paths induced by the activation.
  3169.     */
  3170.    s_store = succ_store;
  3171.    f_store = fail_store;
  3172.    for (j = 0; j < num_coexp; ++j) {
  3173.       if (bitset(n->symtyps->types[1], frst_coexp + j)) {
  3174.          coexp = coexp_map[j];
  3175.          /*
  3176.           * Merge the types of global variables into the "in store" of the
  3177.           *  co-expression. Because the body of the co-expression may already
  3178.           *  have been processed for this pass, the "changed" flag must be
  3179.           *  set if there is a change of type in the store. This will insure
  3180.           *  that there will be another iteration in which to propagate the
  3181.           *  change into the body.
  3182.           */
  3183.          store = coexp->in_store;
  3184.          for (i = 0; i < n_gbl; ++i)
  3185.             ChkMrgTyp(n_icntyp, s_store->types[i], store->types[i])
  3186.  
  3187.          ChkMrgTyp(n_intrtyp, n->symtyps->types[0], coexp->act_typ)
  3188.  
  3189.          /*
  3190.           * Only perform type inference on the body of a co-expression
  3191.           *  once per iteration. The main co-expression has no body.
  3192.           */
  3193.          if (coexp->iteration < iteration & coexp->n != NULL) {
  3194.             coexp->iteration = iteration;
  3195.             succ_store = cpy_store(coexp->in_store);
  3196.             fail_store = coexp->out_store;
  3197.             sv_coexp = cur_coexp;
  3198.             cur_coexp = coexp;
  3199.             infer_nd(coexp->n);
  3200.  
  3201.             /*
  3202.              * Dereference the locals in the value resulting from
  3203.              *  the execution of the co-expression body.
  3204.              */
  3205.  
  3206. #ifdef TypTrc
  3207.             if (trcfile != NULL)
  3208.                fprintf(trcfile, "%s (%d,%d) %sC%d  =>>  ", coexp->n->n_file,
  3209.                   coexp->n->n_line, coexp->n->n_col, trc_indent, j);
  3210. #endif                    /* TypTrc */
  3211.  
  3212.             deref_lcl(coexp->n->type, coexp->rslt_typ);
  3213.  
  3214.             mrg_store(succ_store, coexp->out_store);
  3215.             free_store(succ_store);
  3216.             cur_coexp = sv_coexp;
  3217.             }
  3218.  
  3219.          /*
  3220.           * Get updated types for global variables, assuming the co-expression
  3221.           *  fails or returns by completing.
  3222.           */
  3223.          store = coexp->out_store;
  3224.          for (i = 0; i < n_gbl; ++i)
  3225.             MrgTyp(n_icntyp, store->types[i], e_store->types[i]);
  3226.          if (f_store->perm) {
  3227.             for (i = 0; i < n_gbl; ++i)
  3228.                ChkMrgTyp(n_icntyp, store->types[i], f_store->types[i]);
  3229.             }
  3230.           else {
  3231.             for (i = 0; i < n_gbl; ++i)
  3232.                MrgTyp(n_icntyp, store->types[i], f_store->types[i]);
  3233.             }
  3234.          MrgTyp(n_intrtyp, coexp->rslt_typ, rslt_typ->bits)
  3235.          }
  3236.       }
  3237.  
  3238.    /*
  3239.     * Control may return from the activation if another co-expression
  3240.     *  activates the current one. If we are in a create expression,
  3241.     *  cur_coexp is the current co-expression, otherwise the current
  3242.     *  procedure may be called within several co-expressions.
  3243.     */
  3244.    if (cur_coexp == NULL) {
  3245.       for (j = 0; j < num_coexp; ++j)
  3246.          if (bitset(cur_proc->coexprs, frst_coexp + j))
  3247.             mrg_act(coexp_map[j], e_store, rslt_typ);
  3248.       }
  3249.    else
  3250.       mrg_act(cur_coexp, e_store, rslt_typ);
  3251.  
  3252.    free_store(s_store);
  3253.    succ_store = e_store;
  3254.    fail_store = f_store;
  3255.  
  3256.  
  3257. #ifdef TypTrc
  3258.    if (trcfile != NULL) {
  3259.       fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col,
  3260.          trc_indent);
  3261.       prt_typ(trcfile, n->symtyps->types[0]);
  3262.       fprintf(trcfile, " @ ");
  3263.       prt_typ(trcfile, n->symtyps->types[1]);
  3264.       fprintf(trcfile, "  =>>  ");
  3265.       prt_typ(trcfile, rslt_typ->bits);
  3266.       fprintf(trcfile, "\n");
  3267.       }
  3268. #endif                    /* TypTrc */
  3269.  
  3270.    if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) {
  3271.       /*
  3272.        * Perform type inference on the assignment.
  3273.        */
  3274.       asgn_impl = optab[asgn_loc].binary;
  3275.       sav_argtyp = arg_typs;
  3276.       sav_nargs = num_args;
  3277.       arg_typs = get_argtyp();
  3278.       num_args = 2;
  3279.       arg_typs->types[0] = Tree1(n)->type;
  3280.       arg_typs->types[1] = rslt_typ->bits;
  3281.       infer_impl(asgn_impl, n, n->symtyps->next, n->type);
  3282.       chk_succ(asgn_impl->ret_flag, n->store);
  3283.       free_argtyp(arg_typs);
  3284.       arg_typs = sav_argtyp;
  3285.       num_args = sav_nargs;
  3286.       }
  3287.    else
  3288.       ChkMrgTyp(n_intrtyp, rslt_typ->bits, n->type)
  3289.  
  3290.    free_wktyp(rslt_typ);
  3291.    }
  3292.  
  3293. /*
  3294.  * mrg_act - merge entry information for the co-expression to the
  3295.  *  the ending store and result type for the activation being
  3296.  *  analyzed.
  3297.  */
  3298. static novalue mrg_act(coexp, e_store, rslt_typ)
  3299. struct t_coexpr *coexp;
  3300. struct store *e_store;
  3301. struct type *rslt_typ;
  3302.    {
  3303.    struct store *store;
  3304.    int i;
  3305.  
  3306.    store = coexp->in_store;
  3307.    for (i = 0; i < n_gbl; ++i)
  3308.       MrgTyp(n_icntyp, store->types[i], e_store->types[i]);
  3309.  
  3310.    MrgTyp(n_intrtyp, coexp->act_typ, rslt_typ->bits)
  3311.    }
  3312.  
  3313. /*
  3314.  * typ_deref - perform dereferencing in the abstract type realm.
  3315.  */
  3316. static novalue typ_deref(src, dest, chk)
  3317. unsigned int *src;
  3318. unsigned int *dest;
  3319. int chk;
  3320.    {
  3321.    struct store *tblel_stor;
  3322.    struct store *tbldf_stor;
  3323.    struct store *ttv_stor;
  3324.    struct store *store;
  3325.    unsigned int old;
  3326.    int num_tbl;
  3327.    int frst_tbl;
  3328.    int num_bits;
  3329.    int frst_bit;
  3330.    int i;
  3331.    int j;
  3332.  
  3333.    /*
  3334.     * copy values to destination
  3335.     */
  3336.    for (i = 0; i < NumInts(n_icntyp) - 1; ++i) {
  3337.       old = dest[i];
  3338.       dest[i] |= src[i];
  3339.       if (chk && (old != dest[i]))
  3340.          ++changed;
  3341.       }
  3342.    old = dest[i];
  3343.    dest[i] |= src[i] & val_mask;  /* mask out variables */
  3344.    if (chk && (old != dest[i]))
  3345.       ++changed;
  3346.  
  3347.    /* 
  3348.     * predefined variables whose types do not change.
  3349.     */
  3350.    for (i = 0; i < num_typs; ++i) {
  3351.       if (icontypes[i].deref == DrfCnst) {
  3352.          if (bitset(src, type_array[i].frst_bit))
  3353.             if (chk)
  3354.                ChkMrgTyp(n_icntyp, type_array[i].typ, dest)
  3355.             else
  3356.                MrgTyp(n_icntyp, type_array[i].typ, dest)
  3357.          }
  3358.       }
  3359.  
  3360.  
  3361.    /*
  3362.     * substring trapped variables
  3363.     */
  3364.    num_bits = type_array[stv_typ].num_bits;
  3365.    frst_bit = type_array[stv_typ].frst_bit;
  3366.    for (i = 0; i < num_bits; ++i)
  3367.       if (bitset(src, frst_bit + i))
  3368.          if (!bitset(dest, str_bit)) {
  3369.             if (chk)
  3370.                ++changed;
  3371.             set_typ(dest, str_bit);
  3372.             }
  3373.  
  3374.    /*
  3375.     * table element trapped variables
  3376.     */
  3377.    num_bits = type_array[ttv_typ].num_bits;
  3378.    frst_bit = type_array[ttv_typ].frst_bit;
  3379.    num_tbl = type_array[tbl_typ].num_bits;
  3380.    frst_tbl = type_array[tbl_typ].frst_bit;
  3381.    tblel_stor = compnt_array[tbl_val].store;
  3382.    tbldf_stor = compnt_array[tbl_dflt].store;
  3383.    ttv_stor = compnt_array[trpd_tbl].store;
  3384.    for (i = 0; i < num_bits; ++i)
  3385.       if (bitset(src, frst_bit + i))
  3386.          for (j = 0; j < num_tbl; ++j)
  3387.              if (bitset(ttv_stor->types[i], frst_tbl + j)) {
  3388.                 if (chk) {
  3389.                    ChkMrgTyp(n_icntyp, tblel_stor->types[j], dest)
  3390.                    ChkMrgTyp(n_icntyp, tbldf_stor->types[j], dest)
  3391.                    }
  3392.                 else {
  3393.                    MrgTyp(n_icntyp, tblel_stor->types[j], dest)
  3394.                    MrgTyp(n_icntyp, tbldf_stor->types[j], dest)
  3395.                    }
  3396.                 }
  3397.  
  3398.    /*
  3399.     * Aggregate compontents that are variables.
  3400.     */
  3401.    for (i = 0; i < num_cmpnts; ++i) {
  3402.       if (typecompnt[i].var) {
  3403.          frst_bit = compnt_array[i].frst_bit;
  3404.          num_bits = compnt_array[i].num_bits;
  3405.          store = compnt_array[i].store;
  3406.          for (j = 0; j < num_bits; ++j) {
  3407.             if (bitset(src, frst_bit + j))
  3408.                if (chk)
  3409.                   ChkMrgTyp(n_icntyp, store->types[j], dest)
  3410.                else
  3411.                   MrgTyp(n_icntyp, store->types[j], dest)
  3412.              }
  3413.          }
  3414.       }
  3415.  
  3416.  
  3417.    /*
  3418.     * record fields
  3419.     */
  3420.    for (i = 0; i < n_fld; ++i)
  3421.       if (bitset(src, frst_fld + i))
  3422.          if (chk)
  3423.             ChkMrgTyp(n_icntyp, fld_stor->types[i], dest)
  3424.          else
  3425.             MrgTyp(n_icntyp, fld_stor->types[i], dest)
  3426.  
  3427.    /*
  3428.     * global variables
  3429.     */
  3430.    for (i = 0; i < n_gbl; ++i)
  3431.       if (bitset(src, frst_gbl + i))
  3432.          if (chk)
  3433.             ChkMrgTyp(n_icntyp, succ_store->types[i], dest)
  3434.          else
  3435.             MrgTyp(n_icntyp, succ_store->types[i], dest)
  3436.  
  3437.    /*
  3438.     * local variables
  3439.     */
  3440.    for (i = 0; i < n_loc; ++i)
  3441.       if (bitset(src, frst_loc + i))
  3442.          if (chk)
  3443.             ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest)
  3444.          else
  3445.             MrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest)
  3446.    }
  3447.  
  3448. /*
  3449.  * infer_impl - perform type inference on a call to built-in operation
  3450.  *   using the implementation entry from the data base.
  3451.  */
  3452. static novalue infer_impl(impl, n, symtyps, rslt_typ)
  3453. struct implement *impl;
  3454. nodeptr n;
  3455. struct symtyps *symtyps;
  3456. unsigned int *rslt_typ;
  3457.    {
  3458.    unsigned int *typ;
  3459.    int flag;
  3460.    int nparms;
  3461.    int i;
  3462.    int j; 
  3463.  
  3464. #ifdef TypTrc
  3465.    if (trcfile != NULL) {
  3466.       fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col,
  3467.          trc_indent);
  3468.       if (impl->oper_typ == 'K')
  3469.          fprintf(trcfile, "&%s", impl->name);
  3470.       else
  3471.          fprintf(trcfile, "%s(", impl->name);
  3472.       }
  3473. #endif                    /* TypTrc */
  3474.    /*
  3475.     * Set up the "symbol table" of dereferenced and undereferenced
  3476.     *  argument types as needed by the operation.
  3477.     */
  3478.    nparms = impl->nargs;
  3479.    j = 0;
  3480.    for (i = 0; i < num_args && i < nparms; ++i) {
  3481.       if (impl->arg_flgs[i] & RtParm) {
  3482.          CpyTyp(n_intrtyp, arg_typs->types[i], symtyps->types[j]);
  3483.  
  3484. #ifdef TypTrc
  3485.          if (trcfile != NULL) {
  3486.             if (i > 0)
  3487.                fprintf(trcfile, ", ");
  3488.             prt_typ(trcfile, arg_typs->types[i]);
  3489.             }
  3490. #endif                    /* TypTrc */
  3491.  
  3492.          ++j;
  3493.          }
  3494.       if (impl->arg_flgs[i] & DrfPrm) {
  3495.          typ_deref(arg_typs->types[i], symtyps->types[j], 0);
  3496.  
  3497. #ifdef TypTrc
  3498.          if (trcfile != NULL) {
  3499.             if (impl->arg_flgs[i] & RtParm)
  3500.                fprintf(trcfile, "->");
  3501.             else if (i > 0)
  3502.                fprintf(trcfile, ", ");
  3503.             prt_d_typ(trcfile, arg_typs->types[i]);
  3504.             }
  3505. #endif                    /* TypTrc */
  3506.  
  3507.          ++j;
  3508.          }
  3509.       }
  3510.    if (nparms > 0) {
  3511.       /*
  3512.        * Check for varargs. Merge remaining arguments into the
  3513.        *  type of the variable part of the parameter list.
  3514.        */
  3515.       flag = impl->arg_flgs[nparms - 1];
  3516.       if (flag & VarPrm) {
  3517.          n_vararg = num_args - nparms + 1;
  3518.          if (n_vararg < 0)
  3519.             n_vararg = 0;
  3520.          typ = symtyps->types[j - 1];
  3521.          while (i < num_args) {
  3522.             if (flag & RtParm) {
  3523.                MrgTyp(n_intrtyp, arg_typs->types[i], typ)
  3524.  
  3525. #ifdef TypTrc
  3526.                if (trcfile != NULL) {
  3527.                   if (i > 0)
  3528.                      fprintf(trcfile, ", ");
  3529.                   prt_typ(trcfile, arg_typs->types[i]);
  3530.                   }
  3531. #endif                    /* TypTrc */
  3532.  
  3533.               }
  3534.             else {
  3535.                typ_deref(arg_typs->types[i], typ, 0);
  3536.  
  3537. #ifdef TypTrc
  3538.                if (trcfile != NULL) {
  3539.                   if (i > 0)
  3540.                      fprintf(trcfile, ", ");
  3541.                   prt_d_typ(trcfile, arg_typs->types[i]);
  3542.                   }
  3543. #endif                    /* TypTrc */
  3544.  
  3545.               }
  3546.             ++i;
  3547.             }
  3548.          nparms -= 1; /* Don't extend with nulls into variable part */
  3549.          }
  3550.       }
  3551.    while (i < nparms) {
  3552.       if (impl->arg_flgs[i] & RtParm)
  3553.          set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */
  3554.       if (impl->arg_flgs[i] & DrfPrm)
  3555.          set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */
  3556.       ++i;
  3557.       }
  3558.  
  3559.    /*
  3560.     * If this operation can suspend, there may be backtracking paths
  3561.     *  to this invocation. Merge type information from those paths
  3562.     *  into the current store.
  3563.     */
  3564.    if (impl->ret_flag & DoesSusp)
  3565.       mrg_store(n->store, succ_store);
  3566.  
  3567.    cur_symtyps = symtyps;
  3568.    cur_rslt.bits = rslt_typ;
  3569.    cur_rslt.size = n_intrtyp;
  3570.    cur_new = n->new_types;
  3571.    infer_il(impl->in_line); /* perform inference on operation */
  3572.  
  3573.    if (MightFail(impl->ret_flag))
  3574.       mrg_store(succ_store, fail_store);
  3575.  
  3576. #ifdef TypTrc
  3577.    if (trcfile != NULL) {
  3578.       if (impl->oper_typ != 'K')
  3579.          fprintf(trcfile, ")");
  3580.       fprintf(trcfile, "  =>>  ");
  3581.       prt_typ(trcfile, rslt_typ);
  3582.       fprintf(trcfile, "\n");
  3583.       }
  3584. #endif                    /* TypTrc */
  3585.    }
  3586.  
  3587. /*
  3588.  * chk_succ - check to see if the operation can succeed. In particular,
  3589.  *   see if it can suspend. Change the succ_store and failure store
  3590.  *   appropriately.
  3591.  */
  3592. static novalue chk_succ(ret_flag, susp_stor)
  3593. int ret_flag;
  3594. struct store *susp_stor;
  3595.    {
  3596.    if (ret_flag & DoesSusp) {
  3597.        if (susp_stor != NULL && (ret_flag & DoesRet))
  3598.           mrg_store(susp_stor, fail_store); /* "pass along" failure */
  3599.        fail_store = susp_stor;
  3600.        }
  3601.    else if (!(ret_flag & DoesRet)) {
  3602.       free_store(succ_store);
  3603.       succ_store = get_store(1);
  3604.       fail_store = dummy_stor;    /* shouldn't be used */
  3605.       }
  3606.    }
  3607.  
  3608. /*
  3609.  * infer_il - perform type inference on a piece of code within built-in
  3610.  *   operation and determine whether execution can get past it.
  3611.  */
  3612. static int infer_il(il)
  3613. struct il_code *il;
  3614.    {
  3615.    struct il_code *il1;
  3616.    int condition;
  3617.    int case_fnd;
  3618.    int ncases;
  3619.    int may_fallthru;
  3620.    int indx;
  3621.    int i;
  3622.  
  3623.    if (il == NULL)
  3624.       return 1;
  3625.  
  3626.    switch (il->il_type) {
  3627.       case IL_Const:  /* should have been replaced by literal node */
  3628.          return 0;
  3629.  
  3630.       case IL_If1:
  3631.          condition = eval_cond(il->u[0].fld);
  3632.          may_fallthru = (condition & MaybeFalse);
  3633.          if (condition & MaybeTrue)
  3634.             may_fallthru |= infer_il(il->u[1].fld);
  3635.          return may_fallthru;
  3636.  
  3637.       case IL_If2:
  3638.          condition = eval_cond(il->u[0].fld);
  3639.          may_fallthru = 0;
  3640.          if (condition & MaybeTrue)
  3641.             may_fallthru |= infer_il(il->u[1].fld);
  3642.          if (condition & MaybeFalse)
  3643.             may_fallthru |= infer_il(il->u[2].fld);
  3644.          return may_fallthru;
  3645.  
  3646.       case IL_Tcase1:
  3647.          type_case(il, infer_il, NULL);
  3648.          return 1;      /* no point in trying very hard here */
  3649.  
  3650.       case IL_Tcase2:
  3651.          indx = type_case(il, infer_il, NULL);
  3652.          if (indx != -1)
  3653.             infer_il(il->u[indx].fld);         /* default */
  3654.          return 1;      /* no point in trying very hard here */
  3655.  
  3656.       case IL_Lcase:
  3657.          ncases = il->u[0].n;
  3658.          indx = 1;
  3659.          case_fnd = 0;
  3660.          for (i = 0; i < ncases && !case_fnd; ++i) {
  3661.             if (il->u[indx++].n == n_vararg) {   /* selection number */
  3662.                infer_il(il->u[indx].fld);        /* action */
  3663.                case_fnd = 1;
  3664.                }
  3665.             ++indx;
  3666.             }
  3667.          if (!case_fnd)
  3668.             infer_il(il->u[indx].fld);        /* default */
  3669.          return 1;      /* no point in trying very hard here */
  3670.  
  3671.       case IL_Acase: {
  3672.          int maybe_int;
  3673.          int maybe_dbl;
  3674.  
  3675.          eval_arith((int)il->u[0].fld->u[0].n, (int)il->u[1].fld->u[0].n,
  3676.              &maybe_int, &maybe_dbl);
  3677.          if (maybe_int) {
  3678.             infer_il(il->u[2].fld);          /* C_integer action */
  3679.             if (largeints) 
  3680.                infer_il(il->u[3].fld);       /* integer action */
  3681.             }
  3682.          if (maybe_dbl)
  3683.             infer_il(il->u[4].fld);          /* C_double action */
  3684.          return 1;      /* no point in trying very hard here */
  3685.          }
  3686.  
  3687.       case IL_Err1:
  3688.       case IL_Err2:
  3689.          return 0;
  3690.  
  3691.       case IL_Block:
  3692.          return il->u[0].n;
  3693.  
  3694.       case IL_Call:
  3695.          return ((il->u[3].n & DoesFThru) != 0);
  3696.  
  3697.       case IL_Lst:
  3698.          if (infer_il(il->u[0].fld))
  3699.              return infer_il(il->u[1].fld);
  3700.          else
  3701.              return 0;
  3702.  
  3703.       case IL_Abstr:
  3704.          /*
  3705.           * Handle side effects.
  3706.           */
  3707.          il1 = il->u[0].fld;
  3708.          if (il1 != NULL) {
  3709.              while (il1->il_type == IL_Lst) {
  3710.                 side_effect(il1->u[1].fld);
  3711.                 il1 = il1->u[0].fld;
  3712.                 }
  3713.              side_effect(il1);
  3714.              }
  3715.  
  3716.          /*
  3717.           * Set return type.
  3718.           */
  3719.          abstr_typ(il->u[1].fld, &cur_rslt);
  3720.          return 1;
  3721.  
  3722.       default:
  3723.          fprintf(stderr, "compiler error: unknown info in data base\n");
  3724.          exit(ErrorExit);
  3725.          /* NOTREACHED */
  3726.       }
  3727.    }
  3728.  
  3729. /*
  3730.  * side_effect - perform a side effect from an abstract clause of a
  3731.  *  built-in operation.
  3732.  */
  3733. static novalue side_effect(il)
  3734. struct il_code *il;
  3735.    {
  3736.    struct type *var_typ;
  3737.    struct type *val_typ;
  3738.    struct store *store;
  3739.    int num_bits;
  3740.    int frst_bit;
  3741.    int i, j;
  3742.  
  3743.    /*
  3744.     * il is IL_TpAsgn, get the variable type and value type, and perform
  3745.     *  the side effect.
  3746.     */
  3747.    var_typ = get_wktyp();
  3748.    val_typ = get_wktyp();
  3749.    abstr_typ(il->u[0].fld, var_typ);    /* variable type */
  3750.    abstr_typ(il->u[1].fld, val_typ);    /* value type */
  3751.  
  3752.    /*
  3753.     * Determine which types that can be assigned to are in the variable
  3754.     *  type.
  3755.     *
  3756.     * Aggregate compontents.
  3757.     */
  3758.    for (i = 0; i < num_cmpnts; ++i) {
  3759.       frst_bit = compnt_array[i].frst_bit;
  3760.       num_bits = compnt_array[i].num_bits;
  3761.       store = compnt_array[i].store;
  3762.       for (j = 0; j < num_bits; ++j) {
  3763.          if (bitset(var_typ->bits, frst_bit + j))
  3764.             ChkMrgTyp(n_icntyp, val_typ->bits, store->types[j])
  3765.          }
  3766.       }
  3767.  
  3768.    /*
  3769.     * record fields
  3770.     */
  3771.    for (i = 0; i < n_fld; ++i)
  3772.       if (bitset(var_typ->bits, frst_fld + i))
  3773.          ChkMrgTyp(n_icntyp, val_typ->bits, fld_stor->types[i]);
  3774.  
  3775.    /*
  3776.     * global variables
  3777.     */
  3778.    for (i = 0; i < n_gbl; ++i)
  3779.       if (bitset(var_typ->bits, frst_gbl + i))
  3780.           MrgTyp(n_icntyp, val_typ->bits, succ_store->types[i]);
  3781.  
  3782.    /*
  3783.     * local variables
  3784.     */
  3785.    for (i = 0; i < n_loc; ++i)
  3786.       if (bitset(var_typ->bits, frst_loc + i))
  3787.           MrgTyp(n_icntyp, val_typ->bits, succ_store->types[n_gbl + i]);
  3788.  
  3789.  
  3790.    free_wktyp(var_typ);
  3791.    free_wktyp(val_typ);
  3792.    }
  3793.  
  3794. /*
  3795.  * abstr_typ - compute the type bits corresponding to an abstract type
  3796.  *  from an abstract clause of a built-in operation.
  3797.  */
  3798. static novalue abstr_typ(il, typ)
  3799. struct il_code *il;
  3800. struct type *typ;
  3801.    {
  3802.    struct type *typ1;
  3803.    struct type *typ2;
  3804.    struct rentry *rec;
  3805.    struct store *store;
  3806.    struct compnt_info *compnts;
  3807.    int num_bits;
  3808.    int frst_bit;
  3809.    int frst_cmpnt;
  3810.    int num_comps;
  3811.    int typcd;
  3812.    int new_indx;
  3813.    int i;
  3814.    int j;
  3815.    int indx;
  3816.    int size;
  3817.    int t_indx;
  3818.    unsigned int *prmtyp;
  3819.  
  3820.    if (il == NULL)
  3821.        return;
  3822.  
  3823.    switch (il->il_type) {
  3824.       case IL_VarTyp:
  3825.          /*
  3826.           * type(<parameter>)
  3827.           */
  3828.          indx = il->u[0].fld->u[0].n; /* symbol table index of variable */
  3829.          if (indx >= cur_symtyps->nsyms) {
  3830.             prmtyp = any_typ;
  3831.             size = n_rttyp;
  3832.             }
  3833.          else {
  3834.             prmtyp = cur_symtyps->types[indx];
  3835.             size = n_intrtyp;
  3836.             }
  3837.          if (typ->size < size)
  3838.             size = typ->size;
  3839.          MrgTyp(size, prmtyp, typ->bits);
  3840.          break;
  3841.  
  3842.       case IL_Store:
  3843.          /*
  3844.           * store[<type>]
  3845.           */
  3846.          typ1 = get_wktyp();
  3847.          abstr_typ(il->u[0].fld, typ1); /* type to be "dereferenced" */
  3848.  
  3849.          /*
  3850.           * Dereference types that are Icon varaibles.
  3851.           */
  3852.          typ_deref(typ1->bits, typ->bits, 0);
  3853.  
  3854.          /*
  3855.           * "Dereference" aggregate compontents that are not Icon variables.
  3856.           */
  3857.          for (i = 0; i < num_cmpnts; ++i) {
  3858.             if (!typecompnt[i].var) {
  3859.                if (i == stv_typ) {
  3860.                   /*
  3861.                    * Substring trapped variable stores contain variable
  3862.                    *  references, so the types are larger, but we cannot
  3863.                    *  copy more than the destination holds.
  3864.                    */
  3865.                   size = n_intrtyp;
  3866.                   if (typ->size < size)
  3867.                     size = typ->size;
  3868.                   }
  3869.                else
  3870.                   size = n_icntyp;
  3871.                frst_bit = compnt_array[i].frst_bit;
  3872.                num_bits = compnt_array[i].num_bits;
  3873.                store = compnt_array[i].store;
  3874.                for (j = 0; j < num_bits; ++j) {
  3875.                   if (bitset(typ1->bits, frst_bit + j))
  3876.                      MrgTyp(size, store->types[j], typ->bits);
  3877.                   }
  3878.                }
  3879.             }
  3880.  
  3881.          free_wktyp(typ1);
  3882.          break;
  3883.  
  3884.       case IL_Compnt:
  3885.          /*
  3886.           * <type>.<component>
  3887.           */
  3888.          typ1 = get_wktyp();
  3889.          abstr_typ(il->u[0].fld, typ1); /* type */
  3890.          i = il->u[1].n;
  3891.          if (i == CM_Fields) {
  3892.             /*
  3893.              * The all_fields component must be handled differently
  3894.              *  from the others.
  3895.              */
  3896.             frst_bit = type_array[rec_typ].frst_bit;
  3897.             num_bits = type_array[rec_typ].num_bits;
  3898.             for (i = 0; i < num_bits; ++i)
  3899.                if (bitset(typ1->bits, frst_bit + i)) {
  3900.                   rec = rec_map[i];
  3901.                   for (j = 0; j < rec->nfields; ++j)
  3902.                      set_typ(typ->bits, frst_fld + rec->frst_fld + j);
  3903.                   }
  3904.             }
  3905.          else {
  3906.             /*
  3907.              * Use component information arrays to transform type bits to
  3908.              *  the corresponding component bits.
  3909.              */
  3910.             frst_bit = type_array[typecompnt[i].aggregate].frst_bit;
  3911.             num_bits = type_array[typecompnt[i].aggregate].num_bits;
  3912.             frst_cmpnt = compnt_array[i].frst_bit;
  3913.             if (!typecompnt[i].var && typ->size < n_rttyp)
  3914.                break;   /* bad abstract type computation */ 
  3915.             for (i = 0; i < num_bits; ++i)
  3916.                if (bitset(typ1->bits, frst_bit + i))
  3917.                   set_typ(typ->bits, frst_cmpnt + i);
  3918.             free_wktyp(typ1);
  3919.             }
  3920.          break;
  3921.  
  3922.       case IL_Union:
  3923.          /*
  3924.           * <type 1> ++ <type 2>
  3925.           */
  3926.          abstr_typ(il->u[0].fld, typ);
  3927.          abstr_typ(il->u[1].fld, typ);
  3928.          break;
  3929.  
  3930.       case IL_Inter:
  3931.          /*
  3932.           * <type 1> ** <type 2>
  3933.           */
  3934.          typ1 = get_wktyp();
  3935.          typ2 = get_wktyp();
  3936.          abstr_typ(il->u[0].fld, typ1);
  3937.          abstr_typ(il->u[1].fld, typ2);
  3938.          size = n_rttyp;
  3939.          for (i = 0; i < NumInts(size); ++i)
  3940.             typ1->bits[i] &= typ2->bits[i];
  3941.          if (typ->size < size)
  3942.             size = typ->size;
  3943.          MrgTyp(size, typ1->bits, typ->bits);
  3944.          free_wktyp(typ1);
  3945.          free_wktyp(typ2);
  3946.          break;
  3947.  
  3948.       case IL_New:
  3949.          /*
  3950.           * new <type-name>(<type 1> , ...)
  3951.           *
  3952.           * If a type was not allocated for this node, use the default
  3953.           *   one.
  3954.           */
  3955.          typ1 = get_wktyp();
  3956.          typcd = il->u[0].n;      /* type code */
  3957.          new_indx = type_array[typcd].new_indx;
  3958.          t_indx = 0;                     /* default is first index of type */
  3959.          if (cur_new != NULL && cur_new[new_indx] > 0)
  3960.             t_indx = cur_new[new_indx];
  3961.  
  3962.          /*
  3963.           * This RTL expression evaluates to the "new" sub-type.
  3964.           */
  3965.          set_typ(typ->bits, type_array[typcd].frst_bit + t_indx);
  3966.  
  3967.          /*
  3968.           * Update stores for components based on argument types in the
  3969.           *  "new" expression.
  3970.           */
  3971.          num_comps = icontypes[typcd].num_comps;
  3972.          j = icontypes[typcd].compnts;
  3973.          compnts = &compnt_array[j];
  3974.          if (typcd == stv_typ) {
  3975.             size = n_intrtyp;
  3976.             }
  3977.          else
  3978.             size = n_icntyp;
  3979.          for (i = 0; i < num_comps; ++i) {
  3980.             ClrTyp(n_rttyp, typ1->bits);
  3981.             abstr_typ(il->u[2 + i].fld, typ1);
  3982.             ChkMrgTyp(size, typ1->bits, compnts[i].store->types[t_indx]);
  3983.             }
  3984.  
  3985.          free_wktyp(typ1);
  3986.          break;
  3987.  
  3988.       case IL_IcnTyp:
  3989.          typcd_bits((int)il->u[0].n, typ);      /* type code */
  3990.          break;
  3991.       }
  3992.    }
  3993.  
  3994. /*
  3995.  * eval_cond - evaluate the condition of in 'if' statement from a
  3996.  *  built-in operation. The result can be both true and false because
  3997.  *  of uncertainty and because more than one execution path may be
  3998.  *  involved.
  3999.  */
  4000. static int eval_cond(il)
  4001. struct il_code *il;
  4002.    {
  4003.    int cond1;
  4004.    int cond2;
  4005.  
  4006.    switch (il->il_type) {
  4007.       case IL_Bang:
  4008.          cond1 = eval_cond(il->u[0].fld);
  4009.          cond2 = 0;
  4010.          if (cond1 & MaybeTrue)
  4011.             cond2 = MaybeFalse;
  4012.          if (cond1 & MaybeFalse)
  4013.             cond2 |= MaybeTrue;
  4014.          return cond2;
  4015.  
  4016.       case IL_And:
  4017.          cond1 = eval_cond(il->u[0].fld);
  4018.          cond2 = eval_cond(il->u[1].fld);
  4019.          return (cond1 & cond2 & MaybeTrue) | ((cond1 | cond2) & MaybeFalse);
  4020.  
  4021.       case IL_Cnv1:
  4022.       case IL_Cnv2:
  4023.          return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n,
  4024.             0, NULL);
  4025.  
  4026.       case IL_Def1:
  4027.       case IL_Def2:
  4028.          return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n,
  4029.             1, NULL);
  4030.  
  4031.       case IL_Is:
  4032.          return eval_is((int)il->u[0].n, il->u[1].fld->u[0].n);
  4033.  
  4034.       default:
  4035.          fprintf(stderr, "compiler error: unknown info in data base\n");
  4036.          exit(ErrorExit);
  4037.          /* NOTREACHED */
  4038.       }
  4039.    }
  4040.  
  4041. /*
  4042.  * eval_cnv - evaluate the conversion of a variable to a specific type
  4043.  *  to see if it may succeed or fail.
  4044.  */
  4045. int eval_cnv(typcd, indx, def, cnv_flags)
  4046. int typcd;       /* type to convert to */
  4047. int indx;        /* index into symbol table of variable */
  4048. int def;         /* flag: conversion has a default value */
  4049. int *cnv_flags;  /* return flag for detailed conversion information */
  4050.    {
  4051.    struct type *may_succeed;  /* types where conversion sometimes succeed */
  4052.    struct type *must_succeed; /* types where conversion always succeeds */
  4053.    struct type *must_cnv;     /* types where actual conversion is performed */
  4054.    struct type *as_is;        /* types where value already has correct type */
  4055.    unsigned int *typ;         /* possible types of the variable */
  4056.    int cond;
  4057.    int i;
  4058.  
  4059.    /*
  4060.     * Conversions may succeed for strings, integers, csets, and reals.
  4061.     *  Conversions may fail for any other types. In addition,
  4062.     *  conversions to integer or real may fail for specific values.
  4063.     */
  4064.    if (indx >= cur_symtyps->nsyms)
  4065.       return MaybeTrue | MaybeFalse;
  4066.    typ = cur_symtyps->types[indx];
  4067.  
  4068.    may_succeed = get_wktyp();
  4069.    must_succeed = get_wktyp();
  4070.    must_cnv = get_wktyp();
  4071.    as_is = get_wktyp();
  4072.  
  4073.    if (typcd == cset_typ || typcd == TypTCset) {
  4074.       set_typ(as_is->bits, cset_bit);
  4075.  
  4076.       set_typ(must_cnv->bits, str_bit);
  4077.       set_typ(must_cnv->bits, int_bit);
  4078.       set_typ(must_cnv->bits, real_bit);
  4079.  
  4080.       set_typ(must_succeed->bits, str_bit);
  4081.       set_typ(must_succeed->bits, cset_bit);
  4082.       set_typ(must_succeed->bits, int_bit);
  4083.       set_typ(must_succeed->bits, real_bit);
  4084.       }
  4085.    else if (typcd == str_typ || typcd == TypTStr) {
  4086.       set_typ(as_is->bits, str_bit);
  4087.  
  4088.       set_typ(must_cnv->bits, cset_bit);
  4089.       set_typ(must_cnv->bits, int_bit);
  4090.       set_typ(must_cnv->bits, real_bit);
  4091.  
  4092.       set_typ(must_succeed->bits, str_bit);
  4093.       set_typ(must_succeed->bits, cset_bit);
  4094.       set_typ(must_succeed->bits, int_bit);
  4095.       set_typ(must_succeed->bits, real_bit);
  4096.       }
  4097.    else if (typcd == TypCStr) {
  4098.       /*
  4099.        * as_is is empty.
  4100.        */
  4101.  
  4102.       set_typ(must_cnv->bits, str_bit);
  4103.       set_typ(must_cnv->bits, cset_bit);
  4104.       set_typ(must_cnv->bits, int_bit);
  4105.       set_typ(must_cnv->bits, real_bit);
  4106.  
  4107.       set_typ(must_succeed->bits, str_bit);
  4108.       set_typ(must_succeed->bits, cset_bit);
  4109.       set_typ(must_succeed->bits, int_bit);
  4110.       set_typ(must_succeed->bits, real_bit);
  4111.       }
  4112.    else if (typcd == real_typ) {
  4113.       set_typ(as_is->bits, real_bit);
  4114.  
  4115.       set_typ(must_cnv->bits, str_bit);
  4116.       set_typ(must_cnv->bits, cset_bit);
  4117.       set_typ(must_cnv->bits, int_bit);
  4118.  
  4119.       set_typ(must_succeed->bits, int_bit);
  4120.       set_typ(must_succeed->bits, real_bit);
  4121.       }
  4122.    else if (typcd == TypCDbl) {
  4123.       /*
  4124.        * as_is is empty.
  4125.        */
  4126.  
  4127.       set_typ(must_cnv->bits, str_bit);
  4128.       set_typ(must_cnv->bits, cset_bit);
  4129.       set_typ(must_cnv->bits, int_bit);
  4130.       set_typ(must_cnv->bits, real_bit);
  4131.  
  4132.       set_typ(must_succeed->bits, int_bit);
  4133.       set_typ(must_succeed->bits, real_bit);
  4134.       }
  4135.    else if (typcd == int_typ) {
  4136.       set_typ(as_is->bits, int_bit);
  4137.  
  4138.       set_typ(must_cnv->bits, str_bit);
  4139.       set_typ(must_cnv->bits, cset_bit);
  4140.       set_typ(must_cnv->bits, real_bit);
  4141.  
  4142.       set_typ(must_succeed->bits, int_bit);
  4143.       }
  4144.    else if (typcd == TypCInt) {
  4145.       /*
  4146.        * Note that conversion from an integer to a C integer can be
  4147.        *  done by changing the way the descriptor is accessed. It
  4148.        *  is not considered a real conversion. Conversion may fail
  4149.        *  even for integers if large integers are supported.
  4150.        */
  4151.       set_typ(as_is->bits, int_bit);
  4152.  
  4153.       set_typ(must_cnv->bits, str_bit);
  4154.       set_typ(must_cnv->bits, cset_bit);
  4155.       set_typ(must_cnv->bits, real_bit);
  4156.  
  4157.       if (!largeints)
  4158.          set_typ(must_succeed->bits, int_bit);
  4159.       }
  4160.    else if (typcd == TypEInt) {
  4161.       set_typ(as_is->bits, int_bit);
  4162.  
  4163.       set_typ(must_cnv->bits, str_bit);
  4164.       set_typ(must_cnv->bits, cset_bit);
  4165.  
  4166.       set_typ(must_succeed->bits, int_bit);
  4167.       }
  4168.    else if (typcd == TypECInt) {
  4169.       set_typ(as_is->bits, int_bit);
  4170.  
  4171.       set_typ(must_cnv->bits, str_bit);
  4172.       set_typ(must_cnv->bits, cset_bit);
  4173.  
  4174.       if (!largeints)
  4175.          set_typ(must_succeed->bits, int_bit);
  4176.       }
  4177.  
  4178.    MrgTyp(n_icntyp, as_is->bits, may_succeed->bits);
  4179.    MrgTyp(n_icntyp, must_cnv->bits, may_succeed->bits);
  4180.    if (def) {
  4181.       set_typ(may_succeed->bits, null_bit);
  4182.       set_typ(must_succeed->bits, null_bit);
  4183.       }
  4184.  
  4185.    /*
  4186.     * Determine if the conversion expression may evaluate to true or false.
  4187.     */
  4188.    cond = 0;
  4189.    for (i = 0; i < NumInts(n_intrtyp); ++i) {
  4190.       if (typ[i] & may_succeed->bits[i]) 
  4191.          cond = MaybeTrue;
  4192.       if (typ[i] & ~must_succeed->bits[i]) 
  4193.          cond |= MaybeFalse;
  4194.       }
  4195.  
  4196.    /*
  4197.     * See if more detailed information about the conversion is needed.
  4198.     */
  4199.    if (cnv_flags != NULL) {
  4200.       *cnv_flags = 0;
  4201.       for (i = 0; i < NumInts(n_intrtyp); ++i) {
  4202.          if (typ[i] & as_is->bits[i]) 
  4203.             *cnv_flags |= MayKeep;
  4204.          if (typ[i] & must_cnv->bits[i]) 
  4205.             *cnv_flags |= MayConvert;
  4206.           }
  4207.       if (def && bitset(typ, null_bit))
  4208.          *cnv_flags |= MayDefault;
  4209.       }
  4210.  
  4211.    free_wktyp(may_succeed);
  4212.    free_wktyp(must_succeed);
  4213.    free_wktyp(must_cnv);
  4214.    free_wktyp(as_is);
  4215.  
  4216.    return cond;
  4217.    }
  4218.  
  4219. /*
  4220.  * eval_is - evaluate the result of an 'is' expression within a built-in
  4221.  *  operation.
  4222.  */
  4223. int eval_is(typcd, indx)
  4224. int typcd;
  4225. int indx;
  4226.    {
  4227.    int cond;
  4228.    unsigned int *typ;
  4229.  
  4230.    if (indx >= cur_symtyps->nsyms)
  4231.       return MaybeTrue | MaybeFalse;
  4232.    typ = cur_symtyps->types[indx];
  4233.    if (has_type(typ, typcd, 0))
  4234.       cond = MaybeTrue;
  4235.    else
  4236.       cond = 0;
  4237.    if (other_type(typ, typcd))
  4238.       cond |= MaybeFalse;
  4239.    return cond;
  4240.    }
  4241.  
  4242. /*
  4243.  * has_type - determine if a bit vector representing types has any bits
  4244.  *  set that correspond to a specific type code from the data base.  Also,
  4245.  *  if requested, clear any such bits.
  4246.  */
  4247. static int has_type(typ, typcd, clear)
  4248. unsigned int *typ;
  4249. int typcd;
  4250. int clear;
  4251.    {
  4252.    int frst_bit, last_bit;
  4253.    int i;
  4254.    int found;
  4255.  
  4256.    found = 0;
  4257.    bitrange(typcd, &frst_bit, &last_bit);
  4258.    for (i = frst_bit; i < last_bit; ++i) {
  4259.       if (bitset(typ, i)) {
  4260.          found = 1;
  4261.          if (clear)
  4262.             clr_typ(typ, i);
  4263.          }
  4264.       }
  4265.    return found;
  4266.    }
  4267.  
  4268. /*
  4269.  * other_type - determine if a bit vector representing types has any bits
  4270.  *  set that correspond to a type *other* than specific type code from the
  4271.  *  data base.
  4272.  */
  4273. static int other_type(typ, typcd)
  4274. unsigned int *typ;
  4275. int typcd;
  4276.    {
  4277.    int frst_bit, last_bit;
  4278.    int i;
  4279.  
  4280.    bitrange(typcd, &frst_bit, &last_bit);
  4281.    for (i = 0; i < frst_bit; ++i)
  4282.       if (bitset(typ, i))
  4283.          return 1;
  4284.    for (i = last_bit; i < n_intrtyp; ++i)
  4285.       if (bitset(typ, i))
  4286.          return 1;
  4287.    return 0;
  4288.    }
  4289.  
  4290. /*
  4291.  * eval_arith - determine which cases of an arith_case may be taken based
  4292.  *   on the types of its arguments.
  4293.  */
  4294. novalue eval_arith(indx1, indx2, maybe_int, maybe_dbl)
  4295. int indx1;
  4296. int indx2;
  4297. int *maybe_int;
  4298. int *maybe_dbl;
  4299.    {
  4300.    unsigned int *typ1;         /* possible types of first variable */
  4301.    unsigned int *typ2;         /* possible types of second variable */
  4302.    int int1 = 0;
  4303.    int int2 = 0;
  4304.    int dbl1 = 0;
  4305.    int dbl2 = 0;
  4306.  
  4307.    typ1 = cur_symtyps->types[indx1];
  4308.    typ2 = cur_symtyps->types[indx2];
  4309.  
  4310.    /*
  4311.     * First see what might result if you do a convert to numeric on each
  4312.     *  variable.
  4313.     */
  4314.    if (bitset(typ1, int_bit))
  4315.       int1 = 1;
  4316.    if (bitset(typ1, real_bit))
  4317.       dbl1 = 1;
  4318.    if (bitset(typ1, str_bit) || bitset(typ1, cset_bit)) {
  4319.       int1 = 1;
  4320.       dbl1 = 1;
  4321.       }
  4322.    if (bitset(typ2, int_bit))
  4323.       int2 = 1;
  4324.    if (bitset(typ2, real_bit))
  4325.       dbl2 = 1;
  4326.    if (bitset(typ2, str_bit) || bitset(typ2, cset_bit)) {
  4327.       int2 = 1;
  4328.       dbl2 = 1;
  4329.       }
  4330.  
  4331.    /*
  4332.     * Use the conversion information to figure out what type of arithmetic
  4333.     *  might be done.
  4334.     */
  4335.    if (int1 && int2)
  4336.       *maybe_int = 1;
  4337.    else
  4338.       *maybe_int = 0;
  4339.  
  4340.    *maybe_dbl = 0;
  4341.    if (dbl1 && dbl2)
  4342.       *maybe_dbl = 1;
  4343.    else if (dbl1 && int2)
  4344.       *maybe_dbl = 1;
  4345.    else if (int1 && dbl2)
  4346.       *maybe_dbl = 1;
  4347.    }
  4348.  
  4349. /*
  4350.  * bitrange - determine the range of bit positions in a type bit vector
  4351.  *  that correspond to a type code from the data base.
  4352.  */
  4353. static novalue bitrange(typcd, frst_bit, last_bit)
  4354. int typcd;
  4355. int *frst_bit;
  4356. int *last_bit;
  4357.    {
  4358.    if (typcd == TypVar) {
  4359.       /*
  4360.        * All variable types.
  4361.        */
  4362.       *frst_bit = n_icntyp;
  4363.       *last_bit = n_intrtyp;
  4364.       }
  4365.    else {
  4366.       *frst_bit = type_array[typcd].frst_bit;
  4367.       *last_bit = *frst_bit + type_array[typcd].num_bits;
  4368.       }
  4369.    }
  4370.  
  4371. /*
  4372.  * type_case - Determine which cases are selected in a type_case
  4373.  *  statement. This routine is used by both type inference and
  4374.  *  the code generator: a different fnc is passed in each case.
  4375.  *  In addition, the code generator passes a case_anlz structure.
  4376.  */
  4377. int type_case(il, fnc, case_anlz)
  4378. struct il_code *il;
  4379. int (*fnc)();
  4380. struct case_anlz *case_anlz;
  4381.    {
  4382.    int *typ_vect;
  4383.    int i, j;
  4384.    int num_cases;
  4385.    int num_types;
  4386.    int indx;
  4387.    int sym_indx;
  4388.    int typcd;
  4389.    int use_dflt;
  4390.    unsigned int *typ;
  4391.    int select;
  4392.    struct type *wktyp;
  4393.  
  4394.    /*
  4395.     * Make a copy of the type of the variable the type case is
  4396.     *  working on.
  4397.     */
  4398.    sym_indx = il->u[0].fld->u[0].n; /* symbol table index */
  4399.    if (sym_indx >= cur_symtyps->nsyms)
  4400.      typ = any_typ;  /* variable is not a parameter, don't know type */
  4401.    else
  4402.      typ = cur_symtyps->types[sym_indx];
  4403.    wktyp = get_wktyp();
  4404.    CpyTyp(n_intrtyp, typ, wktyp->bits);
  4405.    typ = wktyp->bits;
  4406.  
  4407.    /*
  4408.     * Loop through all the case clauses.
  4409.     */
  4410.    num_cases = il->u[1].n;
  4411.    indx = 2;
  4412.    for (i = 0; i < num_cases; ++i) {
  4413.       /*
  4414.        * For each of the types selected by this clause, see if the variable's
  4415.        *  type bit vector contains that type and delete the type from the
  4416.        *  bit vector (so we know if we need the default when we are done).
  4417.        */
  4418.       num_types = il->u[indx++].n;
  4419.       typ_vect = il->u[indx++].vect;
  4420.       select = 0;
  4421.       for (j = 0; j < num_types; ++j)
  4422.          if (has_type(typ, typ_vect[j], 1)) {
  4423.             typcd = typ_vect[j];
  4424.             select += 1;
  4425.             }
  4426.  
  4427.       if (select > 0) {
  4428.          fnc(il->u[indx].fld);       /* action */
  4429.  
  4430.          /*
  4431.           * If this routine was called by the code generator, we need to
  4432.           *  return extra information.
  4433.           */
  4434.          if (case_anlz != NULL) {
  4435.             ++case_anlz->n_cases;
  4436.             if (select == 1) {
  4437.                if (case_anlz->il_then == NULL) {
  4438.                   case_anlz->typcd = typcd;
  4439.                   case_anlz->il_then = il->u[indx].fld;
  4440.                   }
  4441.                else if (case_anlz->il_else == NULL)
  4442.                   case_anlz->il_else = il->u[indx].fld;
  4443.                }
  4444.             else {
  4445.                /*
  4446.                 * There is more than one possible type that will cause
  4447.                 *  us to select this case. It can only be used in the "else".
  4448.                 */
  4449.                if (case_anlz->il_else == NULL)
  4450.                   case_anlz->il_else = il->u[indx].fld;
  4451.                else
  4452.                   case_anlz->n_cases = 3; /* force no inlining. */
  4453.                }
  4454.             }
  4455.          }
  4456.       ++indx;
  4457.       }
  4458.  
  4459.    /*
  4460.     * If there are types that have not been handled, indicate this by
  4461.     *  returning the index of the default clause.
  4462.     */
  4463.    use_dflt = 0;
  4464.    for (i = 0; i < n_intrtyp; ++i)
  4465.       if (bitset(typ, i)) {
  4466.          use_dflt = 1;
  4467.          break;
  4468.          }
  4469.    free_wktyp(wktyp);
  4470.    if (use_dflt)
  4471.       return indx;
  4472.    else
  4473.       return -1;
  4474.    }
  4475.  
  4476. /*
  4477.  * typcd_bits - set the bits of a bit vector corresponding to a type
  4478.  *  code from the data base.
  4479.  */
  4480. static novalue typcd_bits(typcd, typ)
  4481. int typcd;
  4482. struct type *typ;
  4483.    {
  4484.    int frst_bit;
  4485.    int last_bit;
  4486.    int i;
  4487.  
  4488.    if (typcd == TypEmpty)
  4489.       return;  /* Do nothing.  */
  4490.  
  4491.    if (typcd == TypAny) {
  4492.       /*
  4493.        * Set bits corresponding to first-class types.
  4494.        */
  4495.       for (i = 0; i < NumInts(n_icntyp) - 1; ++i)
  4496.          typ->bits[i] |= ~(unsigned int)0;
  4497.       typ->bits[i] |= val_mask;
  4498.       return;
  4499.       }
  4500.  
  4501.    bitrange(typcd, &frst_bit, &last_bit);
  4502.    if (last_bit > typ->size) /* bad abstract type computation */
  4503.       return;
  4504.    for (i = frst_bit; i < last_bit; ++i)
  4505.       set_typ(typ->bits, i);
  4506.    }
  4507.  
  4508. /*
  4509.  * gen_inv - general invocation. The argument list is set up, perform
  4510.  *  abstract interpretation on each possible things being invoked.
  4511.  */
  4512. static novalue gen_inv(typ, n)
  4513. unsigned int *typ;
  4514. nodeptr n;
  4515.    {
  4516.    int ret_flag = 0;
  4517.    struct store *s_store;
  4518.    struct store *store;
  4519.    struct gentry *gptr;
  4520.    struct implement *ip;
  4521.    struct type *prc_typ;
  4522.    int frst_prc;
  4523.    int num_prcs;
  4524.    int i;
  4525.  
  4526. #ifdef TypTrc
  4527.    if (trcfile != NULL) {
  4528.       fprintf(trcfile, "%s (%d,%d) {\n", n->n_file, n->n_line, n->n_col);
  4529.       trc_indent = "   ";
  4530.       }
  4531. #endif                    /* TypTrc */
  4532.  
  4533.    frst_prc = type_array[proc_typ].frst_bit;
  4534.    num_prcs = type_array[proc_typ].num_bits;
  4535.  
  4536.    /*
  4537.     * Dereference the type of the thing being invoked.
  4538.     */
  4539.    prc_typ = get_wktyp();
  4540.    typ_deref(typ, prc_typ->bits, 0);
  4541.  
  4542.    s_store = succ_store;
  4543.    store = get_store(1);
  4544.  
  4545.    if (bitset(prc_typ->bits, str_bit) ||
  4546.        bitset(prc_typ->bits, cset_bit) ||
  4547.        bitset(prc_typ->bits, int_bit) ||
  4548.        bitset(prc_typ->bits, real_bit)) {
  4549.       /*
  4550.        * Assume integer invocation; any argument may be the result type.
  4551.        */
  4552.  
  4553. #ifdef TypTrc
  4554.       if (trcfile != NULL) {
  4555.          fprintf(trcfile, "%s (%d,%d) %s{i}(", n->n_file, n->n_line, n->n_col,
  4556.             trc_indent);
  4557.          }
  4558. #endif                    /* TypTrc */
  4559.  
  4560.       for (i = 0; i < num_args; ++i) {
  4561.          MrgTyp(n_intrtyp, arg_typs->types[i], n->type);
  4562.  
  4563. #ifdef TypTrc
  4564.          if (trcfile != NULL) {
  4565.             if (i > 0)
  4566.                fprintf(trcfile, ", ");
  4567.             prt_typ(trcfile, arg_typs->types[i]);
  4568.             }
  4569. #endif                    /* TypTrc */
  4570.  
  4571.          }
  4572.  
  4573.       /*
  4574.        * Integer invocation may succeed or fail.
  4575.        */
  4576.       ret_flag |= DoesRet | DoesFail;
  4577.       mrg_store(s_store, store);
  4578.       mrg_store(s_store, fail_store);
  4579.  
  4580. #ifdef TypTrc
  4581.       if (trcfile != NULL) {
  4582.          fprintf(trcfile, ")  =>>  ");
  4583.          prt_typ(trcfile, n->type);
  4584.          fprintf(trcfile, "\n");
  4585.          }
  4586. #endif                    /* TypTrc */
  4587.       }
  4588.  
  4589.    if (bitset(prc_typ->bits, str_bit) ||
  4590.        bitset(prc_typ->bits, cset_bit)) {
  4591.       /*
  4592.        * Assume string invocation; add all procedure types to the thing
  4593.        *  being invoked.
  4594.        */
  4595.       for (i = 0; i < num_prcs; ++i)
  4596.          set_typ(prc_typ->bits, frst_prc + i);
  4597.       }
  4598.  
  4599.    if (bitset(prc_typ->bits, frst_prc)) {
  4600.       /*
  4601.        * First procedure type represents all operators that are
  4602.        *  available via string invocation. Scan the operator table
  4603.        *  looking for those that are in the string invocation table.
  4604.        *  Note, this is not particularly efficient or precise.
  4605.        */
  4606.       for (i = 0; i < IHSize; ++i)
  4607.          for (ip = ohash[i]; ip != NULL; ip = ip->blink)
  4608.             if (ip->iconc_flgs & InStrTbl) {
  4609.                succ_store = cpy_store(s_store);
  4610.                infer_impl(ip, n, n->symtyps, n->type);
  4611.                ret_flag |= ip->ret_flag;
  4612.                mrg_store(succ_store, store);
  4613.                free_store(succ_store);
  4614.                }
  4615.       }
  4616.  
  4617.    /*
  4618.     * Check for procedure, built-in, and record constructor types
  4619.     *  and perform type inference on invocations of them.
  4620.     */
  4621.    for (i = 1; i < num_prcs; ++i)
  4622.       if (bitset(prc_typ->bits, frst_prc + i)) {
  4623.          succ_store = cpy_store(s_store);
  4624.          gptr = proc_map[i];
  4625.          switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) {
  4626.             case F_Proc:
  4627.                infer_prc(gptr->val.proc, n);
  4628.                ret_flag |= gptr->val.proc->ret_flag;
  4629.                break;
  4630.             case F_Builtin:
  4631.                infer_impl(gptr->val.builtin, n, n->symtyps, n->type);
  4632.                ret_flag |= gptr->val.builtin->ret_flag;
  4633.                break;
  4634.             case F_Record:
  4635.                infer_con(gptr->val.rec, n);
  4636.                ret_flag |= DoesRet | (err_conv ? DoesFail : 0);
  4637.                break;
  4638.             }
  4639.          mrg_store(succ_store, store);
  4640.          free_store(succ_store);
  4641.          }
  4642.  
  4643.    /*
  4644.     * If error conversion is supported and a non-procedure value
  4645.     *   might be invoked, assume the invocation can fail.
  4646.     */
  4647.    if (err_conv && other_type(prc_typ->bits, proc_typ))
  4648.       mrg_store(s_store, fail_store);
  4649.  
  4650.    free_store(s_store);
  4651.    succ_store = store;
  4652.    chk_succ(ret_flag, n->store);
  4653.  
  4654.    free_wktyp(prc_typ);
  4655.  
  4656. #ifdef TypTrc
  4657.    if (trcfile != NULL) {
  4658.       fprintf(trcfile, "%s (%d,%d) }\n", n->n_file, n->n_line, n->n_col);
  4659.       trc_indent = "";
  4660.       }
  4661. #endif                    /* TypTrc */
  4662.    }
  4663.  
  4664. /*
  4665.  * get_wktyp - get a dynamically allocated bit vector to use as a
  4666.  *  work area for doing type computations.
  4667.  */
  4668. static struct type *get_wktyp()
  4669.    {
  4670.    struct type *typ;
  4671.  
  4672.    if ((typ = type_pool) == NULL) {
  4673.       typ = NewStruct(type);
  4674.       typ->size = n_rttyp;
  4675.       typ->bits = alloc_typ(n_rttyp);
  4676.       }
  4677.    else {
  4678.       type_pool = type_pool->next;
  4679.       ClrTyp(n_rttyp, typ->bits);
  4680.       }
  4681.    return typ;
  4682.    }
  4683.  
  4684. /*
  4685.  * free_wktyp - free a dynamically allocated type bit vector.
  4686.  */
  4687. static novalue free_wktyp(typ)
  4688. struct type *typ;
  4689.    {
  4690.    typ->next = type_pool;
  4691.    type_pool = typ;
  4692.    }
  4693.  
  4694. /*
  4695.  * bitset - determine if a specific bit in a bit vector is set.
  4696.  */
  4697. static int bitset(typ, bit)
  4698. unsigned int *typ;
  4699. int bit;
  4700.    {
  4701.    int mask;
  4702.    int indx;
  4703.  
  4704.    indx = bit / IntBits;
  4705.    mask = 1;
  4706.    mask <<= bit % IntBits;
  4707.    return typ[indx] & mask;
  4708.    }
  4709.  
  4710. #ifdef TypTrc
  4711.  
  4712. /*
  4713.  * ChkSep - supply a separating space if this is not the first item.
  4714.  */
  4715. #define ChkSep(n) (++n > 1 ? " " : "")
  4716.  
  4717. /*
  4718.  * prt_typ - print a type that can include variable references.
  4719.  */
  4720. static novalue prt_typ(file, typ)
  4721. FILE *file;
  4722. unsigned int *typ;
  4723.    {
  4724.    struct gentry *gptr;
  4725.    struct lentry *lptr;
  4726.    char *name;
  4727.    int i, j, k;
  4728.    int n;
  4729.    int frst_bit;
  4730.    int num_bits;
  4731.    char *abrv;
  4732.  
  4733.    fprintf(trcfile, "{");
  4734.    n = 0;
  4735.    /*
  4736.     * Go through the types and see any sub-types are present.
  4737.     */
  4738.    for (k = 0; k < num_typs; ++k) {
  4739.       frst_bit = type_array[k].frst_bit;
  4740.       num_bits = type_array[k].num_bits;
  4741.       abrv = icontypes[k].abrv;
  4742.       if (k == proc_typ) {
  4743.          /*
  4744.           * procedures, record constructors, and built-in functions.
  4745.           */
  4746.          for (i = 0; i < num_bits; ++i)
  4747.             if (bitset(typ, frst_bit + i)) {
  4748.                if (i == 0)
  4749.                   fprintf(file, "%sops", ChkSep(n));
  4750.                else {
  4751.                   gptr = proc_map[i];
  4752.                   switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) {
  4753.                      case F_Proc:
  4754.                         fprintf(file, "%s%s:%s", ChkSep(n), abrv, gptr->name);
  4755.                         break;
  4756.                      case F_Builtin:
  4757.                         fprintf(file, "%sfnc:%s", ChkSep(n), gptr->name);
  4758.                         break;
  4759.                      case F_Record:
  4760.                         fprintf(file, "%sconstr:%s", ChkSep(n), gptr->name);
  4761.                         break;
  4762.                      }
  4763.                   }
  4764.                }
  4765.          }
  4766.       else if (k == rec_typ) {
  4767.          /*
  4768.           * records - include record name.
  4769.           */
  4770.          for (i = 0; i < num_bits; ++i)
  4771.             if (bitset(typ, frst_bit + i))
  4772.                fprintf(file, "%s%s:%s", ChkSep(n), abrv, rec_map[i]->name);
  4773.          }
  4774.       else if (icontypes[k].support_new | k == coexp_typ) {
  4775.          /*
  4776.           * A type with sub-types.
  4777.           */
  4778.          for (i = 0; i < num_bits; ++i)
  4779.             if (bitset(typ, frst_bit + i))
  4780.                fprintf(file, "%s%s%d", ChkSep(n), abrv, i);
  4781.          }
  4782.       else {
  4783.          /*
  4784.           * A type with no subtypes.
  4785.           */
  4786.          if (bitset(typ, frst_bit))
  4787.             fprintf(file, "%s%s", ChkSep(n), abrv);
  4788.          }
  4789.       }
  4790.  
  4791.    for (k = 0; k < num_cmpnts; ++k) {
  4792.       if (typecompnt[k].var) {
  4793.          /*
  4794.           * Structure component that is a variable.
  4795.           */
  4796.          frst_bit = compnt_array[k].frst_bit;
  4797.          num_bits = compnt_array[k].num_bits;
  4798.          abrv = typecompnt[k].abrv;
  4799.          for (i = 0; i < num_bits; ++i)
  4800.             if (bitset(typ, frst_bit + i))
  4801.                fprintf(file, "%s%s%d", ChkSep(n), abrv, i);
  4802.          }
  4803.       }
  4804.  
  4805.  
  4806.    /*
  4807.     * record fields
  4808.     */
  4809.    for (i = 0; i < n_fld; ++i)
  4810.       if (bitset(typ, frst_fld + i))
  4811.          fprintf(file, "%sfld%d", ChkSep(n), i);
  4812.  
  4813.    /*
  4814.     * global variables
  4815.     */
  4816.    for (i = 0; i < n_nmgbl; ++i)
  4817.       if (bitset(typ, frst_gbl + i)) {
  4818.          name = NULL;
  4819.          for (j = 0; j < GHSize && name == NULL; j++)
  4820.             for (gptr = ghash[j]; gptr != NULL && name == NULL; 
  4821.                gptr = gptr->blink)
  4822.                   if (gptr->index == i)
  4823.                      name = gptr->name;
  4824.          for (lptr = cur_proc->statics; lptr != NULL && name == NULL;
  4825.             lptr = lptr->next)
  4826.                if (lptr->val.index == i)
  4827.                   name = lptr->name;
  4828.          /*
  4829.           * Static variables may be returned and dereferenced in a procedure
  4830.           *  they don't belong to.
  4831.           */
  4832.          if (name == NULL)
  4833.             name = "?static?";
  4834.          fprintf(file, "%svar:%s", ChkSep(n), name);
  4835.          }
  4836.  
  4837.    /*
  4838.     * local variables
  4839.     */
  4840.    for (i = 0; i < n_loc; ++i)
  4841.       if (bitset(typ, frst_loc + i)) {
  4842.          name = NULL;
  4843.          for (lptr = cur_proc->args; lptr != NULL && name == NULL;
  4844.             lptr = lptr->next)
  4845.                if (lptr->val.index == i)
  4846.                   name = lptr->name;
  4847.          for (lptr = cur_proc->dynams; lptr != NULL && name == NULL;
  4848.             lptr = lptr->next)
  4849.                if (lptr->val.index == i)
  4850.                   name = lptr->name;
  4851.          /*
  4852.           * Local variables types may appear in the wrong procedure due to
  4853.           *  substring trapped variables and the inference of impossible
  4854.           *  execution paths. Make sure we don't end up with a NULL name.
  4855.           */
  4856.          if (name == NULL)
  4857.             name = "?";
  4858.          fprintf(file, "%svar:%s", ChkSep(n), name);
  4859.          }
  4860.  
  4861.    fprintf(trcfile, "}");
  4862.    }
  4863.  
  4864. /*
  4865.  * prt_d_typ - dereference a type and print it.
  4866.  */
  4867. static novalue prt_d_typ(file, typ)
  4868. FILE *file;
  4869. unsigned int *typ;
  4870.    {
  4871.    struct type *wktyp;
  4872.  
  4873.    wktyp = get_wktyp();
  4874.    typ_deref(typ, wktyp->bits, 0);
  4875.    prt_typ(file, wktyp->bits);
  4876.    free_wktyp(wktyp);
  4877.    }
  4878. #endif                    /* TypTrc */
  4879.  
  4880. /*
  4881.  * get_argtyp - get an array of pointers to type bit vectors for use
  4882.  *  in constructing an argument list. The array is large enough for the
  4883.  *  largest argument list.
  4884.  */ 
  4885. static struct argtyps *get_argtyp()
  4886.    {
  4887.    struct argtyps *argtyps;
  4888.  
  4889.    if ((argtyps = argtyp_pool) == NULL)
  4890.      argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) +
  4891.       ((max_prm - 1) * sizeof(unsigned int *))));
  4892.    else 
  4893.       argtyp_pool = argtyp_pool->next;
  4894.    return argtyps;
  4895.    }
  4896.  
  4897. /*
  4898.  * free_argtyp - free array of pointers to type bitvectors.
  4899.  */
  4900. static novalue free_argtyp(argtyps)
  4901. struct argtyps *argtyps;
  4902.    {
  4903.    argtyps->next = argtyp_pool;
  4904.    argtyp_pool = argtyps;
  4905.    }
  4906.  
  4907. /*
  4908.  * varsubtyp - examine a type and determine what kinds of variable
  4909.  *  subtypes it has and whether it has any non-variable subtypes.
  4910.  *  If the type consists of a single named variable, return its symbol
  4911.  *  table entry through the parameter "single".
  4912.  */
  4913. int varsubtyp(typ, single)
  4914. unsigned int *typ;
  4915. struct lentry **single;
  4916.    {
  4917.    struct store *stv_stor;
  4918.    int subtypes;
  4919.    int n_types;
  4920.    int var_indx;
  4921.    int frst_bit;
  4922.    int num_bits;
  4923.    int i, j;
  4924.  
  4925.  
  4926.    subtypes = 0;
  4927.    n_types = 0;
  4928.    var_indx = -1;
  4929.  
  4930.    /*
  4931.     * check for non-variables.
  4932.     */
  4933.    for (i = 0; i < n_icntyp; ++i)
  4934.       if (bitset(typ, i)) {
  4935.          subtypes |= HasVal;
  4936.          ++n_types;
  4937.          }
  4938.  
  4939.    /* 
  4940.     * Predefined variable types.
  4941.     */
  4942.    for (i = 0; i < num_typs; ++i) {
  4943.       if (icontypes[i].deref != DrfNone) {
  4944.          frst_bit = type_array[i].frst_bit;
  4945.          num_bits = type_array[i].num_bits;
  4946.          for (j = 0; j < num_bits; ++j) {
  4947.             if (bitset(typ, frst_bit + j)) {
  4948.                if (i == stv_typ) {
  4949.                   /*
  4950.                    * We have found substring trapped variable j, see whether it
  4951.                    *  references locals or globals.
  4952.                    */
  4953.                   if (do_typinfer) {
  4954.                      stv_stor = compnt_array[str_var].store;
  4955.                      subtypes |= varsubtyp(stv_stor->types[j], NULL);
  4956.                      }
  4957.                   else
  4958.                      subtypes |= HasLcl | HasPrm | HasGlb;
  4959.                   }
  4960.                else
  4961.                   subtypes |= HasGlb;
  4962.                ++n_types;
  4963.                }
  4964.             }
  4965.          }
  4966.       }
  4967.  
  4968.    /*
  4969.     * Aggregate compontents that are variables.
  4970.     */
  4971.    for (i = 0; i < num_cmpnts; ++i) {
  4972.       if (typecompnt[i].var) {
  4973.          frst_bit = compnt_array[i].frst_bit;
  4974.          num_bits = compnt_array[i].num_bits;
  4975.          for (j = 0; j < num_bits; ++j) {
  4976.             if (bitset(typ, frst_bit + j)) {
  4977.                subtypes |= HasGlb;
  4978.                ++n_types;
  4979.                }
  4980.             }
  4981.          }
  4982.       }
  4983.  
  4984.    /*
  4985.     * record fields
  4986.     */
  4987.    for (i = 0; i < n_fld; ++i)
  4988.       if (bitset(typ, frst_fld + i)) {
  4989.          subtypes |= HasGlb;
  4990.          ++n_types;
  4991.          }
  4992.  
  4993.    /*
  4994.     * global variables, including statics
  4995.     */
  4996.    for (i = 0; i < n_gbl; ++i) {
  4997.       if (bitset(typ, frst_gbl + i)) {
  4998.          subtypes |= HasGlb;
  4999.          var_indx = i;
  5000.          ++n_types;
  5001.          }
  5002.       }
  5003.  
  5004.    /*
  5005.     * local variables
  5006.     */
  5007.    for (i = 0; i < n_loc; ++i) {
  5008.       if (bitset(typ, frst_loc + i)) {
  5009.          if (i < Abs(cur_proc->nargs))
  5010.             subtypes |= HasPrm;
  5011.          else
  5012.             subtypes |= HasLcl;
  5013.          var_indx = n_gbl + i;
  5014.          ++n_types;
  5015.          }
  5016.       }
  5017.  
  5018.    if (single != NULL) {
  5019.       /*
  5020.        *  See if the type consists of a single named variable.
  5021.        */
  5022.       if (n_types == 1 && var_indx != -1)
  5023.          *single = cur_proc->vartypmap[var_indx];
  5024.       else
  5025.          *single = NULL;
  5026.       }
  5027.  
  5028.    return subtypes;
  5029.    }
  5030.  
  5031. /*
  5032.  * mark_recs - go through the list of parent records for this field
  5033.  *  and mark those that are in the type. Also gather information
  5034.  *  to help generate better code.
  5035.  */
  5036. novalue mark_recs(fp, typ, num_offsets, offset, bad_recs)
  5037. struct fentry *fp;
  5038. unsigned int *typ;
  5039. int *num_offsets;
  5040. int *offset;
  5041. int *bad_recs;
  5042.    {
  5043.    struct par_rec *rp;
  5044.    struct type *wktyp;
  5045.    int frst_rec;
  5046.    
  5047.    *num_offsets = 0;
  5048.    *offset = -1;
  5049.    *bad_recs = 0;
  5050.  
  5051.    wktyp = get_wktyp();
  5052.    CpyTyp(n_icntyp, typ, wktyp->bits);
  5053.  
  5054.    /*
  5055.     * For each record containing this field, see if the record is
  5056.     *  in the type.
  5057.     */
  5058.    frst_rec = type_array[rec_typ].frst_bit;
  5059.    for (rp = fp->rlist; rp != NULL; rp = rp->next) {
  5060.       if (bitset(wktyp->bits, frst_rec + rp->rec->rec_num)) {
  5061.          /*
  5062.           * This record is in the type.
  5063.           */
  5064.          rp->mark = 1;
  5065.          clr_typ(wktyp->bits, frst_rec + rp->rec->rec_num);
  5066.          if (*offset != rp->offset) {
  5067.             *offset = rp->offset;
  5068.             *num_offsets += 1;
  5069.             }
  5070.         }
  5071.       }
  5072.  
  5073.    /*
  5074.     * Are there any records that do not contain this field?
  5075.     */
  5076.    *bad_recs = has_type(wktyp->bits, rec_typ, 0);
  5077.    free_wktyp(wktyp);
  5078.    }
  5079.  
  5080. /*
  5081.  * past_prms - return true if execution might continue past the parameter
  5082.  *  evaluation. If a parameter has no type, this will not happen.
  5083.  */
  5084. int past_prms(n)
  5085. nodeptr n;
  5086.    {
  5087.    struct implement *impl;
  5088.    struct symtyps *symtyps;
  5089.    int nparms;
  5090.    int nargs;
  5091.    int flag;
  5092.    int i, j;
  5093.  
  5094.    nargs = Val0(n);
  5095.    impl = Impl1(n);
  5096.    symtyps = n->symtyps;
  5097.    nparms = impl->nargs;
  5098.  
  5099.    if (symtyps == NULL)
  5100.       return 1;
  5101.  
  5102.    j = 0;
  5103.    for (i = 0; i < nparms; ++i) {
  5104.       flag = impl->arg_flgs[i];
  5105.       if (flag & VarPrm && i >= nargs)
  5106.           break;       /* no parameters for variable part of arg list */
  5107.       if (flag & RtParm) {
  5108.          if (is_empty(symtyps->types[j]))
  5109.             return 0;
  5110.          ++j;
  5111.          }
  5112.       if (flag & DrfPrm) {
  5113.          if (is_empty(symtyps->types[j]))
  5114.             return 0;
  5115.          ++j;
  5116.          }
  5117.       }
  5118.    return 1;
  5119.    }
  5120.  
  5121. /*
  5122.  * is_empty - determine if a type bit vector is empty.
  5123.  */
  5124. static int is_empty(typ)
  5125. unsigned int *typ;
  5126.    {
  5127.    int i;
  5128.  
  5129.    for (i = 0; i < NumInts(n_intrtyp); ++i) {
  5130.        if (typ[i] != 0)
  5131.           return 0;
  5132.        }
  5133.    return 1;
  5134.    }
  5135.