diff options
Diffstat (limited to 'src/iconc/typinfer.c')
| -rw-r--r-- | src/iconc/typinfer.c | 5189 |
1 files changed, 5189 insertions, 0 deletions
diff --git a/src/iconc/typinfer.c b/src/iconc/typinfer.c new file mode 100644 index 0000000..8a96e23 --- /dev/null +++ b/src/iconc/typinfer.c @@ -0,0 +1,5189 @@ +/* + * typinfer.c - routines to perform type inference. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ctoken.h" +#include "cglobals.h" +#include "ccode.h" +#include "cproto.h" +#ifdef TypTrc +#ifdef HighResTime +#include <sys/time.h> +#include <sys/resource.h> +#endif /* HighResTime */ +#endif /* TypTrc */ + +/* + * Information about co-expressions is keep on a list. + */ +struct t_coexpr { + nodeptr n; /* code for co-expression */ + int typ_indx; /* relative type number (index) */ + struct store *in_store; /* store entry into co-expression via activation */ + struct store *out_store; /* store at end of co-expression */ +#ifdef OptimizeType + struct typinfo *act_typ; /* types passed via co-expression activation */ + struct typinfo *rslt_typ; /* types resulting from "co-expression return" */ +#else /* OptimizeType */ + unsigned int *act_typ; /* types passed via co-expression activation */ + unsigned int *rslt_typ; /* types resulting from "co-expression return" */ +#endif /* OptimizeType */ + int iteration; + struct t_coexpr *next; + }; + +struct t_coexpr *coexp_lst; + +#ifdef TypTrc +extern int typealloc; /* flag to account for allocation */ +extern long typespace; /* amount of space for type inference */ +#endif /* TypTrc */ + +struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ + +/* + * argtyps is the an array of types large enough to accommodate the argument + * list of any operation. + */ +struct argtyps { + struct argtyps *next; +#ifdef OptimizeType + struct typinfo *types[1]; /* actual size is max_prm */ +#else /* OptimizeType */ + unsigned int *types[1]; /* actual size is max_prm */ +#endif /* OptimizeType */ + }; + +/* + * prototypes for static functions. + */ +#ifdef OptimizeType +void and_bits_to_packed (struct typinfo *src, + struct typinfo *dest, int size); +struct typinfo *alloc_typ (int n_types); +unsigned int *alloc_mem_typ (unsigned int n_types); +int bitset (struct typinfo *typ, int bit); +void clr_typ (struct typinfo *type, unsigned int bit); +void clr_packed (struct typinfo *src, int nsize); +void cpy_packed_to_packed (struct typinfo *src, + struct typinfo *dest, int nsize); +static void deref_lcl (struct typinfo *src, + struct typinfo *dest); +static int findloops ( struct node *n, int resume, + struct typinfo *rslt_type); +static void gen_inv (struct typinfo *prc_typ, nodeptr n); +int has_type (struct typinfo *typ, int typcd, int clear); +static void infer_impl (struct implement *impl, + nodeptr n, struct symtyps *symtyps, + struct typinfo *rslt_typ); +int is_empty (struct typinfo *typ); +int mrg_packed_to_packed (struct typinfo *src, + struct typinfo *dest, int nsize); +int other_type (struct typinfo *typ, int typcd); +static void set_ret (struct typinfo *typ); +void set_typ (struct typinfo *type, unsigned int bit); +void typcd_bits (int typcd, struct type *typ); +static void typ_deref (struct typinfo *src, + struct typinfo *dest, int chk); +int xfer_packed_to_bits (struct typinfo *src, + struct typinfo *dest, int nsize); +#else /* OptimizeType */ +unsigned int *alloc_typ (int n_types); +int bitset (unsigned int *typ, int bit); +void clr_typ (unsigned int *type, unsigned int bit); +static void deref_lcl (unsigned int *src, unsigned int *dest); +static int findloops ( struct node *n, int resume, + unsigned int *rslt_type); +static void gen_inv (unsigned int *prc_typ, nodeptr n); +int has_type (unsigned int *typ, int typcd, int clear); +static void infer_impl (struct implement *impl, + nodeptr n, struct symtyps *symtyps, + unsigned int *rslt_typ); +int is_empty (unsigned int *typ); +int other_type (unsigned int *typ, int typcd); +static void set_ret (unsigned int *typ); +void set_typ (unsigned int *type, unsigned int bit); +void typcd_bits (int typcd, struct type *typ); +static void typ_deref (unsigned int *src, unsigned int *dest, int chk); +#endif /* OptimizeType */ + +static void abstr_new (struct node *n, struct il_code *il); +static void abstr_typ (struct il_code *il, struct type *typ); +static struct store *alloc_stor (int stor_sz, int n_types); +static void chk_succ (int ret_flag, struct store *susp_stor); +static struct store *cpy_store (struct store *source); +static int eval_cond (struct il_code *il); +static void free_argtyp (struct argtyps *argtyps); +static void free_store (struct store *store); +static void free_wktyp (struct type *typ); +static void find_new (struct node *n); +static struct argtyps *get_argtyp (void); +static struct store *get_store (int clear); +static struct type *get_wktyp (void); +static void infer_act (nodeptr n); +static void infer_con (struct rentry *rec, nodeptr n); +static int infer_il (struct il_code *il); +static void infer_nd (nodeptr n); +static void infer_prc (struct pentry *proc, nodeptr n); +static void mrg_act (struct t_coexpr *coexp, + struct store *e_store, + struct type *rslt_typ); +static void mrg_store (struct store *source, struct store *dest); +static void side_effect (struct il_code *il); +static struct symtyps *symtyps (int nsyms); + +#ifdef TypTrc +static void prt_d_typ (FILE *file, struct typinfo *typ); +static void prt_typ (FILE *file, struct typinfo *typ); +#endif /* TypTrc */ + +#define CanFail 1 + +/* + * cur_coexp is non-null while performing type inference on code from a + * create expression. If it is null, the possible current co-expressions + * must be found from cur_proc. + */ +struct t_coexpr *cur_coexp = NULL; + +struct gentry **proc_map; /* map procedure types to symbol table entries */ +struct rentry **rec_map; /* map record types to record information */ +struct t_coexpr **coexp_map; /* map co-expression types to information */ + +struct typ_info *type_array; + +static int num_new; /* number of types supporting "new" abstract type comp */ + +/* + * Data base component codes are mapped to type inferencing information + * using an array. + */ +struct compnt_info { + int frst_bit; /* first bit in bit vector allocated to component */ + int num_bits; /* number of bits allocated to this component */ + struct store *store; /* maps component "reference" to the type it holds */ + }; +static struct compnt_info *compnt_array; + +static unsigned int frst_fld; /* bit number of 1st record field */ +static unsigned int n_fld; /* number of record fields */ +static unsigned int frst_gbl; /* bit number of 1st global reference type */ +static unsigned int n_gbl; /* number of global variables */ +static unsigned int n_nmgbl; /* number of named global variables */ +static unsigned int frst_loc; /* bit number of 1st local reference type */ +static unsigned int n_loc; /* maximum number of locals in any procedure */ + +static unsigned int nxt_bit; /* next unassigned bit in bit vector */ +unsigned int n_icntyp; /* number of non-variable types */ +unsigned int n_intrtyp; /* number of types in intermediate values */ +static unsigned int n_rttyp; /* number of types in runtime computations */ +unsigned int val_mask; /* mask for non-var types in last int of type */ + +unsigned int null_bit; /* bit for null type */ +unsigned int str_bit; /* bit for string type */ +unsigned int cset_bit; /* bit for cset type */ +unsigned int int_bit; /* bit for integer type */ +unsigned int real_bit; /* bit for real type */ + +static struct store *fld_stor; /* record fields */ + +static int *cur_new; /* allocated types for current operation */ + +static struct store *succ_store = NULL; /* current success store */ +static struct store *fail_store = NULL; /* current failure store */ + +static struct store *dummy_stor; +static struct store *store_pool = NULL; /* free list of store structs */ + +static struct type *type_pool = NULL; /* free list of type structs */ +static struct type cur_rslt = {0, NULL, NULL}; /* result type of operation */ + +static struct argtyps *argtyp_pool = NULL; /* free list of arg type arrays */ +static struct argtyps *arg_typs = NULL; /* current arg type array */ + +static int num_args; /* number of arguments for current operation */ +static int n_vararg; /* size of variable part of arg list to run-time routine */ + +#ifdef OptimizeType +static struct typinfo *any_typ; /* type bit vector with all bits on */ +struct typinfo *free_typinfo = NULL; +struct typinfo *start_typinfo = NULL; +struct typinfo *high_typinfo = NULL; +struct typinfo *low_typinfo = NULL; +#else /* OptimizeType */ +static unsigned int *any_typ; /* type bit vector with all bits on */ +#endif /* OptimizeType */ + +long changed; /* number of changes to type information in this iteration */ +int iteration; /* iteration number for type inferencing */ + +#ifdef TypTrc +static FILE *trcfile = NULL; /* output file pointer for tracing */ +static char *trcname = NULL; /* output file name for tracing */ +static char *trc_indent = ""; +#endif /* TypTrc */ + + +/* + * typeinfer - infer types of operands. If "do_typinfer" is set, actually + * do abstract interpretation, otherwise assume any type for all operands. + */ +void typeinfer() + { + struct gentry *gptr; + struct lentry *lptr; + nodeptr call_main; + struct pentry *p; + struct rentry *rec; + struct t_coexpr *coexp; + struct store *init_store; + struct store *f_store; +#ifdef OptimizeType + struct typinfo *type; +#else /* OptimizeType */ + unsigned int *type; +#endif /* OptimizeType */ + struct implement *ip; + struct lentry **lhash; + struct lentry **vartypmap; + int i, j, k; + int size; + int flag; + +#ifdef TypTrc + /* + * Set up for type tracing. + */ + long start_infer, end_infer; + +#ifdef HighResTime + struct rusage rusage; + + getrusage(RUSAGE_SELF, &rusage); + start_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; +#else /* HighResTime */ + start_infer = millisec(); +#endif /* HighResTime */ + + typealloc = 1; /* note allocation in this phase */ + + trcname = getenv("TYPTRC"); + + if (trcname != NULL && strlen(trcname) != 0) { + + if (trcname[0] == '|') { + FILE *popen(); + + trcfile = popen(trcname+1, "w"); + } + else + + trcfile = fopen(trcname, "w"); + + if (trcfile == NULL) { + fprintf(stderr, "TYPTRC: cannot open %s\n", trcname); + fflush(stderr); + exit(EXIT_FAILURE); + } + } +#endif /* TypTrc */ + + /* + * Make sure max_prm is large enough for any run-time routine. + */ + for (i = 0; i < IHSize; ++i) + for (ip = bhash[i]; ip != NULL; ip = ip->blink) + if (ip->nargs > max_prm) + max_prm = ip->nargs; + for (i = 0; i < IHSize; ++i) + for (ip = ohash[i]; ip != NULL; ip = ip->blink) + if (ip->nargs > max_prm) + max_prm = ip->nargs; + + /* + * Allocate an arrays to map data base type codes and component codes + * to type inferencing information. + */ + type_array = (struct typ_info *)alloc((unsigned int)(num_typs * + sizeof(struct typ_info))); + compnt_array = (struct compnt_info *)alloc((unsigned int)(num_cmpnts * + sizeof(struct compnt_info))); + + /* + * Find those types that support the "new" abstract type computation + * assign to them locations in the arrays of allocated types associated + * with operation invocations. Also initialize the number of type bits. + * Types with no subtypes have one bit. Types allocated with the the "new" + * abstract have a default sub-type that is allocated here. Procedures + * have a subtype to for string invocable operators. Co-expressions + * have a subtype for &main. Records are handled below. + */ + num_new = 0; + for (i = 0; i < num_typs; ++i) { + if (icontypes[i].support_new) + type_array[i].new_indx = num_new++; + type_array[i].num_bits = 1; /* reserve one type bit */ + } + type_array[list_typ].num_bits = 2; /* default & list for arg to main() */ + + cur_coexp = NewStruct(t_coexpr); + cur_coexp->n = NULL; + cur_coexp->next = NULL; + coexp_lst = cur_coexp; + + if (do_typinfer) { + /* + * Go through the syntax tree for each procedure locating program + * points that may create structures at run time. Allocate the + * appropriate structure type(s) to each such point. + */ + for (p = proc_lst; p != NULL; p = p->next) { + if (p->nargs < 0) + p->arg_lst = type_array[list_typ].num_bits++; /* list for varargs */ + find_new(Tree1(p->tree)); /* initial clause */ + find_new(Tree2(p->tree)); /* body of procedure */ + } + } + + /* + * Allocate a type number for each record type (use record number for + * offset) and a variable type number for each field. + */ + n_fld = 0; + if (rec_lst == NULL) { + type_array[rec_typ].num_bits = 0; + rec_map = NULL; + } + else { + type_array[rec_typ].num_bits = rec_lst->rec_num + 1; + rec_map = (struct rentry **)alloc( + (unsigned int)((rec_lst->rec_num + 1)*sizeof(struct rentry *))); + for (rec = rec_lst; rec != NULL; rec = rec->next) { + rec->frst_fld = n_fld; + n_fld += rec->nfields; + rec_map[rec->rec_num] = rec; + } + } + + /* + * Allocate type numbers to global variables. Don't count those procedure + * variables that are no longer referenced in the syntax tree. Do count + * static variables. Also allocate types to procedures, built-in functions, + * record constructors. + */ + n_gbl = 0; + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag; + if (flag & F_SmplInv) + gptr->index = -1; /* unused: set to something not a valid type */ + else { + gptr->index = n_gbl++; + if (flag & (F_Proc | F_Record | F_Builtin)) + gptr->init_type = type_array[proc_typ].num_bits++; + } + if (flag & F_Proc) { + for (lptr = gptr->val.proc->statics; lptr != NULL;lptr = lptr->next) + lptr->val.index = n_gbl++; + } + } + n_nmgbl = n_gbl; + + /* + * Determine relative bit numbers for predefined variable types that + * are treated as sets of global variables. + */ + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfGlbl) + type_array[i].frst_bit = n_gbl++; /* converted to absolute later */ + + proc_map = (struct gentry **)alloc( + (unsigned int)((type_array[proc_typ].num_bits)*sizeof(struct gentry *))); + proc_map[0] = NULL; /* proc type for string invocable operators */ + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag; + if (!(flag & F_SmplInv) && (flag & (F_Proc | F_Record | F_Builtin))) + proc_map[gptr->init_type] = gptr; + } + + /* + * Allocate type numbers to local variables. The same numbers are reused + * in different procedures. + */ + n_loc = 0; + for (p = proc_lst; p != NULL; p = p->next) { + i = Abs(p->nargs); + for (lptr = p->args; lptr != NULL; lptr = lptr->next) + lptr->val.index = --i; + i = Abs(p->nargs); + for (lptr = p->dynams; lptr != NULL; lptr = lptr->next) + lptr->val.index = i++; + n_loc = Max(n_loc, i); + + /* + * produce a mapping from the variable types used in this procedure + * to the corresponding symbol table entries. + */ + if (n_gbl + n_loc == 0) + vartypmap = NULL; + else + vartypmap = (struct lentry **)alloc( + (unsigned int)((n_gbl + n_loc)*sizeof(struct lentry *))); + for (i = 0; i < n_gbl + n_loc; ++i) + vartypmap[i] = NULL; /* no entries for foreign statics */ + p->vartypmap = vartypmap; + lhash = p->lhash; + for (i = 0; i < LHSize; ++i) { + for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { + switch (lptr->flag) { + case F_Global: + gptr = lptr->val.global; + if (!(gptr->flag & F_SmplInv)) + vartypmap[gptr->index] = lptr; + break; + case F_Static: + vartypmap[lptr->val.index] = lptr; + break; + case F_Dynamic: + case F_Argument: + vartypmap[n_gbl + lptr->val.index] = lptr; + } + } + } + } + + /* + * There is a component reference subtype for every subtype of the + * associated aggregate type. + */ + for (i = 0; i < num_cmpnts; ++i) + compnt_array[i].num_bits = type_array[typecompnt[i].aggregate].num_bits; + + /* + * Assign bits for non-variable (first-class) types. + */ + nxt_bit = 0; + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfNone) { + type_array[i].frst_bit = nxt_bit; + nxt_bit += type_array[i].num_bits; + } + + n_icntyp = nxt_bit; /* number of first-class types */ + + /* + * Load some commonly needed bit numbers into global variable. + */ + null_bit = type_array[null_typ].frst_bit; + str_bit = type_array[str_typ].frst_bit; + cset_bit = type_array[cset_typ].frst_bit; + int_bit = type_array[int_typ].frst_bit; + real_bit = type_array[real_typ].frst_bit; + + /* + * Assign bits for predefined variable types that are not treated as + * sets of globals. + */ + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfCnst || icontypes[i].deref == DrfSpcl) { + type_array[i].frst_bit = nxt_bit; + nxt_bit += type_array[i].num_bits; + } + + /* + * Assign bits to aggregate compontents that are variables. + */ + for (i = 0; i < num_cmpnts; ++i) + if (typecompnt[i].var) { + compnt_array[i].frst_bit = nxt_bit; + nxt_bit += compnt_array[i].num_bits; + } + + /* + * Assign bits to record fields and named variables. + */ + frst_fld = nxt_bit; + nxt_bit += n_fld; + frst_gbl = nxt_bit; + nxt_bit += n_gbl; + frst_loc = nxt_bit; + nxt_bit += n_loc; + + /* + * Convert from relative to ablsolute bit numbers for predefined variable + * types that are treated as sets of global variables. + */ + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfGlbl) + type_array[i].frst_bit += frst_gbl; + + n_intrtyp = nxt_bit; /* number of types for intermediate values */ + + /* + * Assign bits to aggregate compontents that are not variables. These + * are the runtime system's internal descriptor reference types. + */ + for (i = 0; i < num_cmpnts; ++i) + if (!typecompnt[i].var) { + compnt_array[i].frst_bit = nxt_bit; + nxt_bit += compnt_array[i].num_bits; + } + + n_rttyp = nxt_bit; /* total size of type system */ + +#ifdef TypTrc + if (trcfile != NULL) { + /* + * Output a summary of the type system. + */ + for (i = 0; i < num_typs; ++i) { + fprintf(trcfile, "%s", icontypes[i].id); + if (strcmp(icontypes[i].id, icontypes[i].abrv) != 0) + fprintf(trcfile, "(%s)", icontypes[i].abrv); + fprintf(trcfile, " sub-types: %d\n", type_array[i].num_bits); + } + } +#endif /* TypTrc */ + + /* + * The division between bits for first-class types and variables types + * generally occurs in the middle of a word. Set up a mask for extracting + * the first-class types from this word. + */ + val_mask = 0; + i = n_icntyp - (NumInts(n_icntyp) - 1) * IntBits; + while (i--) + val_mask = (val_mask << 1) | 1; + + if (do_typinfer) { + /* + * Create stores large enough for the component references. These + * are global to the entire program, rather than being propagated + * from node to node in the syntax tree. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (i == str_var) + size = n_intrtyp; + else + size = n_icntyp; + compnt_array[i].store = alloc_stor(compnt_array[i].num_bits, size); + } + fld_stor = alloc_stor(n_fld, n_icntyp); + + dummy_stor = get_store(0); + + /* + * First list is arg to main: a list of strings. + */ + set_typ(compnt_array[lst_elem].store->types[1], str_typ); + } + + /* + * Set up a type bit vector with all bits on. + */ +#ifdef OptimizeType + any_typ = alloc_typ(n_rttyp); + any_typ->bits = alloc_mem_typ(DecodeSize(any_typ->packed)); + for (i = 0; i < NumInts(n_rttyp); ++i) + any_typ->bits[i] = ~(unsigned int)0; +#else /* OptimizeType */ + any_typ = alloc_typ(n_rttyp); + for (i = 0; i < NumInts(n_rttyp); ++i) + any_typ[i] = ~(unsigned int)0; +#endif /* OptimizeType */ + + /* + * Initialize stores and return values for procedures. Also initialize + * flag indicating whether the procedure can be executed. + */ + call_main = NULL; + for (p = proc_lst; p != NULL; p = p->next) { + if (do_typinfer) { + p->iteration = 0; + p->ret_typ = alloc_typ(n_intrtyp); + p->coexprs = alloc_typ(n_icntyp); + p->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (p->ret_flag & DoesSusp) + p->susp_store = alloc_stor(n_gbl, n_icntyp); + else + p->susp_store = NULL; + for (i = Abs(p->nargs); i < n_loc; ++i) + set_typ(p->in_store->types[n_gbl + i], null_bit); + if (p->nargs < 0) + set_typ(p->in_store->types[n_gbl + Abs(p->nargs) - 1], + type_array[list_typ].frst_bit + p->arg_lst); + if (strcmp(p->name, "main") == 0) { + /* + * create a the initial call to main with one list argument. + */ + call_main = invk_main(p); + call_main->type = alloc_typ(n_intrtyp); + Tree2(call_main)->type = alloc_typ(n_intrtyp); + set_typ(Tree2(call_main)->type, type_array[list_typ].frst_bit + 1); + call_main->store = alloc_stor(n_gbl + n_loc, n_icntyp); + } + p->out_store = alloc_stor(n_gbl, n_icntyp); + p->reachable = 0; + } + else + p->reachable = 1; + /* + * Analyze the code of the procedure to determine where to place stores + * that survive iterations of type inferencing. Note, both the initial + * clause and the body of the procedure are bounded. + */ + findloops(Tree1(p->tree), 0, NULL); + findloops(Tree2(p->tree), 0, NULL); + } + + /* + * If type inferencing is suppressed, we have set up very conservative + * type information and will do no inferencing. + */ + if (!do_typinfer) + return; + + if (call_main == NULL) + return; /* no main procedure, cannot continue */ + if (tfatals > 0) + return; /* don't do inference if there are fatal errors */ + + /* + * Construct mapping from co-expression types to information + * about the co-expressions and finish initializing the information. + */ + i = type_array[coexp_typ].num_bits; + coexp_map = (struct t_coexpr **)alloc( + (unsigned int)(i * sizeof(struct t_coexpr *))); + for (coexp = coexp_lst; coexp != NULL; coexp = coexp->next) { + coexp_map[--i] = coexp; + coexp->typ_indx = i; + coexp->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); + coexp->out_store = alloc_stor(n_gbl + n_loc, n_icntyp); + coexp->act_typ = alloc_typ(n_intrtyp); + coexp->rslt_typ = alloc_typ(n_intrtyp); + coexp->iteration = 0; + } + + /* + * initialize globals + */ + init_store = get_store(1); + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag; + if (!(flag & F_SmplInv)) { + type = init_store->types[gptr->index]; + if (flag & (F_Proc | F_Record | F_Builtin)) + set_typ(type, type_array[proc_typ].frst_bit + gptr->init_type); + else + set_typ(type, null_bit); + } + } + + /* + * Initialize types for predefined variable types. + */ + for (i = 0; i < num_typs; ++i) { + type = NULL; + switch (icontypes[i].deref) { + case DrfGlbl: + /* + * Treated as a global variable. + */ + type = init_store->types[type_array[i].frst_bit - frst_gbl]; + break; + case DrfCnst: + /* + * Type doesn't change so keep one copy. + */ + type = alloc_typ(n_intrtyp); + type_array[i].typ = type; + break; + } + if (type != NULL) { + /* + * Determine which types are in the initial type for this variable. + */ + for (j = 0; j < num_typs; ++j) { + if (icontypes[i].typ[j] != '.') { + for (k = 0; k < type_array[j].num_bits; ++k) + set_typ(type, type_array[j].frst_bit + k); + } + } + } + } + + f_store = get_store(1); + + /* + * Type inferencing iterates over the program until a fixed point is + * reached. + */ + changed = 1L; /* force first iteration */ + iteration = 0; + if (verbose > 1) + fprintf(stderr, "type inferencing: "); + + while (changed > 0L) { + changed = 0L; + ++iteration; + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "**** iteration %d ****\n", iteration); +#endif /* TypTrc */ + + /* + * Start at the implicit initial call to the main procedure. Inferencing + * walks the call graph from here. + */ + succ_store = cpy_store(init_store); + fail_store = f_store; + infer_nd(call_main); + + /* + * If requested, monitor the progress of inferencing. + */ + switch (verbose) { + case 0: + case 1: + break; + case 2: + fprintf(stderr, "."); + break; + default: /* > 2 */ + if (iteration != 1) + fprintf(stderr, ", "); + fprintf(stderr, "%ld", changed); + } + } + + /* + * Type inferencing is finished, complete any diagnostic output. + */ + if (verbose > 1) + fprintf(stderr, "\n"); + +#ifdef TypTrc + if (trcfile != NULL) { + +#ifdef HighResTime + getrusage(RUSAGE_SELF, &rusage); + end_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; +#else /* HighResTime */ + end_infer = millisec(); +#endif /* HighResTime */ + fprintf(trcfile, "\n**** inferencing time: %ld milliseconds\n", + end_infer - start_infer); + fprintf(trcfile, "\n**** inferencing space: %ld bytes\n",typespace); + fclose(trcfile); + } + typealloc = 0; +#endif /* TypTrc */ + } + +/* + * find_new - walk the syntax tree allocating structure types where + * operations create new structures. + */ +static void find_new(n) +struct node *n; + { + struct t_coexpr *coexp; + struct node *cases; + struct node *clause; + int nargs; + int i; + + n->new_types = NULL; + switch (n->n_type) { + case N_Cset: + case N_Empty: + case N_Id: + case N_Int: + case N_Next: + case N_Real: + case N_Str: + break; + + case N_Bar: + case N_Break: + case N_Field: + case N_Not: + find_new(Tree0(n)); + break; + + case N_Alt: + case N_Apply: + case N_Limit: + case N_Slist: + find_new(Tree0(n)); + find_new(Tree1(n)); + break; + + case N_Activat: + find_new(Tree1(n)); + find_new(Tree2(n)); + break; + + case N_If: + find_new(Tree0(n)); /* control clause */ + find_new(Tree1(n)); /* then clause */ + find_new(Tree2(n)); /* else clause, may be N_Empty */ + break; + + case N_Create: + /* + * Allocate a sub-type for the co-expressions created here. + */ + n->new_types = (int *)alloc((unsigned int)(sizeof(int))); + n->new_types[0] = type_array[coexp_typ].num_bits++; + coexp = NewStruct(t_coexpr); + coexp->n = Tree0(n); + coexp->next = coexp_lst; + coexp_lst = coexp; + find_new(Tree0(n)); + break; + + case N_Augop: + abstr_new(n, Impl0(n)->in_line); /* assignment */ + abstr_new(n, Impl1(n)->in_line); /* the operation */ + find_new(Tree2(n)); /* 1st operand */ + find_new(Tree3(n)); /* 2nd operand */ + break; + + case N_Case: + find_new(Tree0(n)); /* control clause */ + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + find_new(Tree0(clause)); /* value of clause */ + find_new(Tree1(clause)); /* body of clause */ + } + if (Tree2(n) != NULL) + find_new(Tree2(n)); /* deflt */ + break; + + case N_Invok: + nargs = Val0(n); /* number of arguments */ + find_new(Tree1(n)); /* thing being invoked */ + for (i = 1; i <= nargs; ++i) + find_new(n->n_field[i+1].n_ptr); /* arg i */ + break; + + case N_InvOp: + /* + * This is a call to an operation, this is what we must + * check for "new" abstract type computation. + */ + nargs = Val0(n); /* number of arguments */ + abstr_new(n, Impl1(n)->in_line); /* operation */ + for (i = 1; i <= nargs; ++i) + find_new(n->n_field[i+1].n_ptr); /* arg i */ + break; + + case N_InvProc: + case N_InvRec: + nargs = Val0(n); /* number of arguments */ + for (i = 1; i <= nargs; ++i) + find_new(n->n_field[i+1].n_ptr); /* arg i */ + break; + + case N_Loop: + switch ((int)Val0(Tree0(n))) { + case EVERY: + case SUSPEND: + case WHILE: + case UNTIL: + find_new(Tree1(n)); /* control clause */ + find_new(Tree2(n)); /* do clause - may be N_Empty*/ + break; + + case REPEAT: + find_new(Tree1(n)); /* clause */ + break; + } + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) + find_new(Tree1(n)); /* value - may be N_Empty */ + break; + + case N_Scan: + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) + abstr_new(n, optab[asgn_loc].binary->in_line); + find_new(Tree1(n)); /* subject */ + find_new(Tree2(n)); /* body */ + break; + + case N_Sect: + abstr_new(n, Impl0(n)->in_line); /* sectioning */ + if (Impl1(n) != NULL) + abstr_new(n, Impl1(n)->in_line); /* plus, minus, or nothing */ + find_new(Tree2(n)); /* 1st operand */ + find_new(Tree3(n)); /* 2nd operand */ + find_new(Tree4(n)); /* 3rd operand */ + break; + + case N_SmplAsgn: + case N_SmplAug: + find_new(Tree3(n)); + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + } + +/* + * abstr_new - find the abstract clauses in the implementation of an operation. + * If they indicate that the operations creates structures, allocate a + * type for the structures and associate it with the node in the syntax tree. + */ +static void abstr_new(n, il) +struct node *n; +struct il_code *il; + { + int i; + int num_cases, indx; + struct typ_info *t_info; + + if (il == NULL) + return; + + switch (il->il_type) { + case IL_New: + /* + * We have found a "new" construct in an abstract type computation. + * Make sure an array has been created to hold the types allocated + * to this call, then allocate the indicated type if one has not + * already been allocated. + */ + if (n->new_types == NULL) { + n->new_types = (int *)alloc((unsigned int)(num_new * sizeof(int))); + for (i = 0; i < num_new; ++i) + n->new_types[i] = -1; + } + t_info = &type_array[il->u[0].n]; /* index by type code */ + if (n->new_types[t_info->new_indx] < 0) { + n->new_types[t_info->new_indx] = t_info->num_bits++; +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %s\n", n->n_file, n->n_line, + n->n_col, icontypes[il->u[0].n].id); +#endif /* TypTrc */ + } + i = il->u[1].n; /* num args */ + indx = 2; + while (i--) + abstr_new(n, il->u[indx++].fld); + break; + + case IL_If1: + abstr_new(n, il->u[1].fld); + break; + + case IL_If2: + abstr_new(n, il->u[1].fld); + abstr_new(n, il->u[2].fld); + break; + + case IL_Tcase1: + num_cases = il->u[1].n; + indx = 2; + for (i = 0; i < num_cases; ++i) { + indx += 2; /* skip type info */ + abstr_new(n, il->u[indx++].fld); /* action */ + } + break; + + case IL_Tcase2: + num_cases = il->u[1].n; + indx = 2; + for (i = 0; i < num_cases; ++i) { + indx += 2; /* skip type info */ + abstr_new(n, il->u[indx++].fld); /* action */ + } + abstr_new(n, il->u[indx].fld); /* default */ + break; + + case IL_Lcase: + num_cases = il->u[0].n; + indx = 1; + for (i = 0; i < num_cases; ++i) { + ++indx; /* skip selection num */ + abstr_new(n, il->u[indx++].fld); /* action */ + } + abstr_new(n, il->u[indx].fld); /* default */ + break; + + case IL_Acase: + abstr_new(n, il->u[2].fld); /* C_integer action */ + if (largeints) + abstr_new(n, il->u[3].fld); /* integer action */ + abstr_new(n, il->u[4].fld); /* C_double action */ + break; + + case IL_Abstr: + case IL_Inter: + case IL_Lst: + case IL_TpAsgn: + case IL_Union: + abstr_new(n, il->u[0].fld); + abstr_new(n, il->u[1].fld); + break; + + case IL_Compnt: + case IL_Store: + case IL_VarTyp: + abstr_new(n, il->u[0].fld); + break; + + case IL_Block: + case IL_Call: + case IL_Const: /* should have been replaced by literal node */ + case IL_Err1: + case IL_Err2: + case IL_IcnTyp: + case IL_Subscr: + case IL_Var: + break; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + } + } + +/* + * alloc_stor - allocate a store with empty types. + */ +static struct store *alloc_stor(stor_sz, n_types) +int stor_sz; +int n_types; + { + struct store *stor; + int i; + + /* + * If type inferencing is disabled, we don't actually make use of + * any stores, but the initialization code asks for them anyway. + */ + if (!do_typinfer) + return NULL; + +#ifdef OptimizeType + stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + + ((stor_sz - 1) * sizeof(struct typinfo *)))); + stor->next = NULL; + stor->perm = 1; + for (i = 0; i < stor_sz; ++i) { + stor->types[i] = (struct typinfo *)alloc_typ(n_types); + } +#else /* OptimizeType */ + stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + + ((stor_sz - 1) * sizeof(unsigned int *)))); + stor->next = NULL; + stor->perm = 1; + for (i = 0; i < stor_sz; ++i) { + stor->types[i] = (unsigned int *)alloc_typ(n_types); + } +#endif /* OptimizeType */ + + return stor; + } + +/* + * findloops - find both explicit loops and implicit loops caused by + * goal-directed evaluation. Allocate stores for them. Determine which + * expressions cannot fail (used to eliminate dynamic store allocation + * for some bounded expressions). Allocate stores for 'if' and 'case' + * expressions that can be resumed. Initialize expression types. + * The syntax tree is walked in reverse execution order looking for + * failure and for generators. + */ +static int findloops(n, resume, rslt_type) +struct node *n; +int resume; +#ifdef OptimizeType +struct typinfo *rslt_type; +#else /* OptimizeType */ +unsigned int *rslt_type; +#endif /* OptimizeType */ + { + struct loop { + int resume; + int can_fail; + int every_cntrl; +#ifdef OptimizeType + struct typinfo *type; +#else /* OptimizeType */ + unsigned int *type; +#endif /* OptimizeType */ + struct loop *prev; + } loop_info; + struct loop *loop_sav; + static struct loop *cur_loop = NULL; + struct node *cases; + struct node *clause; + int can_fail; + int nargs, i; + + n->store = NULL; + if (!do_typinfer) + rslt_type = any_typ; + + switch (n->n_type) { + case N_Activat: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + /* + * Assume activation can fail. + */ + can_fail = findloops(Tree2(n), 1, NULL); + can_fail = findloops(Tree1(n), can_fail, NULL); + n->symtyps = symtyps(2); + if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) + n->symtyps->next = symtyps(2); + break; + + case N_Alt: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + +#ifdef TypTrc + rslt_type = NULL; /* don't share result loc with subexpressions*/ +#endif /* TypTrc */ + + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail = findloops(Tree0(n), resume, rslt_type) | + findloops(Tree1(n), resume, rslt_type); + break; + + case N_Apply: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + /* + * Assume operation can suspend or fail. + */ + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail = findloops(Tree1(n), 1, NULL); + can_fail = findloops(Tree0(n), can_fail, NULL); + n->symtyps = symtyps(max_sym); + break; + + case N_Augop: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + + can_fail = resume; + /* + * Impl0(n) is assignment. + */ + if (resume && Impl0(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl0(n)->ret_flag)) + can_fail = 1; + /* + * Impl1(n) is the augmented operation. + */ + if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ + can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ + n->type = Tree2(n)->type; + Typ4(n) = alloc_typ(n_intrtyp); + n->symtyps = symtyps(n_arg_sym(Impl1(n))); + n->symtyps->next = symtyps(n_arg_sym(Impl0(n))); + break; + + case N_Bar: + can_fail = findloops(Tree0(n), resume, rslt_type); + n->type = Tree0(n)->type; + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + break; + + case N_Break: + if (cur_loop == NULL) { + nfatal(n, "invalid context for break", NULL); + return 0; + } + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + loop_sav = cur_loop; + cur_loop = cur_loop->prev; + loop_sav->can_fail |= findloops(Tree0(n), loop_sav->resume, + loop_sav->type); + cur_loop = loop_sav; + can_fail = 0; + break; + + case N_Case: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + +#ifdef TypTrc + rslt_type = NULL; /* don't share result loc with subexpressions*/ +#endif /* TypTrc */ + + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + + /* + * control clause is bounded + */ + can_fail = findloops(Tree0(n), 0, NULL); + + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + /* + * The expression being compared can be resumed. + */ + findloops(Tree0(clause), 1, NULL); + + /* + * Body. + */ + can_fail |= findloops(Tree1(clause), resume, rslt_type); + } + + if (Tree2(n) == NULL) + can_fail = 1; + else + can_fail |= findloops(Tree2(n), resume, rslt_type); /* default */ + break; + + case N_Create: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + findloops(Tree0(n), 1, NULL); /* co-expression code */ + /* + * precompute type + */ + i= type_array[coexp_typ].frst_bit; + if (do_typinfer) + i += n->new_types[0]; + set_typ(n->type, i); + can_fail = resume; + break; + + case N_Cset: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, type_array[cset_typ].frst_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Empty: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, null_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Id: { + struct lentry *var; + + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + /* + * Precompute type + */ + var = LSym0(n); + if (var->flag & F_Global) + set_typ(n->type, frst_gbl + var->val.global->index); + else if (var->flag & F_Static) + set_typ(n->type, frst_gbl + var->val.index); + else + set_typ(n->type, frst_loc + var->val.index); + can_fail = resume; + } + break; + + case N_Field: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + can_fail = findloops(Tree0(n), resume, NULL); + n->symtyps = symtyps(1); + break; + + case N_If: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + +#ifdef TypTrc + rslt_type = NULL; /* don't share result loc with subexpressions*/ +#endif /* TypTrc */ + /* + * control clause is bounded + */ + findloops(Tree0(n), 0, NULL); + can_fail = findloops(Tree1(n), resume, rslt_type); + if (Tree2(n)->n_type == N_Empty) + can_fail = 1; + else { + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail |= findloops(Tree2(n), resume, rslt_type); + } + break; + + case N_Int: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, int_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Invok: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of arguments */ + /* + * Assume operation can suspend and fail. + */ + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail = 1; + for (i = nargs; i >= 0; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + n->symtyps = symtyps(max_sym); + break; + + case N_InvOp: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of arguments */ + if (resume && Impl1(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + else + can_fail = resume; + for (i = nargs; i >= 1; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + n->symtyps = symtyps(n_arg_sym(Impl1(n))); + break; + + case N_InvProc: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of arguments */ + if (resume && Proc1(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (Proc1(n)->ret_flag & DoesFail) + can_fail = 1; + else + can_fail = resume; + for (i = nargs; i >= 1; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + break; + + case N_InvRec: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of args */ + if (err_conv) + can_fail = 1; + else + can_fail = resume; + for (i = nargs; i >= 1; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + break; + + case N_Limit: + findloops(Tree0(n), resume, rslt_type); + can_fail = findloops(Tree1(n), 1, NULL); + n->type = Tree0(n)->type; + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + n->symtyps = symtyps(1); + break; + + case N_Loop: { + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + loop_info.prev = cur_loop; + loop_info.resume = resume; + loop_info.can_fail = 0; + loop_info.every_cntrl = 0; + loop_info.type = n->type; + cur_loop = &loop_info; + switch ((int)Val0(Tree0(n))) { + case EVERY: + case SUSPEND: + /* + * The control clause can be resumed. The body is bounded. + */ + loop_info.every_cntrl = 1; + can_fail = findloops(Tree1(n), 1, NULL); + loop_info.every_cntrl = 0; + findloops(Tree2(n), 0, NULL); + break; + + case REPEAT: + /* + * The loop needs a saved store. The body is bounded. + */ + findloops(Tree1(n), 0, NULL); + can_fail = 0; + break; + + case WHILE: + /* + * The loop needs a saved store. The control + * clause and the body are each bounded. + */ + can_fail = findloops(Tree1(n), 0, NULL); + findloops(Tree2(n), 0, NULL); + break; + + case UNTIL: + /* + * The loop needs a saved store. The control + * clause and the body are each bounded. + */ + findloops(Tree1(n), 0, NULL); + findloops(Tree2(n), 0, NULL); + can_fail = 1; + break; + } + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (do_typinfer && resume) + n->store->next = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail |= cur_loop->can_fail; + cur_loop = cur_loop->prev; + } + break; + + case N_Next: + if (cur_loop == NULL) { + nfatal(n, "invalid context for next", NULL); + return 1; + } + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + can_fail = cur_loop->every_cntrl; + break; + + case N_Not: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, null_bit); /* precompute type */ + /* + * The expression is bounded. + */ + findloops(Tree0(n), 0, NULL); + can_fail = 1; + break; + + case N_Real: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, real_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Ret: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + if (Val0(Tree0(n)) == RETURN) { + /* + * The expression is bounded. + */ + findloops(Tree1(n), 0, NULL); + } + can_fail = 0; + break; + + case N_Scan: { + struct implement *asgn_impl; + + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + n->symtyps = symtyps(1); + can_fail = resume; + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { + asgn_impl = optab[asgn_loc].binary; + if (resume && asgn_impl->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(asgn_impl->ret_flag)) + can_fail = 1; + n->symtyps->next = symtyps(n_arg_sym(asgn_impl)); + } + can_fail = findloops(Tree2(n), can_fail, NULL); /* body */ + can_fail = findloops(Tree1(n), can_fail, NULL); /* subject */ + } + break; + + case N_Sect: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + can_fail = resume; + /* + * Impl0(n) is sectioning. + */ + if (resume && Impl0(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl0(n)->ret_flag)) + can_fail = 1; + n->symtyps = symtyps(n_arg_sym(Impl0(n))); + if (Impl1(n) != NULL) { + /* + * Impl1(n) is plus or minus + */ + if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + n->symtyps->next = symtyps(n_arg_sym(Impl1(n))); + } + can_fail = findloops(Tree4(n), can_fail, NULL); /* operand 3 */ + can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ + can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ + break; + + case N_Slist: + /* + * 1st expression is bounded. + */ + findloops(Tree0(n), 0, NULL); + can_fail = findloops(Tree1(n), resume, rslt_type); + n->type = Tree1(n)->type; + break; + + case N_SmplAsgn: + can_fail = findloops(Tree3(n), resume, NULL); /* 2nd operand */ + findloops(Tree2(n), can_fail, rslt_type); /* variable */ + n->type = Tree2(n)->type; + break; + + case N_SmplAug: + can_fail = resume; + /* + * Impl1(n) is the augmented operation. + */ + if (resume && Impl1(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + can_fail = findloops(Tree3(n), can_fail, NULL); /* 2nd operand */ + findloops(Tree2(n), can_fail, rslt_type); /* variable */ + n->symtyps = symtyps(n_arg_sym(Impl1(n))); + n->type = Tree2(n)->type; + Typ4(n) = alloc_typ(n_intrtyp); + break; + + case N_Str: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, str_bit); /* precompute type */ + can_fail = resume; + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + if (can_fail) + n->flag = CanFail; + else + n->flag = 0; + return can_fail; + } + +/* + * symtyps - determine the number of entries needed for a symbol table + * that maps argument indexes to types for an operation in the + * data base. Allocate the symbol table. + */ +static struct symtyps *symtyps(nsyms) +int nsyms; + { + struct symtyps *tab; + + if (nsyms == 0) + return NULL; + +#ifdef OptimizeType + tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + + (nsyms - 1) * sizeof(struct typinfo *))); +#else /* OptimizeType */ + tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + + (nsyms - 1) * sizeof(int *))); +#endif /* OptimizeType */ + tab->nsyms = nsyms; + tab->next = NULL; + while (nsyms) + tab->types[--nsyms] = alloc_typ(n_intrtyp); + return tab; + } + +/* + * infer_proc - perform type inference on a call to an Icon procedure. + */ +static void infer_prc(proc, n) +struct pentry *proc; +nodeptr n; + { + struct store *s_store; + struct store *f_store; + struct store *store; + struct pentry *sv_proc; + struct t_coexpr *sv_coexp; + struct lentry *lptr; + nodeptr n1; + int i; + int nparams; + int coexp_bit; + + /* + * Determine what co-expressions the procedure might be called from. + */ + if (cur_coexp == NULL) + ChkMrgTyp(n_icntyp, cur_proc->coexprs, proc->coexprs) + else { + coexp_bit = type_array[coexp_typ].frst_bit + cur_coexp->typ_indx; + if (!bitset(proc->coexprs, coexp_bit)) { + ++changed; + set_typ(proc->coexprs, coexp_bit); + } + } + + proc->reachable = 1; /* this procedure can be called */ + + /* + * If this procedure can suspend, there may be backtracking paths + * to this invocation. If so, propagate types of globals from the + * backtracking paths to the suspends of the procedure and propagate + * types of locals to the success store of the call. + */ + if (proc->ret_flag & DoesSusp && n->store != NULL) { + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, n->store->types[i], proc->susp_store->types[i]) + for (i = 0; i < n_loc; ++i) + MrgTyp(n_icntyp, n->store->types[n_gbl + i], succ_store->types[n_gbl + + i]) + } + + /* + * Merge the types of global variables into the "in store" of the + * procedure. Because the body of the procedure may already have + * been processed for this pass, the "changed" flag must be set if + * there is a change of type in the store. This will insure that + * there will be another iteration in which to propagate the change + * into the body. + */ + store = proc->in_store; + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, succ_store->types[i], store->types[i]) + +#ifdef TypTrc + /* + * Trace the call. + */ + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, + trc_indent, proc->name); +#endif /* TypTrc */ + + /* + * Get the types of the arguments, starting with the non-varargs part. + */ + nparams = proc->nargs; /* number of parameters */ + if (nparams < 0) + nparams = -nparams - 1; + for (i = 0; i < num_args && i < nparams; ++i) { + typ_deref(arg_typs->types[i], store->types[n_gbl + i], 1); + +#ifdef TypTrc + if (trcfile != NULL) { + /* + * Trace the argument type to the call. + */ + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + + /* + * Get the type of the varargs part of the argument list. + */ + if (proc->nargs < 0) + while (i < num_args) { + typ_deref(arg_typs->types[i], + compnt_array[lst_elem].store->types[proc->arg_lst], 1); + +#ifdef TypTrc + if (trcfile != NULL) { + /* + * Trace the argument type to the call. + */ + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + ++i; + } + + /* + * Missing arguments have the null type. + */ + while (i < nparams) { + set_typ(store->types[n_gbl + i], null_bit); + ++i; + } + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, ")\n"); + { + char *trc_ind_sav = trc_indent; + trc_indent = ""; /* staring a new procedure, don't indent tracing */ +#endif /* TypTrc */ + + /* + * only perform type inference on the body of a procedure + * once per iteration + */ + if (proc->iteration < iteration) { + proc->iteration = iteration; + s_store = succ_store; + f_store = fail_store; + sv_proc = cur_proc; + succ_store = cpy_store(proc->in_store); + cur_proc = proc; + sv_coexp = cur_coexp; + cur_coexp = NULL; /* we are not in a create expression */ + /* + * Perform type inference on the initial clause. Static variables + * are initialized to null on this path. + */ + for (lptr = proc->statics; lptr != NULL; lptr = lptr->next) + set_typ(succ_store->types[lptr->val.index], null_bit); + n1 = Tree1(proc->tree); + if (n1->flag & CanFail) { + /* + * The initial clause can fail. Because it is bounded, we need + * a new failure store that we can merge into the success store + * at the end of the clause. + */ + store = get_store(1); + fail_store = store; + infer_nd(n1); + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(n1); + /* + * Perform type inference on the body of procedure. Execution may + * pass directly to it without executing initial clause. + */ + mrg_store(proc->in_store, succ_store); + n1 = Tree2(proc->tree); + if (n1->flag & CanFail) { + /* + * The body can fail. Because it is bounded, we need a new failure + * store that we can merge into the success store at the end of + * the procedure. + */ + store = get_store(1); + fail_store = store; + infer_nd(n1); + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(n1); + set_ret(NULL); /* implicit fail */ + free_store(succ_store); + succ_store = s_store; + fail_store = f_store; + cur_proc = sv_proc; + cur_coexp = sv_coexp; + } + +#ifdef TypTrc + trc_indent = trc_ind_sav; + } +#endif /* TypTrc */ + + /* + * Get updated types for global variables at the end of the call. + */ + store = proc->out_store; + for (i = 0; i < n_gbl; ++i) + CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); + + /* + * If the procedure can fail, merge variable types into the failure + * store. + */ + if (proc->ret_flag & DoesFail) + mrg_store(succ_store, fail_store); + + /* + * The return type of the procedure is the result type of the call. + */ + MrgTyp(n_intrtyp, proc->ret_typ, n->type); + } + +/* + * cpy_store - make a copy of a store. + */ +static struct store *cpy_store(source) +struct store *source; + { + struct store *dest; + int stor_sz; + int i; + + if (source == NULL) + dest = get_store(1); + else { + stor_sz = n_gbl + n_loc; + dest = get_store(0); + for (i = 0; i < stor_sz; ++i) + CpyTyp(n_icntyp, source->types[i], dest->types[i]) + } + return dest; + } + +/* + * mrg_store - merge the source store into the destination store. + */ +static void mrg_store(source, dest) +struct store *source; +struct store *dest; + { + int i; + + if (source == NULL) + return; + + /* + * Is this store included in the state that must be checked for a fixed + * point? + */ + if (dest->perm) { + for (i = 0; i < n_gbl + n_loc; ++i) + ChkMrgTyp(n_icntyp, source->types[i], dest->types[i]) + } + else { + for (i = 0; i < n_gbl + n_loc; ++i) + MrgTyp(n_icntyp, source->types[i], dest->types[i]) + } + } + +/* + * set_ret - Save return type and the store for global variables. + */ +static void set_ret(typ) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ + { + int i; + + /* + * Merge the return type into the type of the procedure, dereferencing + * locals in the process. + */ + if (typ != NULL) + deref_lcl(typ, cur_proc->ret_typ); + + /* + * Update the types that variables may have upon exit of the procedure. + */ + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, succ_store->types[i], cur_proc->out_store->types[i]); + } + +/* + * deref_lcl - dereference local variable sub-types. + */ +static void deref_lcl(src, dest) +#ifdef OptimizeType +struct typinfo *src; +struct typinfo *dest; +#else /* OptimizeType */ +unsigned int *src; +unsigned int *dest; +#endif /* OptimizeType */ + { + int i, j; + int ref_gbl; + int frst_stv; + int num_stv; + struct store *stv_stor; + struct type *wktyp; + + /* + * Make a copy of the type to be dereferenced. + */ + wktyp = get_wktyp(); + CpyTyp(n_intrtyp, src, wktyp->bits); + + /* + * Determine which variable types must be dereferenced. Merge the + * dereferenced type into the return type and delete the variable + * type. Start with simple local variables. + */ + for (i = 0; i < n_loc; ++i) + if (bitset(wktyp->bits, frst_loc + i)) { + MrgTyp(n_icntyp, succ_store->types[n_gbl + i], wktyp->bits) + clr_typ(wktyp->bits, frst_loc + i); + } + + /* + * Check for substring trapped variables. If a sub-string trapped + * variable references a local, add "string" to the return type. + * If a sub-string trapped variable references a global, leave the + * trapped variable in the return type. + * It is theoretically possible for a sub-string trapped variable type to + * reference both a local and a global. When the trapped variable type + * is returned to the calling procedure, the local is re-interpreted + * as a local of that procedure. This is a "valid" overestimate of + * of the semantics of the return. Because this is unlikely to occur + * in real programs, the overestimate is of no practical consequence. + */ + num_stv = type_array[stv_typ].num_bits; + frst_stv = type_array[stv_typ].frst_bit; + stv_stor = compnt_array[str_var].store; + for (i = 0; i < num_stv; ++i) { + if (bitset(wktyp->bits, frst_stv + i)) { + /* + * We have found substring trapped variable i, see whether it + * references locals or globals. Globals include structure + * element references. + */ + for (j = 0; j < n_loc; ++j) + if (bitset(stv_stor->types[i], frst_loc + j)) { + set_typ(wktyp->bits, str_bit); + break; + } + ref_gbl = 0; + for (j = n_icntyp; j < frst_loc; ++j) + if (bitset(stv_stor->types[i], j)) { + ref_gbl = 1; + break; + } + /* + * Keep the trapped variable only if it references globals. + */ + if (!ref_gbl) + clr_typ(wktyp->bits, frst_stv + i); + } + } + + /* + * Merge the types into the destination. + */ + MrgTyp(n_intrtyp, wktyp->bits, dest); + +#ifdef TypTrc + if (trcfile != NULL) { + prt_typ(trcfile, wktyp->bits); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + + free_wktyp(wktyp); + } + +/* + * get_store - get a store large enough to hold globals and locals. + */ +static struct store *get_store(clear) +int clear; + { + struct store *store; + int store_sz; + int i; + + /* + * Warning, stores for all procedures must be the same size. In some + * situations involving sub-string trapped variables (for example + * when using the "default" trapped variable) a referenced local variable + * type may be interpreted in a procedure to which it does not belong. + * This represents an impossible execution and type inference may + * "legally" produce any results for this part of the abstract + * interpretation. As long as the store is large enough to include any + * such "impossible" variables, type inference will do something legal. + * Note that n_loc is the maximum number of locals in any procedure, + * so store_sz is large enough. + */ + store_sz = n_gbl + n_loc; + if ((store = store_pool) == NULL) { + store = alloc_stor(store_sz, n_icntyp); + store->perm = 0; + } + else { + store_pool = store_pool->next; + /* + * See if the variables in the store should be initialized to the + * empty type. + */ + if (clear) + for (i = 0; i < store_sz; ++i) + ClrTyp(n_icntyp, store->types[i]); + } + return store; + } + +static void free_store(store) +struct store *store; + { + store->next = store_pool; + store_pool = store; + } + +/* + * infer_nd - perform type inference on a subtree of the syntax tree. + */ +static void infer_nd(n) +nodeptr n; + { + struct node *cases; + struct node *clause; + struct store *s_store; + struct store *f_store; + struct store *store; + struct loop { + struct store *succ_store; + struct store *fail_store; + struct store *next_store; + struct store *susp_store; + struct loop *prev; + } loop_info; + struct loop *loop_sav; + static struct loop *cur_loop; + struct argtyps *sav_argtyp; + int sav_nargs; + struct type *wktyp; + int i; + + switch (n->n_type) { + case N_Activat: + infer_act(n); + break; + + case N_Alt: + f_store = fail_store; + store = get_store(1); + fail_store = store; + infer_nd(Tree0(n)); /* 1st alternative */ + + /* + * "Correct" type inferencing of alternation has a performance + * problem. Propagating stores through nested alternation + * requires as many iterations as the depth of the nesting. + * This is solved by adding two edges to the flow graph. These + * represent impossible execution paths but this does not + * affect the soundness of type inferencing and, in "real" + * programs, does not affect the preciseness of its inference. + * One edge is directly from the 1st alternative to the 2nd. + * The other is a backtracking edge immediately back into + * the alternation from the 1st alternative. + */ + mrg_store(succ_store, store); /* imaginary edge to 2nd alternative */ + + if (n->store != NULL) { + mrg_store(succ_store, n->store); /* imaginary backtracking edge */ + mrg_store(n->store, fail_store); + } + s_store = succ_store; + succ_store = store; + fail_store = f_store; + infer_nd(Tree1(n)); /* 2nd alternative */ + mrg_store(s_store, succ_store); + free_store(s_store); + if (n->store != NULL) + mrg_store(n->store, fail_store); + fail_store = n->store; +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree0(n)->type, n->type); + MrgTyp(n_intrtyp, Tree1(n)->type, n->type); +#else /* TypTrc */ + /* + * Type is computed by sub-expressions directly into n->type. + */ +#endif /* TypTrc */ + break; + + case N_Apply: { + struct type *lst_types; + int frst_lst; + int num_lst; + struct store *lstel_stor; + + infer_nd(Tree0(n)); /* thing being invoked */ + infer_nd(Tree1(n)); /* list */ + + frst_lst = type_array[list_typ].frst_bit; + num_lst = type_array[list_typ].num_bits; + lstel_stor = compnt_array[lst_elem].store; + + /* + * All that is available is a "summary" of the types of the + * elements of the list. Each argument to the invocation + * could be any type in the summary. Set up a maximum length + * argument list. + */ + lst_types = get_wktyp(); + typ_deref(Tree1(n)->type, lst_types->bits, 0); + wktyp = get_wktyp(); + for (i = 0; i < num_lst; ++i) + if (bitset(lst_types->bits, frst_lst + i)) + MrgTyp(n_icntyp, lstel_stor->types[i], wktyp->bits); + bitset(wktyp->bits, null_bit); /* arg list extension might be done */ + + sav_nargs = num_args; + sav_argtyp = arg_typs; + num_args = max_prm; + arg_typs = get_argtyp(); + for (i = 0; i < max_prm; ++i) + arg_typs->types[i] = wktyp->bits; + gen_inv(Tree0(n)->type, n); /* inference on general invocation */ + + free_wktyp(wktyp); + free_wktyp(lst_types); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + } + break; + + case N_Augop: + infer_nd(Tree2(n)); /* 1st operand */ + infer_nd(Tree3(n)); /* 2nd operand */ + /* + * Perform type inference on the operation. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree2(n)->type; + arg_typs->types[1] = Tree3(n)->type; + infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); + chk_succ(Impl1(n)->ret_flag, n->store); + /* + * Perform type inference on the assignment. + */ + arg_typs->types[1] = Typ4(n); + infer_impl(Impl0(n), n, n->symtyps->next, n->type); + chk_succ(Impl0(n)->ret_flag, n->store); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_Bar: + /* + * This operation intercepts failure and has an associated + * resumption store. If backtracking reaches this operation + * execution may either continue backward or proceed forward + * again. + */ + mrg_store(n->store, fail_store); + mrg_store(n->store, succ_store); + fail_store = n->store; + infer_nd(Tree0(n)); + /* + * Type is computed by operand. + */ + break; + + case N_Break: + /* + * The success and failure stores for the operand of break are + * those associated with the enclosing loop. + */ + fail_store = cur_loop->fail_store; + loop_sav = cur_loop; + cur_loop = cur_loop->prev; + infer_nd(Tree0(n)); + cur_loop = loop_sav; + mrg_store(succ_store, cur_loop->succ_store); + if (cur_loop->susp_store != NULL) + mrg_store(cur_loop->susp_store, fail_store); + free_store(succ_store); + succ_store = get_store(1); /* empty store says: can't get past here */ + fail_store = dummy_stor; /* shouldn't be used */ + /* + * Result of break is empty type. Result type of expression + * is computed directly into result type of loop. + */ + break; + + case N_Case: + f_store = fail_store; + s_store = get_store(1); + infer_nd(Tree0(n)); /* control clause */ + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + /* + * Set up a failure store to capture the effects of failure + * of the selection clause. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree0(clause)); /* value of clause */ + + /* + * Create the effect of the possible failure of the comparison + * of the selection value to the control value. + */ + mrg_store(succ_store, fail_store); + + /* + * The success and failure stores and the result of the body + * of the clause are those of the whole case expression. + */ + fail_store = f_store; + infer_nd(Tree1(clause)); /* body of clause */ + mrg_store(succ_store, s_store); + free_store(succ_store); + succ_store = store; + if (n->store != NULL) + mrg_store(n->store, fail_store); /* 'case' can be resumed */ +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree1(clause)->type, n->type); +#else /* TypTrc */ + /* + * Type is computed by case clause directly into n->type. + */ +#endif /* TypTrc */ + } + + /* + * Check for default clause. + */ + if (Tree2(n) == NULL) + mrg_store(succ_store, f_store); + else { + fail_store = f_store; + infer_nd(Tree2(n)); /* default */ + mrg_store(succ_store, s_store); + if (n->store != NULL) + mrg_store(n->store, fail_store); /* 'case' can be resumed */ +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree2(n)->type, n->type); +#else /* TypTrc */ + /* + * Type is computed by default clause directly into n->type. + */ +#endif /* TypTrc */ + } + free_store(succ_store); + succ_store = s_store; + if (n->store != NULL) + fail_store = n->store; + break; + + case N_Create: + /* + * Record initial values of local variables for coexpression. + */ + store = coexp_map[n->new_types[0]]->in_store; + for (i = 0; i < n_loc; ++i) + ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], + store->types[n_gbl + i]) + /* + * Type is precomputed. + */ + break; + + case N_Cset: + case N_Empty: + case N_Id: + case N_Int: + case N_Real: + case N_Str: + /* + * Type is precomputed. + */ + break; + + case N_Field: { + struct fentry *fp; + struct par_rec *rp; + int frst_rec; + + if ((fp = flookup(Str0(Tree1(n)))) == NULL) { + break; /* error message printed elsewhere */ + } + + /* + * Determine the record types. + */ + infer_nd(Tree0(n)); + typ_deref(Tree0(n)->type, n->symtyps->types[0], 0); + + /* + * For each record containing this field, get the tupe of + * the field in that record. + */ + frst_rec = type_array[rec_typ].frst_bit; + for (rp = fp->rlist; rp != NULL; rp = rp->next) { + if (bitset(n->symtyps->types[0], frst_rec + rp->rec->rec_num)) + set_typ(n->type, frst_fld + rp->rec->frst_fld + rp->offset); + } + } + break; + + case N_If: + f_store = fail_store; + if (Tree2(n)->n_type != N_Empty) { + /* + * If there is an else clause, we must set up a failure store + * to capture the effects of failure of the control clause. + */ + store = get_store(1); + fail_store = store; + } + + infer_nd(Tree0(n)); /* control clause */ + + /* + * If the control clause succeeds, execution passes into the + * then clause with the failure store for the entire if expression. + */ + fail_store = f_store; + infer_nd(Tree1(n)); /* then clause */ + + if (Tree2(n)->n_type != N_Empty) { + if (n->store != NULL) + mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ + s_store = succ_store; + + /* + * The entering success store of the else clause is the failure + * store of the control clause. The failure store is that of + * the entire if expression. + */ + succ_store = store; + fail_store = f_store; + infer_nd(Tree2(n)); /* else clause */ + + if (n->store != NULL) { + mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ + fail_store = n->store; + } + + /* + * Join the exiting success stores of the then and else clauses. + */ + mrg_store(s_store, succ_store); + free_store(s_store); + } + +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree1(n)->type, n->type); + if (Tree2(n)->n_type != N_Empty) + MrgTyp(n_intrtyp, Tree2(n)->type, n->type); +#else /* TypTrc */ + /* + * Type computed by 'then' and 'else' clauses directly into n->type. + */ +#endif /* TypTrc */ + break; + + case N_Invok: + /* + * General invocation. + */ + infer_nd(Tree1(n)); /* thing being invoked */ + + /* + * Perform type inference on all the arguments and copy the + * results into the argument type array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + /* + * If this is mutual evaluation, get the type of the last argument, + * otherwise do inference on general invocation. + */ + if (Tree1(n)->n_type == N_Empty) { + MrgTyp(n_intrtyp, arg_typs->types[num_args - 1], n->type); + } + else + gen_inv(Tree1(n)->type, n); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_InvOp: + /* + * Invocation of a run-time operation. Perform inference on all + * the arguments, copying the results into the argument type + * array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + /* + * Perform inference on operation invocation. + */ + infer_impl(Impl1(n), n, n->symtyps, n->type); + chk_succ(Impl1(n)->ret_flag, n->store); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_InvProc: + /* + * Invocation of a procedure. Perform inference on all + * the arguments, copying the results into the argument type + * array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + /* + * Perform inference on the procedure invocation. + */ + infer_prc(Proc1(n), n); + chk_succ(Proc1(n)->ret_flag, n->store); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_InvRec: + /* + * Invocation of a record constructor. Perform inference on all + * the arguments, copying the results into the argument type + * array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + infer_con(Rec1(n), n); /* inference on constructor invocation */ + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_Limit: + infer_nd(Tree1(n)); /* limit */ + typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); + mrg_store(succ_store, fail_store); /* limit might be 0 */ + mrg_store(n->store, fail_store); /* resumption may bypass expr */ + infer_nd(Tree0(n)); /* expression */ + if (fail_store != NULL) + mrg_store(n->store, fail_store); /* expression may be resumed */ + fail_store = n->store; + /* + * Type is computed by expression being limited. + */ + break; + + case N_Loop: { + /* + * Establish stores used by break and next. + */ + loop_info.prev = cur_loop; + loop_info.succ_store = get_store(1); + loop_info.fail_store = fail_store; + loop_info.next_store = NULL; + loop_info.susp_store = n->store->next; + cur_loop = &loop_info; + + switch ((int)Val0(Tree0(n))) { + case EVERY: + infer_nd(Tree1(n)); /* control clause */ + f_store = fail_store; + + /* + * Next in the do clause resumes the control clause as + * does success of the do clause. + */ + loop_info.next_store = fail_store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, f_store); + break; + + case REPEAT: + /* + * The body of the loop can be entered by entering the + * loop, by executing a next in the body, or by having + * the loop succeed or fail. n->store captures all but + * the first case, which is covered by the initial success + * store. + */ + fail_store = n->store; + mrg_store(n->store, succ_store); + loop_info.next_store = n->store; + infer_nd(Tree1(n)); + mrg_store(succ_store, n->store); + break; + + case SUSPEND: + infer_nd(Tree1(n)); /* value */ +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) suspend ", n->n_file, n->n_line, + n->n_col); +#endif /* TypTrc */ + + set_ret(Tree1(n)->type); /* set return type of procedure */ + + /* + * Get changes to types of global variables from + * resumption. + */ + store = cur_proc->susp_store; + for (i = 0; i < n_gbl; ++i) + CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); + + /* + * Next in the do clause resumes the control clause as + * does success of the do clause. + */ + f_store = fail_store; + loop_info.next_store = fail_store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, f_store); + break; + + case WHILE: + /* + * The control clause can be entered by entering the loop, + * executing a next expression, or by having the do clause + * succeed or fail. n->store captures all but the first case, + * which is covered by the initial success store. + */ + mrg_store(n->store, succ_store); + loop_info.next_store = n->store; + infer_nd(Tree1(n)); /* control clause */ + fail_store = n->store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, n->store); + break; + + case UNTIL: + /* + * The control clause can be entered by entering the loop, + * executing a next expression, or by having the do clause + * succeed or fail. n->store captures all but the first case, + * which is covered by the initial success store. + */ + mrg_store(n->store, succ_store); + loop_info.next_store = n->store; + f_store = fail_store; + /* + * Set up a failure store to capture the effects of failure + * of the control clause. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree1(n)); /* control clause */ + mrg_store(succ_store, f_store); + free_store(succ_store); + succ_store = store; + fail_store = n->store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, n->store); + break; + } + free_store(succ_store); + succ_store = loop_info.succ_store; + if (n->store->next != NULL) + fail_store = n->store->next; + cur_loop = cur_loop->prev; + /* + * Type is computed by break expressions. + */ + } + break; + + case N_Next: + if (cur_loop->next_store == NULL) + mrg_store(succ_store, fail_store); /* control clause of every */ + else + mrg_store(succ_store, cur_loop->next_store); + free_store(succ_store); + succ_store = get_store(1); /* empty store says: can't get past here */ + fail_store = dummy_stor; /* shouldn't be used */ + /* + * Result is empty type. + */ + break; + + case N_Not: + /* + * Set up a failure store to capture the effects of failure + * of the negated expression, it becomes the success store + * of the entire expression. + */ + f_store = fail_store; + store = get_store(1); + fail_store = store; + infer_nd(Tree0(n)); + mrg_store(succ_store, f_store); /* if success, then fail */ + free_store(succ_store); + succ_store = store; + fail_store = f_store; + /* + * Type is precomputed. + */ + break; + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) { + if (Tree1(n)->flag & CanFail) { + /* + * Set up a failure store to capture the effects of failure + * of the returned expression and the corresponding procedure + * failure. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree1(n)); /* return value */ + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(Tree1(n)); /* return value */ + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) return ", n->n_file, n->n_line, + n->n_col); +#endif /* TypTrc */ + + set_ret(Tree1(n)->type); + } + else { /* fail */ + set_ret(NULL); + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) fail\n", n->n_file, n->n_line, + n->n_col); +#endif /* TypTrc */ + + } + free_store(succ_store); + succ_store = get_store(1); /* empty store says: can't get past here */ + fail_store = dummy_stor; /* shouldn't be used */ + /* + * Empty type. + */ + break; + + case N_Scan: { + struct implement *asgn_impl; + + infer_nd(Tree1(n)); /* subject */ + typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); + infer_nd(Tree2(n)); /* body */ + + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { + /* + * Perform type inference on the assignment. + */ + asgn_impl = optab[asgn_loc].binary; + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree1(n)->type; + arg_typs->types[1] = Tree2(n)->type; + infer_impl(asgn_impl, n, n->symtyps->next, n->type); + chk_succ(asgn_impl->ret_flag, n->store); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + } + else + MrgTyp(n_intrtyp, Tree2(n)->type, n->type); + } + break; + + case N_Sect: + infer_nd(Tree2(n)); /* 1st operand */ + infer_nd(Tree3(n)); /* 2nd operand */ + infer_nd(Tree4(n)); /* 3rd operand */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + if (Impl1(n) != NULL) { + /* + * plus or minus. + */ + num_args = 2; + arg_typs->types[0] = Tree3(n)->type; + arg_typs->types[1] = Tree4(n)->type; + wktyp = get_wktyp(); + infer_impl(Impl1(n), n, n->symtyps->next, wktyp->bits); + chk_succ(Impl1(n)->ret_flag, n->store); + arg_typs->types[2] = wktyp->bits; + } + else + arg_typs->types[2] = Tree4(n)->type; + num_args = 3; + arg_typs->types[0] = Tree2(n)->type; + arg_typs->types[1] = Tree3(n)->type; + /* + * sectioning + */ + infer_impl(Impl0(n), n, n->symtyps, n->type); + chk_succ(Impl0(n)->ret_flag, n->store); + if (Impl1(n) != NULL) + free_wktyp(wktyp); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_Slist: + f_store = fail_store; + if (Tree0(n)->flag & CanFail) { + /* + * Set up a failure store to capture the effects of failure + * of the first operand; this is merged into the + * incoming success store of the second operand. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree0(n)); + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(Tree0(n)); + fail_store = f_store; + infer_nd(Tree1(n)); + /* + * Type is computed by second operand. + */ + break; + + case N_SmplAsgn: { + /* + * Optimized assignment to a named variable. + */ + struct lentry *var; + int indx; + + infer_nd(Tree3(n)); + var = LSym0(Tree2(n)); + if (var->flag & F_Global) + indx = var->val.global->index; + else if (var->flag & F_Static) + indx = var->val.index; + else + indx = n_gbl + var->val.index; + ClrTyp(n_icntyp, succ_store->types[indx]); + typ_deref(Tree3(n)->type, succ_store->types[indx], 0); + +#ifdef TypTrc + /* + * Trace assignment. + */ + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, + n->n_col, trc_indent, var->name); + prt_d_typ(trcfile, Tree3(n)->type); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + /* + * Type is precomputed. + */ + } + break; + + case N_SmplAug: { + /* + * Optimized augmented assignment to a named variable. + */ + struct lentry *var; + int indx; + + /* + * Perform type inference on the operation. + */ + infer_nd(Tree3(n)); /* 2nd operand */ + + /* + * Set up type array for arguments of operation. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree2(n)->type; /* type was precomputed */ + arg_typs->types[1] = Tree3(n)->type; + + /* + * Perform inference on the operation. + */ + infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); + chk_succ(Impl1(n)->ret_flag, n->store); + + /* + * Perform assignment to the variable. + */ + var = LSym0(Tree2(n)); + if (var->flag & F_Global) + indx = var->val.global->index; + else if (var->flag & F_Static) + indx = var->val.index; + else + indx = n_gbl + var->val.index; + ClrTyp(n_icntyp, succ_store->types[indx]); + typ_deref(Typ4(n), succ_store->types[indx], 0); + +#ifdef TypTrc + /* + * Trace assignment. + */ + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, + n->n_col, trc_indent, var->name); + prt_d_typ(trcfile, Typ4(n)); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + + /* + * Type is precomputed. + */ + } + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + } + +/* + * infer_con - perform type inference for the invocation of a record + * constructor. + */ +static void infer_con(rec, n) +struct rentry *rec; +nodeptr n; + { + int fld_indx; + int nfields; + int i; + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, + trc_indent, rec->name); +#endif /* TypTrc */ + + /* + * Dereference argument types into appropriate entries of field store. + */ + fld_indx = rec->frst_fld; + nfields = rec->nfields; + for (i = 0; i < num_args && i < nfields; ++i) { + typ_deref(arg_typs->types[i], fld_stor->types[fld_indx++], 1); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + + /* + * If there are too few arguments, add null type to appropriate entries + * of field store. + */ + while (i < nfields) { + if (!bitset(fld_stor->types[fld_indx], null_bit)) { + ++changed; + set_typ(fld_stor->types[fld_indx], null_bit); + } + ++fld_indx; + ++i; + } + + /* + * return record type + */ + set_typ(n->type, type_array[rec_typ].frst_bit + rec->rec_num); + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, ") =>> "); + prt_typ(trcfile, n->type); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + } + +/* + * infer_act - perform type inference on coexpression activation. + */ +static void infer_act(n) +nodeptr n; + { + struct implement *asgn_impl; + struct store *s_store; + struct store *f_store; + struct store *e_store; + struct store *store; + struct t_coexpr *sv_coexp; + struct t_coexpr *coexp; + struct type *rslt_typ; + struct argtyps *sav_argtyp; + int frst_coexp; + int num_coexp; + int sav_nargs; + int i; + int j; + +#ifdef TypTrc + FILE *trc_save; +#endif /* TypTrc */ + + num_coexp = type_array[coexp_typ].num_bits; + frst_coexp = type_array[coexp_typ].frst_bit; + + infer_nd(Tree1(n)); /* value to transmit */ + infer_nd(Tree2(n)); /* coexpression */ + + /* + * Dereference the two arguments. Note that only locals in the + * transmitted value are dereferenced. + */ + +#ifdef TypTrc + trc_save = trcfile; + trcfile = NULL; /* don't trace value during dereferencing */ +#endif /* TypTrc */ + + deref_lcl(Tree1(n)->type, n->symtyps->types[0]); + +#ifdef TypTrc + trcfile = trc_save; +#endif /* TypTrc */ + + typ_deref(Tree2(n)->type, n->symtyps->types[1], 0); + + rslt_typ = get_wktyp(); + + /* + * Set up a store for the end of the activation and propagate local + * variables across the activation; the activation may succeed or + * fail. + */ + e_store = get_store(1); + for (i = 0; i < n_loc; ++i) + CpyTyp(n_icntyp, succ_store->types[n_gbl + i], e_store->types[n_gbl + i]) + if (fail_store->perm) { + for (i = 0; i < n_loc; ++i) + ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], + fail_store->types[n_gbl + i]) + } + else { + for (i = 0; i < n_loc; ++i) + MrgTyp(n_icntyp, succ_store->types[n_gbl + i], + fail_store->types[n_gbl + i]) + } + + + /* + * Go through all the co-expressions that might be activated, + * perform type inference on them, and transmit stores along + * the execution paths induced by the activation. + */ + s_store = succ_store; + f_store = fail_store; + for (j = 0; j < num_coexp; ++j) { + if (bitset(n->symtyps->types[1], frst_coexp + j)) { + coexp = coexp_map[j]; + /* + * Merge the types of global variables into the "in store" of the + * co-expression. Because the body of the co-expression may already + * have been processed for this pass, the "changed" flag must be + * set if there is a change of type in the store. This will insure + * that there will be another iteration in which to propagate the + * change into the body. + */ + store = coexp->in_store; + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, s_store->types[i], store->types[i]) + + ChkMrgTyp(n_intrtyp, n->symtyps->types[0], coexp->act_typ) + + /* + * Only perform type inference on the body of a co-expression + * once per iteration. The main co-expression has no body. + */ + if (coexp->iteration < iteration & coexp->n != NULL) { + coexp->iteration = iteration; + succ_store = cpy_store(coexp->in_store); + fail_store = coexp->out_store; + sv_coexp = cur_coexp; + cur_coexp = coexp; + infer_nd(coexp->n); + + /* + * Dereference the locals in the value resulting from + * the execution of the co-expression body. + */ + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %sC%d =>> ", coexp->n->n_file, + coexp->n->n_line, coexp->n->n_col, trc_indent, j); +#endif /* TypTrc */ + + deref_lcl(coexp->n->type, coexp->rslt_typ); + + mrg_store(succ_store, coexp->out_store); + free_store(succ_store); + cur_coexp = sv_coexp; + } + + /* + * Get updated types for global variables, assuming the co-expression + * fails or returns by completing. + */ + store = coexp->out_store; + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, store->types[i], e_store->types[i]); + if (f_store->perm) { + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, store->types[i], f_store->types[i]); + } + else { + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, store->types[i], f_store->types[i]); + } + MrgTyp(n_intrtyp, coexp->rslt_typ, rslt_typ->bits) + } + } + + /* + * Control may return from the activation if another co-expression + * activates the current one. If we are in a create expression, + * cur_coexp is the current co-expression, otherwise the current + * procedure may be called within several co-expressions. + */ + if (cur_coexp == NULL) { + for (j = 0; j < num_coexp; ++j) + if (bitset(cur_proc->coexprs, frst_coexp + j)) + mrg_act(coexp_map[j], e_store, rslt_typ); + } + else + mrg_act(cur_coexp, e_store, rslt_typ); + + free_store(s_store); + succ_store = e_store; + fail_store = f_store; + + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, + trc_indent); + prt_typ(trcfile, n->symtyps->types[0]); + fprintf(trcfile, " @ "); + prt_typ(trcfile, n->symtyps->types[1]); + fprintf(trcfile, " =>> "); + prt_typ(trcfile, rslt_typ->bits); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + + if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) { + /* + * Perform type inference on the assignment. + */ + asgn_impl = optab[asgn_loc].binary; + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree1(n)->type; + arg_typs->types[1] = rslt_typ->bits; + infer_impl(asgn_impl, n, n->symtyps->next, n->type); + chk_succ(asgn_impl->ret_flag, n->store); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + } + else + ChkMrgTyp(n_intrtyp, rslt_typ->bits, n->type) + + free_wktyp(rslt_typ); + } + +/* + * mrg_act - merge entry information for the co-expression to the + * the ending store and result type for the activation being + * analyzed. + */ +static void mrg_act(coexp, e_store, rslt_typ) +struct t_coexpr *coexp; +struct store *e_store; +struct type *rslt_typ; + { + struct store *store; + int i; + + store = coexp->in_store; + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, store->types[i], e_store->types[i]); + + MrgTyp(n_intrtyp, coexp->act_typ, rslt_typ->bits) + } + +/* + * typ_deref - perform dereferencing in the abstract type realm. + */ +static void typ_deref(src, dest, chk) +#ifdef OptimizeType +struct typinfo *src; +struct typinfo *dest; +#else /* OptimizeType */ +unsigned int *src; +unsigned int *dest; +#endif /* OptimizeType */ +int chk; + { + struct store *tblel_stor; + struct store *tbldf_stor; + struct store *ttv_stor; + struct store *store; + unsigned int old; + int num_tbl; + int frst_tbl; + int num_bits; + int frst_bit; + int i; + int j; + int ret; +/* + if (src->bits == NULL) { + src->bits = alloc_mem_typ(src->size); + xfer_packed_types(src); + } + if (dest->bits == NULL) { + dest->bits = alloc_mem_typ(dest->size); + xfer_packed_types(dest); + } +*/ + /* + * copy values to destination + */ +#ifdef OptimizeType + if ((src->bits != NULL) && (dest->bits != NULL)) { + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { + old = dest->bits[i]; + dest->bits[i] |= src->bits[i]; + if (chk && (old != dest->bits[i])) + ++changed; + } + old = dest->bits[i]; + dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ + if (chk && (old != dest->bits[i])) + ++changed; + } + else if ((src->bits != NULL) && (dest->bits == NULL)) { + dest->bits = alloc_mem_typ(DecodeSize(dest->packed)); + xfer_packed_types(dest); + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { + old = dest->bits[i]; + dest->bits[i] |= src->bits[i]; + if (chk && (old != dest->bits[i])) + ++changed; + } + old = dest->bits[i]; + dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ + if (chk && (old != dest->bits[i])) + ++changed; + } + else if ((src->bits == NULL) && (dest->bits != NULL)) { + ret = xfer_packed_to_bits(src, dest, n_icntyp); + if (chk) + changed += ret; + } + else { + ret = mrg_packed_to_packed(src, dest, n_icntyp); + if (chk) + changed += ret; + } +#else /* OptimizeType */ + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { + old = dest[i]; + dest[i] |= src[i]; + if (chk && (old != dest[i])) + ++changed; + } + old = dest[i]; + dest[i] |= src[i] & val_mask; /* mask out variables */ + if (chk && (old != dest[i])) + ++changed; +#endif /* OptimizeType */ + + /* + * predefined variables whose types do not change. + */ + for (i = 0; i < num_typs; ++i) { + if (icontypes[i].deref == DrfCnst) { + if (bitset(src, type_array[i].frst_bit)) + if (chk) + ChkMrgTyp(n_icntyp, type_array[i].typ, dest) + else + MrgTyp(n_icntyp, type_array[i].typ, dest) + } + } + + + /* + * substring trapped variables + */ + num_bits = type_array[stv_typ].num_bits; + frst_bit = type_array[stv_typ].frst_bit; + for (i = 0; i < num_bits; ++i) + if (bitset(src, frst_bit + i)) + if (!bitset(dest, str_bit)) { + if (chk) + ++changed; + set_typ(dest, str_bit); + } + + /* + * table element trapped variables + */ + num_bits = type_array[ttv_typ].num_bits; + frst_bit = type_array[ttv_typ].frst_bit; + num_tbl = type_array[tbl_typ].num_bits; + frst_tbl = type_array[tbl_typ].frst_bit; + tblel_stor = compnt_array[tbl_val].store; + tbldf_stor = compnt_array[tbl_dflt].store; + ttv_stor = compnt_array[trpd_tbl].store; + for (i = 0; i < num_bits; ++i) + if (bitset(src, frst_bit + i)) + for (j = 0; j < num_tbl; ++j) + if (bitset(ttv_stor->types[i], frst_tbl + j)) { + if (chk) { + ChkMrgTyp(n_icntyp, tblel_stor->types[j], dest) + ChkMrgTyp(n_icntyp, tbldf_stor->types[j], dest) + } + else { + MrgTyp(n_icntyp, tblel_stor->types[j], dest) + MrgTyp(n_icntyp, tbldf_stor->types[j], dest) + } + } + + /* + * Aggregate compontents that are variables. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (typecompnt[i].var) { + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + store = compnt_array[i].store; + for (j = 0; j < num_bits; ++j) { + if (bitset(src, frst_bit + j)) + if (chk) + ChkMrgTyp(n_icntyp, store->types[j], dest) + else + MrgTyp(n_icntyp, store->types[j], dest) + } + } + } + + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(src, frst_fld + i)) { + if (chk) + ChkMrgTyp(n_icntyp, fld_stor->types[i], dest) + else + MrgTyp(n_icntyp, fld_stor->types[i], dest) + } + + /* + * global variables + */ + for (i = 0; i < n_gbl; ++i) + if (bitset(src, frst_gbl + i)) { + if (chk) + ChkMrgTyp(n_icntyp, succ_store->types[i], dest) + else + MrgTyp(n_icntyp, succ_store->types[i], dest) + } + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) + if (bitset(src, frst_loc + i)) { + if (chk) + ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) + else + MrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) + } +} + +/* + * infer_impl - perform type inference on a call to built-in operation + * using the implementation entry from the data base. + */ +static void infer_impl(impl, n, symtyps, rslt_typ) +struct implement *impl; +nodeptr n; +struct symtyps *symtyps; +#ifdef OptimizeType +struct typinfo *rslt_typ; +#else /* OptimizeType */ +unsigned int *rslt_typ; +#endif /* OptimizeType */ + { +#ifdef OptimizeType + struct typinfo *typ; +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + int flag; + int nparms; + int i; + int j; + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, + trc_indent); + if (impl->oper_typ == 'K') + fprintf(trcfile, "&%s", impl->name); + else + fprintf(trcfile, "%s(", impl->name); + } +#endif /* TypTrc */ + /* + * Set up the "symbol table" of dereferenced and undereferenced + * argument types as needed by the operation. + */ + nparms = impl->nargs; + j = 0; + for (i = 0; i < num_args && i < nparms; ++i) { + if (impl->arg_flgs[i] & RtParm) { + CpyTyp(n_intrtyp, arg_typs->types[i], symtyps->types[j]); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + ++j; + } + if (impl->arg_flgs[i] & DrfPrm) { + typ_deref(arg_typs->types[i], symtyps->types[j], 0); + +#ifdef TypTrc + if (trcfile != NULL) { + if (impl->arg_flgs[i] & RtParm) + fprintf(trcfile, "->"); + else if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + ++j; + } + } + if (nparms > 0) { + /* + * Check for varargs. Merge remaining arguments into the + * type of the variable part of the parameter list. + */ + flag = impl->arg_flgs[nparms - 1]; + if (flag & VarPrm) { + n_vararg = num_args - nparms + 1; + if (n_vararg < 0) + n_vararg = 0; + typ = symtyps->types[j - 1]; + while (i < num_args) { + if (flag & RtParm) { + MrgTyp(n_intrtyp, arg_typs->types[i], typ) + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + else { + typ_deref(arg_typs->types[i], typ, 0); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + ++i; + } + nparms -= 1; /* Don't extend with nulls into variable part */ + } + } + while (i < nparms) { + if (impl->arg_flgs[i] & RtParm) + set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ + if (impl->arg_flgs[i] & DrfPrm) + set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ + ++i; + } + + /* + * If this operation can suspend, there may be backtracking paths + * to this invocation. Merge type information from those paths + * into the current store. + */ + if (impl->ret_flag & DoesSusp) + mrg_store(n->store, succ_store); + + cur_symtyps = symtyps; + cur_rslt.bits = rslt_typ; + cur_rslt.size = n_intrtyp; + cur_new = n->new_types; + infer_il(impl->in_line); /* perform inference on operation */ + + if (MightFail(impl->ret_flag)) + mrg_store(succ_store, fail_store); + +#ifdef TypTrc + if (trcfile != NULL) { + if (impl->oper_typ != 'K') + fprintf(trcfile, ")"); + fprintf(trcfile, " =>> "); + prt_typ(trcfile, rslt_typ); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + } + +/* + * chk_succ - check to see if the operation can succeed. In particular, + * see if it can suspend. Change the succ_store and failure store + * appropriately. + */ +static void chk_succ(ret_flag, susp_stor) +int ret_flag; +struct store *susp_stor; + { + if (ret_flag & DoesSusp) { + if (susp_stor != NULL && (ret_flag & DoesRet)) + mrg_store(susp_stor, fail_store); /* "pass along" failure */ + fail_store = susp_stor; + } + else if (!(ret_flag & DoesRet)) { + free_store(succ_store); + succ_store = get_store(1); + fail_store = dummy_stor; /* shouldn't be used */ + } + } + +/* + * infer_il - perform type inference on a piece of code within built-in + * operation and determine whether execution can get past it. + */ +static int infer_il(il) +struct il_code *il; + { + struct il_code *il1; + int condition; + int case_fnd; + int ncases; + int may_fallthru; + int indx; + int i; + + if (il == NULL) + return 1; + + switch (il->il_type) { + case IL_Const: /* should have been replaced by literal node */ + return 0; + + case IL_If1: + condition = eval_cond(il->u[0].fld); + may_fallthru = (condition & MaybeFalse); + if (condition & MaybeTrue) + may_fallthru |= infer_il(il->u[1].fld); + return may_fallthru; + + case IL_If2: + condition = eval_cond(il->u[0].fld); + may_fallthru = 0; + if (condition & MaybeTrue) + may_fallthru |= infer_il(il->u[1].fld); + if (condition & MaybeFalse) + may_fallthru |= infer_il(il->u[2].fld); + return may_fallthru; + + case IL_Tcase1: + type_case(il, infer_il, NULL); + return 1; /* no point in trying very hard here */ + + case IL_Tcase2: + indx = type_case(il, infer_il, NULL); + if (indx != -1) + infer_il(il->u[indx].fld); /* default */ + return 1; /* no point in trying very hard here */ + + case IL_Lcase: + ncases = il->u[0].n; + indx = 1; + case_fnd = 0; + for (i = 0; i < ncases && !case_fnd; ++i) { + if (il->u[indx++].n == n_vararg) { /* selection number */ + infer_il(il->u[indx].fld); /* action */ + case_fnd = 1; + } + ++indx; + } + if (!case_fnd) + infer_il(il->u[indx].fld); /* default */ + return 1; /* no point in trying very hard here */ + + case IL_Acase: { + int maybe_int; + int maybe_dbl; + + eval_arith((int)il->u[0].fld->u[0].n, (int)il->u[1].fld->u[0].n, + &maybe_int, &maybe_dbl); + if (maybe_int) { + infer_il(il->u[2].fld); /* C_integer action */ + if (largeints) + infer_il(il->u[3].fld); /* integer action */ + } + if (maybe_dbl) + infer_il(il->u[4].fld); /* C_double action */ + return 1; /* no point in trying very hard here */ + } + + case IL_Err1: + case IL_Err2: + return 0; + + case IL_Block: + return il->u[0].n; + + case IL_Call: + return ((il->u[3].n & DoesFThru) != 0); + + case IL_Lst: + if (infer_il(il->u[0].fld)) + return infer_il(il->u[1].fld); + else + return 0; + + case IL_Abstr: + /* + * Handle side effects. + */ + il1 = il->u[0].fld; + if (il1 != NULL) { + while (il1->il_type == IL_Lst) { + side_effect(il1->u[1].fld); + il1 = il1->u[0].fld; + } + side_effect(il1); + } + + /* + * Set return type. + */ + abstr_typ(il->u[1].fld, &cur_rslt); + return 1; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + +/* + * side_effect - perform a side effect from an abstract clause of a + * built-in operation. + */ +static void side_effect(il) +struct il_code *il; + { + struct type *var_typ; + struct type *val_typ; + struct store *store; + int num_bits; + int frst_bit; + int i, j; + + /* + * il is IL_TpAsgn, get the variable type and value type, and perform + * the side effect. + */ + var_typ = get_wktyp(); + val_typ = get_wktyp(); + abstr_typ(il->u[0].fld, var_typ); /* variable type */ + abstr_typ(il->u[1].fld, val_typ); /* value type */ + + /* + * Determine which types that can be assigned to are in the variable + * type. + * + * Aggregate compontents. + */ + for (i = 0; i < num_cmpnts; ++i) { + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + store = compnt_array[i].store; + for (j = 0; j < num_bits; ++j) { + if (bitset(var_typ->bits, frst_bit + j)) + ChkMrgTyp(n_icntyp, val_typ->bits, store->types[j]) + } + } + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(var_typ->bits, frst_fld + i)) + ChkMrgTyp(n_icntyp, val_typ->bits, fld_stor->types[i]); + + /* + * global variables + */ + for (i = 0; i < n_gbl; ++i) + if (bitset(var_typ->bits, frst_gbl + i)) + MrgTyp(n_icntyp, val_typ->bits, succ_store->types[i]); + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) + if (bitset(var_typ->bits, frst_loc + i)) + MrgTyp(n_icntyp, val_typ->bits, succ_store->types[n_gbl + i]); + + + free_wktyp(var_typ); + free_wktyp(val_typ); + } + +/* + * abstr_typ - compute the type bits corresponding to an abstract type + * from an abstract clause of a built-in operation. + */ +static void abstr_typ(il, typ) +struct il_code *il; +struct type *typ; + { + struct type *typ1; + struct type *typ2; + struct rentry *rec; + struct store *store; + struct compnt_info *compnts; + int num_bits; + int frst_bit; + int frst_cmpnt; + int num_comps; + int typcd; + int new_indx; + int i; + int j; + int indx; + int size; + int t_indx; +#ifdef OptimizeType + struct typinfo *prmtyp; +#else /* OptimizeType */ + unsigned int *prmtyp; +#endif /* OptimizeType */ + + if (il == NULL) + return; + + switch (il->il_type) { + case IL_VarTyp: + /* + * type(<parameter>) + */ + indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ + if (indx >= cur_symtyps->nsyms) { + prmtyp = any_typ; + size = n_rttyp; + } + else { + prmtyp = cur_symtyps->types[indx]; + size = n_intrtyp; + } + if (typ->size < size) + size = typ->size; + MrgTyp(size, prmtyp, typ->bits); + break; + + case IL_Store: + /* + * store[<type>] + */ + typ1 = get_wktyp(); + abstr_typ(il->u[0].fld, typ1); /* type to be "dereferenced" */ + + /* + * Dereference types that are Icon varaibles. + */ + typ_deref(typ1->bits, typ->bits, 0); + + /* + * "Dereference" aggregate compontents that are not Icon variables. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (!typecompnt[i].var) { + if (i == stv_typ) { + /* + * Substring trapped variable stores contain variable + * references, so the types are larger, but we cannot + * copy more than the destination holds. + */ + size = n_intrtyp; + if (typ->size < size) + size = typ->size; + } + else + size = n_icntyp; + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + store = compnt_array[i].store; + for (j = 0; j < num_bits; ++j) { + if (bitset(typ1->bits, frst_bit + j)) + MrgTyp(size, store->types[j], typ->bits); + } + } + } + + free_wktyp(typ1); + break; + + case IL_Compnt: + /* + * <type>.<component> + */ + typ1 = get_wktyp(); + abstr_typ(il->u[0].fld, typ1); /* type */ + i = il->u[1].n; + if (i == CM_Fields) { + /* + * The all_fields component must be handled differently + * from the others. + */ + frst_bit = type_array[rec_typ].frst_bit; + num_bits = type_array[rec_typ].num_bits; + for (i = 0; i < num_bits; ++i) + if (bitset(typ1->bits, frst_bit + i)) { + rec = rec_map[i]; + for (j = 0; j < rec->nfields; ++j) + set_typ(typ->bits, frst_fld + rec->frst_fld + j); + } + } + else { + /* + * Use component information arrays to transform type bits to + * the corresponding component bits. + */ + frst_bit = type_array[typecompnt[i].aggregate].frst_bit; + num_bits = type_array[typecompnt[i].aggregate].num_bits; + frst_cmpnt = compnt_array[i].frst_bit; + if (!typecompnt[i].var && typ->size < n_rttyp) + break; /* bad abstract type computation */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ1->bits, frst_bit + i)) + set_typ(typ->bits, frst_cmpnt + i); + free_wktyp(typ1); + } + break; + + case IL_Union: + /* + * <type 1> ++ <type 2> + */ + abstr_typ(il->u[0].fld, typ); + abstr_typ(il->u[1].fld, typ); + break; + + case IL_Inter: + /* + * <type 1> ** <type 2> + */ + typ1 = get_wktyp(); + typ2 = get_wktyp(); + abstr_typ(il->u[0].fld, typ1); + abstr_typ(il->u[1].fld, typ2); + size = n_rttyp; +#ifdef OptimizeType + and_bits_to_packed(typ2->bits, typ1->bits, size); +#else /* OptimizeType */ + for (i = 0; i < NumInts(size); ++i) + typ1->bits[i] &= typ2->bits[i]; +#endif /* OptimizeType */ + if (typ->size < size) + size = typ->size; + MrgTyp(size, typ1->bits, typ->bits); + free_wktyp(typ1); + free_wktyp(typ2); + break; + + case IL_New: + /* + * new <type-name>(<type 1> , ...) + * + * If a type was not allocated for this node, use the default + * one. + */ + typ1 = get_wktyp(); + typcd = il->u[0].n; /* type code */ + new_indx = type_array[typcd].new_indx; + t_indx = 0; /* default is first index of type */ + if (cur_new != NULL && cur_new[new_indx] > 0) + t_indx = cur_new[new_indx]; + + /* + * This RTL expression evaluates to the "new" sub-type. + */ + set_typ(typ->bits, type_array[typcd].frst_bit + t_indx); + + /* + * Update stores for components based on argument types in the + * "new" expression. + */ + num_comps = icontypes[typcd].num_comps; + j = icontypes[typcd].compnts; + compnts = &compnt_array[j]; + if (typcd == stv_typ) { + size = n_intrtyp; + } + else + size = n_icntyp; + for (i = 0; i < num_comps; ++i) { + ClrTyp(n_rttyp, typ1->bits); + abstr_typ(il->u[2 + i].fld, typ1); + ChkMrgTyp(size, typ1->bits, compnts[i].store->types[t_indx]); + } + + free_wktyp(typ1); + break; + + case IL_IcnTyp: + typcd_bits((int)il->u[0].n, typ); /* type code */ + break; + } + } + +/* + * eval_cond - evaluate the condition of in 'if' statement from a + * built-in operation. The result can be both true and false because + * of uncertainty and because more than one execution path may be + * involved. + */ +static int eval_cond(il) +struct il_code *il; + { + int cond1; + int cond2; + + switch (il->il_type) { + case IL_Bang: + cond1 = eval_cond(il->u[0].fld); + cond2 = 0; + if (cond1 & MaybeTrue) + cond2 = MaybeFalse; + if (cond1 & MaybeFalse) + cond2 |= MaybeTrue; + return cond2; + + case IL_And: + cond1 = eval_cond(il->u[0].fld); + cond2 = eval_cond(il->u[1].fld); + return (cond1 & cond2 & MaybeTrue) | ((cond1 | cond2) & MaybeFalse); + + case IL_Cnv1: + case IL_Cnv2: + return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, + 0, NULL); + + case IL_Def1: + case IL_Def2: + return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, + 1, NULL); + + case IL_Is: + return eval_is((int)il->u[0].n, il->u[1].fld->u[0].n); + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + +/* + * eval_cnv - evaluate the conversion of a variable to a specific type + * to see if it may succeed or fail. + */ +int eval_cnv(typcd, indx, def, cnv_flags) +int typcd; /* type to convert to */ +int indx; /* index into symbol table of variable */ +int def; /* flag: conversion has a default value */ +int *cnv_flags; /* return flag for detailed conversion information */ + { + struct type *may_succeed; /* types where conversion sometimes succeed */ + struct type *must_succeed; /* types where conversion always succeeds */ + struct type *must_cnv; /* types where actual conversion is performed */ + struct type *as_is; /* types where value already has correct type */ +#ifdef OptimizeType + struct typinfo *typ; /* possible types of the variable */ +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + int cond; + int i; +#ifdef OptimizeType + unsigned int val1, val2; +#endif /* OptimizeType */ + + /* + * Conversions may succeed for strings, integers, csets, and reals. + * Conversions may fail for any other types. In addition, + * conversions to integer or real may fail for specific values. + */ + if (indx >= cur_symtyps->nsyms) + return MaybeTrue | MaybeFalse; + typ = cur_symtyps->types[indx]; + + may_succeed = get_wktyp(); + must_succeed = get_wktyp(); + must_cnv = get_wktyp(); + as_is = get_wktyp(); + + if (typcd == cset_typ || typcd == TypTCset) { + set_typ(as_is->bits, cset_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, str_bit); + set_typ(must_succeed->bits, cset_bit); + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == str_typ || typcd == TypTStr) { + set_typ(as_is->bits, str_bit); + + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, str_bit); + set_typ(must_succeed->bits, cset_bit); + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == TypCStr) { + /* + * as_is is empty. + */ + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, str_bit); + set_typ(must_succeed->bits, cset_bit); + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == real_typ) { + set_typ(as_is->bits, real_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == TypCDbl) { + /* + * as_is is empty. + */ + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == int_typ) { + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, int_bit); + } + else if (typcd == TypCInt) { + /* + * Note that conversion from an integer to a C integer can be + * done by changing the way the descriptor is accessed. It + * is not considered a real conversion. Conversion may fail + * even for integers if large integers are supported. + */ + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, real_bit); + + if (!largeints) + set_typ(must_succeed->bits, int_bit); + } + else if (typcd == TypEInt) { + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + + set_typ(must_succeed->bits, int_bit); + } + else if (typcd == TypECInt) { + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + + if (!largeints) + set_typ(must_succeed->bits, int_bit); + } + + MrgTyp(n_icntyp, as_is->bits, may_succeed->bits); + MrgTyp(n_icntyp, must_cnv->bits, may_succeed->bits); + if (def) { + set_typ(may_succeed->bits, null_bit); + set_typ(must_succeed->bits, null_bit); + } + + /* + * Determine if the conversion expression may evaluate to true or false. + */ + cond = 0; + +/* + if (typ->bits == NULL) { + typ->bits = alloc_mem_typ(typ->size); + xfer_packed_types(typ); + } + if (may_succeed->bits->bits == NULL) { + may_succeed->bits->bits = alloc_mem_typ(may_succeed->bits->size); + xfer_packed_types(may_succeed->bits); + } + if (must_succeed->bits->bits == NULL) { + must_succeed->bits->bits = alloc_mem_typ(must_succeed->bits->size); + xfer_packed_types(must_succeed->bits); + } +*/ + for (i = 0; i < NumInts(n_intrtyp); ++i) { +#ifdef OptimizeType + if ((typ->bits != NULL) && (may_succeed->bits->bits != NULL)) { + if (typ->bits[i] & may_succeed->bits->bits[i]) + cond = MaybeTrue; + } + else if ((typ->bits == NULL) && (may_succeed->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & may_succeed->bits->bits[i]) + cond = MaybeTrue; + } + else if ((typ->bits != NULL) && (may_succeed->bits->bits == NULL)) { + val2 = get_bit_vector(may_succeed->bits, i); + if (typ->bits[i] & val2) + cond = MaybeTrue; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(may_succeed->bits, i); + if (val1 & val2) + cond = MaybeTrue; + } + if ((typ->bits != NULL) && (must_succeed->bits->bits != NULL)) { + if (typ->bits[i] & ~must_succeed->bits->bits[i]) + cond |= MaybeFalse; + } + else if ((typ->bits == NULL) && (must_succeed->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & ~must_succeed->bits->bits[i]) + cond |= MaybeFalse; + } + else if ((typ->bits != NULL) && (must_succeed->bits->bits == NULL)) { + val2 = get_bit_vector(must_succeed->bits, i); + if (typ->bits[i] & ~val2) + cond |= MaybeFalse; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(must_succeed->bits, i); + if (val1 & ~val2) + cond |= MaybeFalse; + } +#else /* OptimizeType */ + if (typ[i] & may_succeed->bits[i]) + cond = MaybeTrue; + if (typ[i] & ~must_succeed->bits[i]) + cond |= MaybeFalse; +#endif /* OptimizeType */ + } + + /* + * See if more detailed information about the conversion is needed. + */ + if (cnv_flags != NULL) { + *cnv_flags = 0; +/* + if (as_is->bits == NULL) { + as_is->bits->bits = alloc_mem_typ(as_is->bits->size); + xfer_packed_types(as_is->bits); + } + if (must_cnv->bits->bits == NULL) { + must_cnv->bits->bits = alloc_mem_typ(must_cnv->bits->size); + xfer_packed_types(must_cnv->bits); + } +*/ + for (i = 0; i < NumInts(n_intrtyp); ++i) { +#ifdef OptimizeType + if ((typ->bits != NULL) && (as_is->bits->bits != NULL)) { + if (typ->bits[i] & as_is->bits->bits[i]) + *cnv_flags |= MayKeep; + } + else if ((typ->bits == NULL) && (as_is->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & as_is->bits->bits[i]) + *cnv_flags |= MayKeep; + } + else if ((typ->bits != NULL) && (as_is->bits->bits == NULL)) { + val2 = get_bit_vector(as_is->bits, i); + if (typ->bits[i] & val2) + *cnv_flags |= MayKeep; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(as_is->bits, i); + if (val1 & val2) + *cnv_flags |= MayKeep; + } + if ((typ->bits != NULL) && (must_cnv->bits->bits != NULL)) { + if (typ->bits[i] & must_cnv->bits->bits[i]) + *cnv_flags |= MayConvert; + } + else if ((typ->bits == NULL) && (must_cnv->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & must_cnv->bits->bits[i]) + *cnv_flags |= MayConvert; + } + else if ((typ->bits != NULL) && (must_cnv->bits->bits == NULL)) { + val2 = get_bit_vector(must_cnv->bits, i); + if (typ->bits[i] & val2) + *cnv_flags |= MayConvert; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(must_cnv->bits, i); + if (val1 & val2) + *cnv_flags |= MayConvert; + } +#else /* OptimizeType */ + if (typ[i] & as_is->bits[i]) + *cnv_flags |= MayKeep; + if (typ[i] & must_cnv->bits[i]) + *cnv_flags |= MayConvert; +#endif /* OptimizeType */ + } + if (def && bitset(typ, null_bit)) + *cnv_flags |= MayDefault; + } + + free_wktyp(may_succeed); + free_wktyp(must_succeed); + free_wktyp(must_cnv); + free_wktyp(as_is); + + return cond; + } + +/* + * eval_is - evaluate the result of an 'is' expression within a built-in + * operation. + */ +int eval_is(typcd, indx) +int typcd; +int indx; + { + int cond; +#ifdef OptimizeType + struct typinfo *typ; +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + + if (indx >= cur_symtyps->nsyms) + return MaybeTrue | MaybeFalse; + typ = cur_symtyps->types[indx]; + if (has_type(typ, typcd, 0)) + cond = MaybeTrue; + else + cond = 0; + if (other_type(typ, typcd)) + cond |= MaybeFalse; + return cond; + } + +/* + * eval_arith - determine which cases of an arith_case may be taken based + * on the types of its arguments. + */ +void eval_arith(indx1, indx2, maybe_int, maybe_dbl) +int indx1; +int indx2; +int *maybe_int; +int *maybe_dbl; + { +#ifdef OptimizeType + struct typinfo *typ1; /* possible types of first variable */ + struct typinfo *typ2; /* possible types of second variable */ +#else /* OptimizeType */ + unsigned int *typ1; /* possible types of first variable */ + unsigned int *typ2; /* possible types of second variable */ +#endif /* OptimizeType */ + int int1 = 0; + int int2 = 0; + int dbl1 = 0; + int dbl2 = 0; + + typ1 = cur_symtyps->types[indx1]; + typ2 = cur_symtyps->types[indx2]; + + /* + * First see what might result if you do a convert to numeric on each + * variable. + */ + if (bitset(typ1, int_bit)) + int1 = 1; + if (bitset(typ1, real_bit)) + dbl1 = 1; + if (bitset(typ1, str_bit) || bitset(typ1, cset_bit)) { + int1 = 1; + dbl1 = 1; + } + if (bitset(typ2, int_bit)) + int2 = 1; + if (bitset(typ2, real_bit)) + dbl2 = 1; + if (bitset(typ2, str_bit) || bitset(typ2, cset_bit)) { + int2 = 1; + dbl2 = 1; + } + + /* + * Use the conversion information to figure out what type of arithmetic + * might be done. + */ + if (int1 && int2) + *maybe_int = 1; + else + *maybe_int = 0; + + *maybe_dbl = 0; + if (dbl1 && dbl2) + *maybe_dbl = 1; + else if (dbl1 && int2) + *maybe_dbl = 1; + else if (int1 && dbl2) + *maybe_dbl = 1; + } + +/* + * type_case - Determine which cases are selected in a type_case + * statement. This routine is used by both type inference and + * the code generator: a different fnc is passed in each case. + * In addition, the code generator passes a case_anlz structure. + */ +int type_case(il, fnc, case_anlz) +struct il_code *il; +int (*fnc)(); +struct case_anlz *case_anlz; + { + int *typ_vect; + int i, j; + int num_cases; + int num_types; + int indx; + int sym_indx; + int typcd; + int use_dflt; +#ifdef OptimizeType + struct typinfo *typ; +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + int select; + struct type *wktyp; + + /* + * Make a copy of the type of the variable the type case is + * working on. + */ + sym_indx = il->u[0].fld->u[0].n; /* symbol table index */ + if (sym_indx >= cur_symtyps->nsyms) + typ = any_typ; /* variable is not a parameter, don't know type */ + else + typ = cur_symtyps->types[sym_indx]; + wktyp = get_wktyp(); + CpyTyp(n_intrtyp, typ, wktyp->bits); + typ = wktyp->bits; + + /* + * Loop through all the case clauses. + */ + num_cases = il->u[1].n; + indx = 2; + for (i = 0; i < num_cases; ++i) { + /* + * For each of the types selected by this clause, see if the variable's + * type bit vector contains that type and delete the type from the + * bit vector (so we know if we need the default when we are done). + */ + num_types = il->u[indx++].n; + typ_vect = il->u[indx++].vect; + select = 0; + for (j = 0; j < num_types; ++j) + if (has_type(typ, typ_vect[j], 1)) { + typcd = typ_vect[j]; + select += 1; + } + + if (select > 0) { + fnc(il->u[indx].fld); /* action */ + + /* + * If this routine was called by the code generator, we need to + * return extra information. + */ + if (case_anlz != NULL) { + ++case_anlz->n_cases; + if (select == 1) { + if (case_anlz->il_then == NULL) { + case_anlz->typcd = typcd; + case_anlz->il_then = il->u[indx].fld; + } + else if (case_anlz->il_else == NULL) + case_anlz->il_else = il->u[indx].fld; + } + else { + /* + * There is more than one possible type that will cause + * us to select this case. It can only be used in the "else". + */ + if (case_anlz->il_else == NULL) + case_anlz->il_else = il->u[indx].fld; + else + case_anlz->n_cases = 3; /* force no inlining. */ + } + } + } + ++indx; + } + + /* + * If there are types that have not been handled, indicate this by + * returning the index of the default clause. + */ + use_dflt = 0; + for (i = 0; i < n_intrtyp; ++i) + if (bitset(typ, i)) { + use_dflt = 1; + break; + } + free_wktyp(wktyp); + if (use_dflt) + return indx; + else + return -1; + } + +/* + * gen_inv - general invocation. The argument list is set up, perform + * abstract interpretation on each possible things being invoked. + */ +static void gen_inv(typ, n) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +nodeptr n; + { + int ret_flag = 0; + struct store *s_store; + struct store *store; + struct gentry *gptr; + struct implement *ip; + struct type *prc_typ; + int frst_prc; + int num_prcs; + int i; + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) {\n", n->n_file, n->n_line, n->n_col); + trc_indent = " "; + } +#endif /* TypTrc */ + + frst_prc = type_array[proc_typ].frst_bit; + num_prcs = type_array[proc_typ].num_bits; + + /* + * Dereference the type of the thing being invoked. + */ + prc_typ = get_wktyp(); + typ_deref(typ, prc_typ->bits, 0); + + s_store = succ_store; + store = get_store(1); + + if (bitset(prc_typ->bits, str_bit) || + bitset(prc_typ->bits, cset_bit) || + bitset(prc_typ->bits, int_bit) || + bitset(prc_typ->bits, real_bit)) { + /* + * Assume integer invocation; any argument may be the result type. + */ + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s{i}(", n->n_file, n->n_line, n->n_col, + trc_indent); + } +#endif /* TypTrc */ + + for (i = 0; i < num_args; ++i) { + MrgTyp(n_intrtyp, arg_typs->types[i], n->type); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + + /* + * Integer invocation may succeed or fail. + */ + ret_flag |= DoesRet | DoesFail; + mrg_store(s_store, store); + mrg_store(s_store, fail_store); + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, ") =>> "); + prt_typ(trcfile, n->type); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + } + + if (bitset(prc_typ->bits, str_bit) || + bitset(prc_typ->bits, cset_bit)) { + /* + * Assume string invocation; add all procedure types to the thing + * being invoked. + */ + for (i = 0; i < num_prcs; ++i) + set_typ(prc_typ->bits, frst_prc + i); + } + + if (bitset(prc_typ->bits, frst_prc)) { + /* + * First procedure type represents all operators that are + * available via string invocation. Scan the operator table + * looking for those that are in the string invocation table. + * Note, this is not particularly efficient or precise. + */ + for (i = 0; i < IHSize; ++i) + for (ip = ohash[i]; ip != NULL; ip = ip->blink) + if (ip->iconc_flgs & InStrTbl) { + succ_store = cpy_store(s_store); + infer_impl(ip, n, n->symtyps, n->type); + ret_flag |= ip->ret_flag; + mrg_store(succ_store, store); + free_store(succ_store); + } + } + + /* + * Check for procedure, built-in, and record constructor types + * and perform type inference on invocations of them. + */ + for (i = 1; i < num_prcs; ++i) + if (bitset(prc_typ->bits, frst_prc + i)) { + succ_store = cpy_store(s_store); + gptr = proc_map[i]; + switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { + case F_Proc: + infer_prc(gptr->val.proc, n); + ret_flag |= gptr->val.proc->ret_flag; + break; + case F_Builtin: + infer_impl(gptr->val.builtin, n, n->symtyps, n->type); + ret_flag |= gptr->val.builtin->ret_flag; + break; + case F_Record: + infer_con(gptr->val.rec, n); + ret_flag |= DoesRet | (err_conv ? DoesFail : 0); + break; + } + mrg_store(succ_store, store); + free_store(succ_store); + } + + /* + * If error conversion is supported and a non-procedure value + * might be invoked, assume the invocation can fail. + */ + if (err_conv && other_type(prc_typ->bits, proc_typ)) + mrg_store(s_store, fail_store); + + free_store(s_store); + succ_store = store; + chk_succ(ret_flag, n->store); + + free_wktyp(prc_typ); + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) }\n", n->n_file, n->n_line, n->n_col); + trc_indent = ""; + } +#endif /* TypTrc */ + } + +/* + * get_wktyp - get a dynamically allocated bit vector to use as a + * work area for doing type computations. + */ +static struct type *get_wktyp() + { + struct type *typ; + + if ((typ = type_pool) == NULL) { + typ = NewStruct(type); + typ->size = n_rttyp; + typ->bits = alloc_typ(n_rttyp); + } + else { + type_pool = type_pool->next; + ClrTyp(n_rttyp, typ->bits); + } + return typ; + } + +/* + * free_wktyp - free a dynamically allocated type bit vector. + */ +static void free_wktyp(typ) +struct type *typ; + { + typ->next = type_pool; + type_pool = typ; + } + +#ifdef TypTrc + +/* + * ChkSep - supply a separating space if this is not the first item. + */ +#define ChkSep(n) (++n > 1 ? " " : "") + +/* + * prt_typ - print a type that can include variable references. + */ +static void prt_typ(file, typ) +FILE *file; +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ + { + struct gentry *gptr; + struct lentry *lptr; + char *name; + int i, j, k; + int n; + int frst_bit; + int num_bits; + char *abrv; + + fprintf(trcfile, "{"); + n = 0; + /* + * Go through the types and see any sub-types are present. + */ + for (k = 0; k < num_typs; ++k) { + frst_bit = type_array[k].frst_bit; + num_bits = type_array[k].num_bits; + abrv = icontypes[k].abrv; + if (k == proc_typ) { + /* + * procedures, record constructors, and built-in functions. + */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) { + if (i == 0) + fprintf(file, "%sops", ChkSep(n)); + else { + gptr = proc_map[i]; + switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { + case F_Proc: + fprintf(file, "%s%s:%s", ChkSep(n), abrv, gptr->name); + break; + case F_Builtin: + fprintf(file, "%sfnc:%s", ChkSep(n), gptr->name); + break; + case F_Record: + fprintf(file, "%sconstr:%s", ChkSep(n), gptr->name); + break; + } + } + } + } + else if (k == rec_typ) { + /* + * records - include record name. + */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) + fprintf(file, "%s%s:%s", ChkSep(n), abrv, rec_map[i]->name); + } + else if (icontypes[k].support_new | k == coexp_typ) { + /* + * A type with sub-types. + */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) + fprintf(file, "%s%s%d", ChkSep(n), abrv, i); + } + else { + /* + * A type with no subtypes. + */ + if (bitset(typ, frst_bit)) + fprintf(file, "%s%s", ChkSep(n), abrv); + } + } + + for (k = 0; k < num_cmpnts; ++k) { + if (typecompnt[k].var) { + /* + * Structure component that is a variable. + */ + frst_bit = compnt_array[k].frst_bit; + num_bits = compnt_array[k].num_bits; + abrv = typecompnt[k].abrv; + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) + fprintf(file, "%s%s%d", ChkSep(n), abrv, i); + } + } + + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(typ, frst_fld + i)) + fprintf(file, "%sfld%d", ChkSep(n), i); + + /* + * global variables + */ + for (i = 0; i < n_nmgbl; ++i) + if (bitset(typ, frst_gbl + i)) { + name = NULL; + for (j = 0; j < GHSize && name == NULL; j++) + for (gptr = ghash[j]; gptr != NULL && name == NULL; + gptr = gptr->blink) + if (gptr->index == i) + name = gptr->name; + for (lptr = cur_proc->statics; lptr != NULL && name == NULL; + lptr = lptr->next) + if (lptr->val.index == i) + name = lptr->name; + /* + * Static variables may be returned and dereferenced in a procedure + * they don't belong to. + */ + if (name == NULL) + name = "?static?"; + fprintf(file, "%svar:%s", ChkSep(n), name); + } + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) + if (bitset(typ, frst_loc + i)) { + name = NULL; + for (lptr = cur_proc->args; lptr != NULL && name == NULL; + lptr = lptr->next) + if (lptr->val.index == i) + name = lptr->name; + for (lptr = cur_proc->dynams; lptr != NULL && name == NULL; + lptr = lptr->next) + if (lptr->val.index == i) + name = lptr->name; + /* + * Local variables types may appear in the wrong procedure due to + * substring trapped variables and the inference of impossible + * execution paths. Make sure we don't end up with a NULL name. + */ + if (name == NULL) + name = "?"; + fprintf(file, "%svar:%s", ChkSep(n), name); + } + + fprintf(trcfile, "}"); + } + +/* + * prt_d_typ - dereference a type and print it. + */ +static void prt_d_typ(file, typ) +FILE *file; +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +{ + struct type *wktyp; + + wktyp = get_wktyp(); + typ_deref(typ, wktyp->bits, 0); + prt_typ(file, wktyp->bits); + free_wktyp(wktyp); +} +#endif /* TypTrc */ + +/* + * get_argtyp - get an array of pointers to type bit vectors for use + * in constructing an argument list. The array is large enough for the + * largest argument list. + */ +static struct argtyps *get_argtyp() + { + struct argtyps *argtyps; + + if ((argtyps = argtyp_pool) == NULL) +#ifdef OptimizeType + argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + + ((max_prm - 1) * sizeof(struct typinfo *)))); +#else /* OptimizeType */ + argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + + ((max_prm - 1) * sizeof(unsigned int *)))); +#endif /* OptimizeType */ + else + argtyp_pool = argtyp_pool->next; + return argtyps; + } + +/* + * free_argtyp - free array of pointers to type bitvectors. + */ +static void free_argtyp(argtyps) +struct argtyps *argtyps; + { + argtyps->next = argtyp_pool; + argtyp_pool = argtyps; + } + +/* + * varsubtyp - examine a type and determine what kinds of variable + * subtypes it has and whether it has any non-variable subtypes. + * If the type consists of a single named variable, return its symbol + * table entry through the parameter "singl". + */ +int varsubtyp(typ, singl) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +struct lentry **singl; + { + struct store *stv_stor; + int subtypes; + int n_types; + int var_indx; + int frst_bit; + int num_bits; + int i, j; + + + subtypes = 0; + n_types = 0; + var_indx = -1; + + /* + * check for non-variables. + */ + for (i = 0; i < n_icntyp; ++i) + if (bitset(typ, i)) { + subtypes |= HasVal; + ++n_types; + } + + /* + * Predefined variable types. + */ + for (i = 0; i < num_typs; ++i) { + if (icontypes[i].deref != DrfNone) { + frst_bit = type_array[i].frst_bit; + num_bits = type_array[i].num_bits; + for (j = 0; j < num_bits; ++j) { + if (bitset(typ, frst_bit + j)) { + if (i == stv_typ) { + /* + * We have found substring trapped variable j, see whether it + * references locals or globals. + */ + if (do_typinfer) { + stv_stor = compnt_array[str_var].store; + subtypes |= varsubtyp(stv_stor->types[j], NULL); + } + else + subtypes |= HasLcl | HasPrm | HasGlb; + } + else + subtypes |= HasGlb; + ++n_types; + } + } + } + } + + /* + * Aggregate compontents that are variables. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (typecompnt[i].var) { + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + for (j = 0; j < num_bits; ++j) { + if (bitset(typ, frst_bit + j)) { + subtypes |= HasGlb; + ++n_types; + } + } + } + } + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(typ, frst_fld + i)) { + subtypes |= HasGlb; + ++n_types; + } + + /* + * global variables, including statics + */ + for (i = 0; i < n_gbl; ++i) { + if (bitset(typ, frst_gbl + i)) { + subtypes |= HasGlb; + var_indx = i; + ++n_types; + } + } + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) { + if (bitset(typ, frst_loc + i)) { + if (i < Abs(cur_proc->nargs)) + subtypes |= HasPrm; + else + subtypes |= HasLcl; + var_indx = n_gbl + i; + ++n_types; + } + } + + if (singl != NULL) { + /* + * See if the type consists of a single named variable. + */ + if (n_types == 1 && var_indx != -1) + *singl = cur_proc->vartypmap[var_indx]; + else + *singl = NULL; + } + + return subtypes; + } + +/* + * mark_recs - go through the list of parent records for this field + * and mark those that are in the type. Also gather information + * to help generate better code. + */ +void mark_recs(fp, typ, num_offsets, offset, bad_recs) +struct fentry *fp; +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +int *num_offsets; +int *offset; +int *bad_recs; + { + struct par_rec *rp; + struct type *wktyp; + int frst_rec; + + *num_offsets = 0; + *offset = -1; + *bad_recs = 0; + + wktyp = get_wktyp(); + CpyTyp(n_icntyp, typ, wktyp->bits); + + /* + * For each record containing this field, see if the record is + * in the type. + */ + frst_rec = type_array[rec_typ].frst_bit; + for (rp = fp->rlist; rp != NULL; rp = rp->next) { + if (bitset(wktyp->bits, frst_rec + rp->rec->rec_num)) { + /* + * This record is in the type. + */ + rp->mark = 1; + clr_typ(wktyp->bits, frst_rec + rp->rec->rec_num); + if (*offset != rp->offset) { + *offset = rp->offset; + *num_offsets += 1; + } + } + } + + /* + * Are there any records that do not contain this field? + */ + *bad_recs = has_type(wktyp->bits, rec_typ, 0); + free_wktyp(wktyp); + } + +/* + * past_prms - return true if execution might continue past the parameter + * evaluation. If a parameter has no type, this will not happen. + */ +int past_prms(n) +nodeptr n; + { + struct implement *impl; + struct symtyps *symtyps; + int nparms; + int nargs; + int flag; + int i, j; + + nargs = Val0(n); + impl = Impl1(n); + symtyps = n->symtyps; + nparms = impl->nargs; + + if (symtyps == NULL) + return 1; + + j = 0; + for (i = 0; i < nparms; ++i) { + flag = impl->arg_flgs[i]; + if (flag & VarPrm && i >= nargs) + break; /* no parameters for variable part of arg list */ + if (flag & RtParm) { + if (is_empty(symtyps->types[j])) + return 0; + ++j; + } + if (flag & DrfPrm) { + if (is_empty(symtyps->types[j])) + return 0; + ++j; + } + } + return 1; + } |