diff options
Diffstat (limited to 'src/iconc')
| -rw-r--r-- | src/iconc/Makefile | 73 | ||||
| -rw-r--r-- | src/iconc/ccode.c | 4954 | ||||
| -rw-r--r-- | src/iconc/ccode.h | 252 | ||||
| -rw-r--r-- | src/iconc/ccomp.c | 130 | ||||
| -rw-r--r-- | src/iconc/cglobals.h | 50 | ||||
| -rw-r--r-- | src/iconc/cgrammar.c | 221 | ||||
| -rw-r--r-- | src/iconc/chkinv.c | 545 | ||||
| -rw-r--r-- | src/iconc/clex.c | 18 | ||||
| -rw-r--r-- | src/iconc/cmain.c | 424 | ||||
| -rw-r--r-- | src/iconc/cmem.c | 114 | ||||
| -rw-r--r-- | src/iconc/codegen.c | 1918 | ||||
| -rw-r--r-- | src/iconc/cparse.c | 1940 | ||||
| -rw-r--r-- | src/iconc/cproto.h | 165 | ||||
| -rw-r--r-- | src/iconc/csym.c | 853 | ||||
| -rw-r--r-- | src/iconc/csym.h | 380 | ||||
| -rw-r--r-- | src/iconc/ctoken.h | 111 | ||||
| -rw-r--r-- | src/iconc/ctrans.c | 184 | ||||
| -rw-r--r-- | src/iconc/ctrans.h | 47 | ||||
| -rw-r--r-- | src/iconc/ctree.c | 777 | ||||
| -rw-r--r-- | src/iconc/ctree.h | 200 | ||||
| -rw-r--r-- | src/iconc/dbase.c | 196 | ||||
| -rw-r--r-- | src/iconc/fixcode.c | 372 | ||||
| -rw-r--r-- | src/iconc/incheck.c | 802 | ||||
| -rw-r--r-- | src/iconc/inline.c | 2007 | ||||
| -rw-r--r-- | src/iconc/ivalues.c | 51 | ||||
| -rw-r--r-- | src/iconc/lifetime.c | 496 | ||||
| -rw-r--r-- | src/iconc/types.c | 893 | ||||
| -rw-r--r-- | src/iconc/typinfer.c | 5189 |
28 files changed, 0 insertions, 23362 deletions
diff --git a/src/iconc/Makefile b/src/iconc/Makefile deleted file mode 100644 index bce6aa8..0000000 --- a/src/iconc/Makefile +++ /dev/null @@ -1,73 +0,0 @@ -# Makefile for the Icon compiler, iconc. -# -# This is no longer supported and may not work. - -include ../../Makedefs - - -OBJS = cmain.o ctrans.o dbase.o clex.o\ - cparse.o csym.o cmem.o ctree.o ccode.o ccomp.o\ - ivalues.o codegen.o fixcode.o inline.o chkinv.o\ - typinfer.o types.o lifetime.o incheck.o - -COBJS = ../common/long.o ../common/getopt.o ../common/time.o\ - ../common/filepart.o ../common/identify.o ../common/munix.o\ - ../common/strtbl.o ../common/rtdb.o ../common/literals.o \ - ../common/alloc.o ../common/ipp.o - - - -iconc: $(OBJS) $(COBJS) - $(CC) -o iconc $(OBJS) $(COBJS) - cp iconc ../../bin - strip ../../bin/iconc$(EXE) - -$(OBJS): ../h/config.h ../h/cpuconf.h ../h/cstructs.h ../h/define.h\ - ../h/mproto.h ../h/typedefs.h ../h/gsupport.h \ - ccode.h cglobals.h cproto.h csym.h ctrans.h ctree.h - -$(COBJS): ../h/mproto.h - cd ../common; $(MAKE); $(MAKE) xpm - -ccode.o: ../h/lexdef.h ctoken.h -chkinv.o: ctoken.h -clex.o: ../h/lexdef.h ../h/parserr.h ctoken.h \ - ../common/lextab.h ../common/yylex.h ../common/error.h -clocal.o: ../h/config.h -cparse.o: ../h/lexdef.h -ctrans.o: ctoken.h -ctree.o: ../h/lexdef.h ctoken.h -csym.o: ctoken.h -dbase.o: ../h/lexdef.h -lifetime.o: ../h/lexdef.h ctoken.h -typinfer.o: ../h/lexdef.h ctoken.h -types.o: ../h/lexdef.h ctoken.h - - - -# The following sections are commented out because they do not need to -# be performed unless changes are made to cgrammar.c, ../h/grammar.h, -# ../common/tokens.txt, or ../common/op.txt. Such changes involve -# modifications to the syntax of Icon and are not part of the installation -# process. However, if the distribution files are unloaded in a fashion -# such that their dates are not set properly, the following sections would -# be attempted. -# -# Note that if any changes are made to the files mentioned above, the comment -# characters at the beginning of the following lines should be removed. -# icont must be on your search path for these actions to work. -# -#../common/lextab.h ../common/yacctok.h ../common/fixgram ../common/pscript: \ -# ../common/tokens.txt ../common/op.txt -# cd ../common; $(MAKE) gfiles -# -#cparse.c ctoken.h: cgram.g ../common/pscript -## expect 218 shift/reduce conflicts -# yacc -d cgram.g -# ../common/pscript <y.tab.c >cparse.c -# mv y.tab.h ctoken.h -# rm -f y.tab.c -# -#cgram.g: cgrammar.c ../h/define.h ../h/grammar.h \ -# ../common/yacctok.h ../common/fixgram -# $(CC) -E -C cgrammar.c | ../common/fixgram >cgram.g diff --git a/src/iconc/ccode.c b/src/iconc/ccode.c deleted file mode 100644 index 108cd15..0000000 --- a/src/iconc/ccode.c +++ /dev/null @@ -1,4954 +0,0 @@ -/* - * ccode.c - routines to produce internal representation of C code. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "ctoken.h" -#include "cproto.h" - -#ifdef OptimizeLit - -#define NO_LIMIT 0 -#define LIMITED 1 -#define LIMITED_TO_INT 2 -#define NO_TOUCH 3 - -struct lit_tbl { - int modified; - int index; - int safe; - struct code *initial; - struct code *end; - struct val_loc *vloc; - struct centry *csym; - struct lit_tbl *prev; - struct lit_tbl *next; -}; -#endif /* OptimizeLit */ - -/* - * Prototypes for static functions. - */ -static struct c_fnc *alc_fnc (void); -static struct tmplftm *alc_lftm (int num, union field *args); -static int alc_tmp (int n, struct tmplftm *lifetm_ary); - -#ifdef OptimizePoll - static int analyze_poll (void); - static void remove_poll (void); -#endif /* OptimizePoll */ - -#ifdef OptimizeLit - static int instr (const char *str, int chr); - static void invalidate (struct val_loc *val,struct code *end,int code); - static void analyze_literals (struct code *start, struct code *top, int lvl); - static int eval_code (struct code *cd, struct lit_tbl *cur); - static void propagate_literals (void); - static void free_tbl (void); - static struct lit_tbl *alc_tbl (void); - static void tbl_add (truct lit_tbl *add); -#endif /* OptimizeLit */ - -static struct code *asgn_null (struct val_loc *loc1); -static struct val_loc *bound (struct node *n, struct val_loc *rslt, - int catch_fail); -static struct code *check_var (struct val_loc *d, struct code *lbl); -static void deref_cd (struct val_loc *src, struct val_loc *dest); -static void deref_ret (struct val_loc *src, struct val_loc *dest, - int subtypes); -static void endlife (int kind, int indx, int old, nodeptr n); -static struct val_loc *field_ref(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_act (nodeptr n, struct val_loc *rslt); -static struct val_loc *gen_apply(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_args (struct node *n, int frst_arg, int nargs); -static struct val_loc *gen_case (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_creat(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_lim (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_scan (struct node *n, struct val_loc *rslt); -static struct val_loc *gencode (struct node *n, struct val_loc *rslt); -static struct val_loc *genretval(struct node *n, struct node *expr, - struct val_loc *dest); -static struct val_loc *inv_prc (nodeptr n, struct val_loc *rslt); -static struct val_loc *inv_op (nodeptr n, struct val_loc *rslt); -static nodeptr max_lftm (nodeptr n1, nodeptr n2); -static void mk_callop (char *oper_nm, int ret_flag, - struct val_loc *arg1rslt, int nargs, - struct val_loc *rslt, int optim); -static struct code *mk_cpyval (struct val_loc *loc1, struct val_loc *loc2); -static struct code *new_call (void); -static char *oper_name (struct implement *impl); -static void restr_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void save_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void setloc (nodeptr n); -static struct val_loc *tmp_loc (int n); -static struct val_loc *var_ref (struct lentry *sym); -static struct val_loc *vararg_sz(int n); - -#define FrstArg 2 - -/* - * Information that must be passed between a loop and its next and break - * expressions. - */ -struct loop_info { - struct code *next_lbl; /* where to branch for a next expression */ - struct code *end_loop; /* label at end of loop */ - struct code *on_failure; /* where to go if the loop fails */ - struct scan_info *scan_info; /* scanning environment upon entering loop */ - struct val_loc *rslt; /* place to put result of loop */ - struct c_fnc *succ_cont; /* the success continuation for the loop */ - struct loop_info *prev; /* link to info for outer loop */ - }; - -/* - * The allocation status of a temporary variable can either be "in use", - * "not allocated", or reserved for use at a code position (indicated - * by a specific negative number). - */ -#define InUse 1 -#define NotAlc 0 - -/* - * tmplftm is used to precompute lifetime information for use in allocating - * temporary variables. - */ -struct tmplftm { - int cur_status; - nodeptr lifetime; - }; - -/* - * Places where &subject and &pos are saved during string scanning. "outer" - * values are saved when the scanning expression is executed. "inner" - * values are saved when the scanning expression suspends. - */ -struct scan_info { - struct val_loc *outer_sub; - struct val_loc *outer_pos; - struct val_loc *inner_sub; - struct val_loc *inner_pos; - struct scan_info *next; - }; - -struct scan_info scan_base = {NULL, 0, NULL, 0, NULL}; -struct scan_info *nxt_scan = &scan_base; - -struct val_loc ignore; /* no values, just something to point at */ -static struct val_loc proc_rslt; /* result location for procedure */ - -int *tmp_status = NULL; /* allocation status of temp descriptor vars */ -int *itmp_status = NULL; /* allocation status of temp C int vars*/ -int *dtmp_status = NULL; /* allocation status of temp C double vars */ -int *sbuf_status = NULL; /* allocation of string buffers */ -int *cbuf_status = NULL; /* allocation of cset buffers */ -int num_tmp; /* number of temp descriptors actually used */ -int num_itmp; /* number of temp C ints actually used */ -int num_dtmp; /* number of temp C doubles actually used */ -int num_sbuf; /* number of string buffers actually used */ -int num_cbuf; /* number of cset buffers actually used */ -int status_sz = 20; /* current size of tmp_status array */ -int istatus_sz = 20; /* current size of itmp_status array */ -int dstatus_sz = 20; /* current size of dtmp_status array */ -int sstatus_sz = 20; /* current size of sbuf_status array */ -int cstatus_sz = 20; /* current size of cbuf_status array */ -struct freetmp *freetmp_pool = NULL; - -static char frm_prfx[PrfxSz + 1];/* prefix for procedure frame */ -static char *lastfiln; /* last file name set in code */ -static int lastline; /* last line number set in code */ - -#ifdef OptimizePoll -static struct code *lastpoll; -#endif /* OptimizePoll */ - -#ifdef OptimizeLit -static struct lit_tbl *tbl = NULL; -static struct lit_tbl *free_lit_tbl = NULL; -#endif /* OptimizeLit */ - -static struct c_fnc *fnc_lst; /* list of C functions implementing proc */ -static struct c_fnc **flst_end; /* pointer to null pointer at end of fnc_lst */ -struct c_fnc *cur_fnc; /* C function currently being built */ -static int create_lvl = 0; /* co-expression create level */ - -struct pentry *cur_proc; /* procedure currently being translated */ - -struct code *on_failure; /* place to go on failure */ - -static struct code *p_ret_lbl; /* label for procedure return */ -static struct code *p_fail_lbl; /* label for procedure fail */ -struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -struct code resume; -struct code contin; -struct code fallthru; -struct code next_fail; - -int lbl_seq_num = 0; /* next label sequence number */ - -#ifdef OptimizeLit -static void print_tbl(struct lit_tbl *start) { - struct lit_tbl *ptr; - - for (ptr=start; ptr != NULL ;ptr=ptr->next) { - printf("mod (%2d) strchr (%2d) ",ptr->modified,ptr->index); - if (ptr->csym != NULL) { - printf("image (%13s) ",ptr->csym->image); - } - if (ptr->vloc != NULL) { - printf("val (%6d) type (%d)",ptr->vloc->u.tmp,ptr->vloc->loc_type); - } - if (ptr->end == NULL) - printf(" END IS NULL"); - printf("\n"); - } -} - - -static void free_tbl() { -/* - struct lit_tbl *ptr, *next; -*/ - free_lit_tbl = tbl; - tbl = NULL; -/* - ptr = tbl; - while (ptr != NULL) { - next = ptr->next; - free(ptr); - ptr = next; - } - tbl = NULL; -*/ -} - - -static struct lit_tbl *alc_tbl() { - struct lit_tbl *new; - static int cnt=0; - - - if (free_lit_tbl != NULL) { - new = free_lit_tbl; - free_lit_tbl = new->next; - } - else - new = (struct lit_tbl *)alloc(sizeof(struct lit_tbl)); - new->modified = NO_LIMIT; - new->index = -1; - new->safe = 1; - new->initial = NULL; - new->end = NULL; - new->vloc = NULL; - new->csym = NULL; - new->prev = NULL; - new->next = NULL; - return new; -} -#endif /* OptimizeLit */ - -/* - * proccode - generate code for a procedure. - */ -void proccode(proc) -struct pentry *proc; - { - struct c_fnc *fnc; - struct code *cd; - struct code *cd1; - struct code *lbl; - nodeptr n; - nodeptr failer; - int gen; - int i; -#ifdef OptimizeLit - struct code *procstart; -#endif /* OptimizeLit */ - - /* - * Initialize arrays used for allocating temporary variables. - */ - if (tmp_status == NULL) - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - if (itmp_status == NULL) - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - if (dtmp_status == NULL) - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - if (sbuf_status == NULL) - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - if (cbuf_status == NULL) - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Initialize standard signals. - */ - resume.cd_id = C_Resume; - contin.cd_id = C_Continue; - fallthru.cd_id = C_FallThru; - - /* - * Initialize procedure result and the transcan locations. - */ - proc_rslt.loc_type = V_PRslt; - proc_rslt.mod_access = M_None; - ignore.loc_type = V_Ignore; - ignore.mod_access = M_None; - - cur_proc = proc; /* current procedure */ - lastfiln = NULL; /* file name */ - lastline = 0; /* line number */ - -#ifdef OptimizePoll - lastpoll = NULL; -#endif /* OptimizePoll */ - - /* - * Procedure frame prefix is the procedure prefix. - */ - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = cur_proc->prefix[i]; - frm_prfx[PrfxSz] = '\0'; - - /* - * Initialize the continuation list and allocate the outer function for - * this procedure. - */ - fnc_lst = NULL; - flst_end = &fnc_lst; - cur_fnc = alc_fnc(); - -#ifdef OptimizeLit - procstart = cur_fnc->cursor; -#endif /* OptimizeLit */ - - /* - * If the procedure is not used anywhere don't generate code for it. - * This can happen when using libraries containing several procedures, - * but not all are needed. However, if there is a block for the - * procedure, we need at least a dummy function. - */ - if (!cur_proc->reachable) { - if (!(glookup(cur_proc->name)->flag & F_SmplInv)) - outerfnc(fnc_lst); - return; - } - - /* - * Allocate labels for the code for procedure failure, procedure return, - * and allocate the bounding signal for this procedure (at this point - * signals and labels are not distinguished). - */ - p_fail_lbl = alc_lbl("proc fail", 0); - p_ret_lbl = alc_lbl("proc return", 0); - bound_sig = alc_lbl("bound", 0); - - n = proc->tree; - setloc(n); - if (Type(Tree1(n)) != N_Empty) { - /* - * initial clause. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - lbl = alc_lbl("end initial", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!first_time"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "first_time = 0;"; - cd_add(cd); - bound(Tree1(n), &ignore, 1); - cur_fnc->cursor = lbl; - } - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - bound(Tree2(n), &ignore, 1); - - /* - * Place code to perform procedure failure and return and the - * end of the outer function. - */ - setloc(Tree3(n)); - cd_add(p_fail_lbl); - cd = NewCode(0); - cd->cd_id = C_PFail; - cd_add(cd); - cd_add(p_ret_lbl); - cd = NewCode(0); - cd->cd_id = C_PRet; - cd_add(cd); - - /* - * Fix up signal handling code and perform peephole optimizations. - */ - fix_fncs(fnc_lst); - -#ifdef OptimizeLit - analyze_literals(procstart, NULL, 0); - propagate_literals(); -#endif /* OptimizeLit */ - - /* - * The outer function is the first one on the list. It has the - * procedure interface; the others are just continuations. - */ - outerfnc(fnc_lst); - for (fnc = fnc_lst->next; fnc != NULL; fnc = fnc->next) - if (fnc->ref_cnt > 0) - prt_fnc(fnc); -#ifdef OptimizeLit - free_tbl(); -#endif /* OptimizeLit */ -} - -/* - * gencode - generate code for a syntax tree. - */ -static struct val_loc *gencode(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *lbl1; - struct code *lbl2; - struct code *cursor_sav; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct implement *impl; - struct implement *impl1; - struct val_loc *r1[3]; - struct val_loc *r2[2]; - struct val_loc *frst_arg; - struct lentry *single; - struct freetmp *freetmp; - struct freetmp *ft; - struct tmplftm *lifetm_ary; - char *sbuf; - int i; - int tmp_indx; - int nargs; - static struct loop_info *loop_info = NULL; - struct loop_info *li_sav; - - switch (n->n_type) { - case N_Activat: - rslt = gen_act(n, rslt); - break; - - case N_Alt: - rslt = chk_alc(rslt, n->lifetime); /* insure a result location */ - - fail_sav = on_failure; - fnc_sav = cur_fnc; - - /* - * If the first alternative fails, execution must go to the - * "alt" label. - */ - lbl1 = alc_lbl("alt", 0); - on_failure = lbl1; - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* 1st alternative goes before label */ - gencode(Tree0(n), rslt); - - /* - * Each alternative must call the same success continuation. - */ - fnc = alc_fnc(); - callc_add(fnc); - - cur_fnc = fnc_sav; /* return to the context of the label */ - cur_fnc->cursor = lbl1; /* 2nd alternative goes after label */ - on_failure = fail_sav; /* on failure, alternation fails */ - gencode(Tree1(n), rslt); - callc_add(fnc); /* call continuation */ - - /* - * Code following the alternation goes in the continuation. If - * the code fails, the continuation returns the resume signal. - */ - cur_fnc = fnc; - on_failure = &resume; - break; - - case N_Apply: - rslt = gen_apply(n, rslt); - break; - - case N_Augop: - impl = Impl0(n); /* assignment */ - impl1 = Impl1(n); /* the operation */ - if (impl == NULL || impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - /* - * allocate an argument list for the operation. - */ - lifetm_ary = alc_lftm(2, &n->n_field[2]); - tmp_indx = alc_tmp(2, lifetm_ary); - r1[0] = tmp_loc(tmp_indx); - r1[1] = tmp_loc(tmp_indx + 1); - - gencode(Tree2(n), r1[0]); /* first argument */ - - /* - * allocate an argument list for the assignment and copy the - * value of the first argument into it. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[1].cur_status = n->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(2, lifetm_ary); - r2[0] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[0])); - r2[1] = tmp_loc(tmp_indx); - - gencode(Tree3(n), r1[1]); /* second argument */ - - /* - * Produce code for the operation. - */ - setloc(n); - implproto(impl1); - mk_callop(oper_name(impl1), impl1->ret_flag, r1[0], 2, r2[1], 0); - - /* - * Produce code for the assignment. - */ - implproto(impl); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, rslt, 0); - - free((char *)lifetm_ary); - break; - - case N_Bar: { - struct val_loc *fail_flg; - - /* - * Allocate an integer variable to keep track of whether the - * repeated alternation should fail when execution reaches - * the top of its loop, and generate code to initialize the - * variable to 0. - */ - fail_flg = itmp_loc(alc_itmp(n->intrnl_lftm)); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - - /* - * Code at the top of the repeated alternation loop checks - * the failure flag. - */ - lbl1 = alc_lbl("rep alt", 0); - cd_add(lbl1); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = fail_flg; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * If the expression fails without producing a value, the - * repeated alternation must fail. - */ - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 1;"; - cd_add(cd); - - /* - * Generate code for the repeated expression. If it produces - * a value before before backtracking occurs, the loop is - * repeated as indicated by the value of the failure flag. - */ - on_failure = lbl1; - rslt = gencode(Tree0(n), rslt); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - } - break; - - case N_Break: - if (loop_info == NULL) { - nfatal(n, "invalid context for a break expression", NULL); - rslt = &ignore; - break; - } - - /* - * If the break is in a different string scanning context from the - * loop itself, generate code to restore the scanning environment. - */ - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - - - if (Tree0(n)->n_type == N_Empty && loop_info->rslt == &ignore) { - /* - * The break has no associated expression and the loop needs - * no value, so just branch out of the loop. - */ - cd_add(sig_cd(loop_info->end_loop, cur_fnc)); - } - else { - /* - * The code for the expression associated with the break is - * actually placed at the end of the loop. Go there and - * add a label to branch to. - */ - cursor_sav = cur_fnc->cursor; - fnc_sav = cur_fnc; - fail_sav = on_failure; - cur_fnc = loop_info->end_loop->Container; - cur_fnc->cursor = loop_info->end_loop->prev; - on_failure = loop_info->on_failure; - lbl1 = alc_lbl("break", 0); - cd_add(lbl1); - - /* - * Make sure a result location has been allocated for the - * loop, restore the loop information for the next outer - * loop, generate code for the break expression, then - * restore the loop information for this loop. - */ - loop_info->rslt = chk_alc(loop_info->rslt, Tree0(n)->lifetime); - li_sav = loop_info; - loop_info = loop_info->prev; - gencode(Tree0(n), li_sav->rslt); - loop_info = li_sav; - - /* - * If this or another break expression suspends so we cannot - * just branch to the end of the loop, all breaks must - * call a common continuation. - */ - if (cur_fnc->cursor->next != loop_info->end_loop && - loop_info->succ_cont == NULL) - loop_info->succ_cont = alc_fnc(); - if (loop_info->succ_cont == NULL) - cd_add(mk_goto(loop_info->end_loop)); /* go to end of loop */ - else - callc_add(loop_info->succ_cont); /* call continuation */ - - /* - * Return to the location of the break and generate a branch to - * the code for its associated expression. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cursor_sav; - on_failure = fail_sav; - cd_add(sig_cd(lbl1, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Case: - rslt = gen_case(n, rslt); - break; - - case N_Create: - rslt = gen_creat(n, rslt); - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - cd = NewCode(2); - cd->cd_id = C_Lit; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->Literal = CSym0(n); - cd_add(cd); - break; - - case N_Empty: - /* - * Assume null value is needed. - */ - if (rslt == &ignore) - break; - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - break; - - case N_Field: - rslt = field_ref(n, rslt); - break; - - case N_Id: - /* - * If the variable reference is not going to be used, don't bother - * building it. - */ - if (rslt == &ignore) - break; - cd = NewCode(2); - cd->cd_id = C_NamedVar; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->NamedVar = LSym0(n); - cd_add(cd); - break; - - case N_If: - if (Type(Tree2(n)) == N_Empty) { - /* - * if-then. Control clause is bounded, but otherwise trivial. - */ - bound(Tree0(n), &ignore, 0); /* control clause */ - rslt = gencode(Tree1(n), rslt); /* then clause */ - } - else { - /* - * if-then-else. Establish an "else" label as the failure - * label of the bounded control clause. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - lbl1 = alc_lbl("else", 0); - on_failure = lbl1; - - bound(Tree0(n), &ignore, 0); /* control clause */ - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* then clause goes before else lbl */ - on_failure = fail_sav; - rslt = chk_alc(rslt, n->lifetime); - gencode(Tree1(n), rslt); /* then clause */ - - /* - * If the then clause is not a generator, execution can - * just go to the end of the if-then-else expression. If it - * is a generator, the continuation for the expression must be - * in a separate function. - */ - if (cur_fnc->cursor->next == lbl1) { - fnc = NULL; - lbl2 = alc_lbl("end if", 0); - cd_add(mk_goto(lbl2)); - cur_fnc->cursor = lbl1; - cd_add(lbl2); - } - else { - lbl2 = NULL; - fnc = alc_fnc(); - callc_add(fnc); - cur_fnc = fnc_sav; - } - - cur_fnc->cursor = lbl1; /* else clause goes after label */ - on_failure = fail_sav; - gencode(Tree2(n), rslt); /* else clause */ - - /* - * If the else clause is not a generator, execution is at - * the end of the if-then-else expression, but the if clause - * may have forced the continuation to be in a separate function. - * If the else clause is a generator, it forces the continuation - * to be in a separate function. - */ - if (fnc == NULL) { - if (cur_fnc->cursor->next == lbl2) - cur_fnc->cursor = lbl2; - else { - fnc = alc_fnc(); - callc_add(fnc); - /* - * The then clause is not a generator, so it has branched - * to lbl2. We must add a call to the continuation there. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl2; - on_failure = fail_sav; - callc_add(fnc); - } - } - else - callc_add(fnc); - - if (fnc != NULL) { - /* - * We produced a continuation for the if-then-else, so code - * generation must proceed in it. - */ - cur_fnc = fnc; - on_failure = &resume; - } - } - break; - - case N_Invok: - /* - * General invocation. - */ - nargs = Val0(n); - if (Tree1(n)->n_type == N_Empty) { - /* - * Mutual evaluation. - */ - for (i = 2; i <= nargs; ++i) - gencode(n->n_field[i].n_ptr, &ignore); /* arg i - 1 */ - rslt = chk_alc(rslt, n->lifetime); - gencode(n->n_field[nargs + 1].n_ptr, rslt); /* last argument */ - } - else { - ++nargs; /* consider the procedure an argument to invoke() */ - frst_arg = gen_args(n, 1, nargs); - setloc(n); - /* - * Assume this operation uses its result location as a work - * area. Give it a location that is tended, where the value - * is retained as long as the operation can be resumed. - */ - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - rslt = chk_alc(rslt, max_lftm(n->lifetime, n->intrnl_lftm)); - mk_callop( "invoke", DoesRet | DoesFail | DoesSusp, frst_arg, nargs, - rslt, 0); - } - break; - - case N_InvOp: - rslt = inv_op(n, rslt); - break; - - case N_InvProc: - rslt = inv_prc(n, rslt); - break; - - case N_InvRec: { - /* - * Directly invoke a record constructor. - */ - struct rentry *rec; - - nargs = Val0(n); /* number of arguments */ - frst_arg = gen_args(n, 2, nargs); - setloc(n); - rec = Rec1(n); - - rslt = chk_alc(rslt, n->lifetime); - - /* - * If error conversion can occur then the record constructor may - * fail and we must check the signal. - */ - if (err_conv) { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + - strlen("signal = R_") + PrfxSz + 1)); - sprintf(sbuf, "signal = R%s_%s(", rec->prefix, rec->name); - } - else { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + PrfxSz +4)); - sprintf(sbuf, "R%s_%s(", rec->prefix, rec->name); - } - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; /* constructor name */ - cd->Str(0) = sbuf; - cd->ElemTyp(1) = A_Intgr; /* number of arguments */ - cd->Intgr(1) = nargs; - cd->ElemTyp(2) = A_Str; /* , */ - cd->Str(2) = ", "; - if (frst_arg == NULL) { /* location of first argument */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "NULL"; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ""; - } - else { - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "&"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = frst_arg; - } - cd->ElemTyp(5) = A_Str; /* , */ - cd->Str(5) = ", "; - cd->ElemTyp(6) = A_Str; /* location of result */ - cd->Str(6) = "&"; - cd->ElemTyp(7) = A_ValLoc; - cd->ValLoc(7) = rslt; - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - if (err_conv) { - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "signal == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - } - break; - - case N_Limit: - rslt = gen_lim(n, rslt); - break; - - case N_Loop: { - struct loop_info li; - - /* - * Set up loop information for use by break and next expressions. - */ - li.end_loop = alc_lbl("end loop", 0); - cd_add(li.end_loop); - cur_fnc->cursor = li.end_loop->prev; /* loop goes before label */ - li.rslt = rslt; - li.on_failure = on_failure; - li.scan_info = nxt_scan; - li.succ_cont = NULL; - li.prev = loop_info; - loop_info = &li; - - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * "next" in the control clause just fails. - */ - li.next_lbl = &next_fail; - gencode(Tree1(n), &ignore); /* control clause */ - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); /* resume control clause */ - break; - - case REPEAT: - li.next_lbl = alc_lbl("repeat", 0); - cd_add(li.next_lbl); - bound(Tree1(n), &ignore, 1); - cd_add(mk_goto(li.next_lbl)); - break; - - case SUSPEND: /* suspension expression */ - if (create_lvl > 0) { - nfatal(n, "invalid context for suspend", NULL); - return &ignore; - } - /* - * "next" in the control clause just fails. The result - * of the control clause goes in the procedure return - * location. - */ - li.next_lbl = &next_fail; - genretval(n, Tree1(n), &proc_rslt); - - /* - * If necessary, swap scanning environments before suspending. - * if there is no success continuation, just return. - */ - if (nxt_scan != &scan_base) { - save_env(scan_base.inner_sub, scan_base.inner_pos); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - } - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ProcCont; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == NULL"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(p_ret_lbl, cur_fnc); - cd_add(cd); - cd = NewCode(0); - cd->cd_id = C_PSusp; - cd_add(cd); - cur_fnc->flag |= CF_ForeignSig; - - /* - * Force updating file name and line number, and if needed, - * switch scanning environments before resuming. - */ - lastfiln = NULL; - lastline = 0; - if (nxt_scan != &scan_base) { - save_env(scan_base.outer_sub, scan_base.outer_pos); - restr_env(scan_base.inner_sub, scan_base.inner_pos); - } - - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case WHILE: - li.next_lbl = alc_lbl("while", 0); - cd_add(li.next_lbl); - /* - * The control clause and do clause are both bounded expressions, - * but only the do clause establishes a new failure label. - */ - bound(Tree1(n), &ignore, 0); /* control clause */ - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - break; - - case UNTIL: - fail_sav = on_failure; - li.next_lbl = alc_lbl("until", 0); - cd_add(li.next_lbl); - - /* - * If the control clause fails, execution continues in - * the loop. - */ - if (Type(Tree2(n)) == N_Empty) - on_failure = li.next_lbl; - else { - lbl2 = alc_lbl("do", 0); - on_failure = lbl2; - cd_add(lbl2); - cur_fnc->cursor = lbl2->prev; /* control before label */ - } - bound(Tree1(n), &ignore, 0); /* control clause */ - - /* - * If the control clause succeeds, the loop fails. - */ - cd_add(sig_cd(fail_sav, cur_fnc)); - - if (Type(Tree2(n)) != N_Empty) { - /* - * Do clause goes after the label and the loop repeats. - */ - cur_fnc->cursor = lbl2; - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - } - break; - } - - /* - * Go to the end of the loop and see if the loop's success continuation - * is in a separate function. - */ - cur_fnc = li.end_loop->Container; - cur_fnc->cursor = li.end_loop; - if (li.succ_cont != NULL) { - callc_add(li.succ_cont); - cur_fnc = li.succ_cont; - on_failure = &resume; - } - if (li.rslt == NULL) - rslt = &ignore; /* shouldn't be used but must be something valid */ - else - rslt = li.rslt; - loop_info = li.prev; - break; - } - - case N_Next: - /* - * In some contexts "next" just fails. In other contexts it - * transfers control to a label, in which case it may have - * to restore a scanning environment. - */ - if (loop_info == NULL) - nfatal(n, "invalid context for a next expression", NULL); - else if (loop_info->next_lbl == &next_fail) - cd_add(sig_cd(on_failure, cur_fnc)); - else { - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - cd_add(sig_cd(loop_info->next_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Not: - lbl1 = alc_lbl("not", 0); - fail_sav = on_failure; - on_failure = lbl1; - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - bound(Tree0(n), &ignore, 0); - on_failure = fail_sav; - cd_add(sig_cd(on_failure, cur_fnc)); /* convert success to failure */ - cur_fnc->cursor = lbl1; /* convert failure to null */ - if (rslt != &ignore) { - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - } - break; - - case N_Ret: - if (create_lvl > 0) { - nfatal(n, "invalid context for return or fail", NULL); - return &ignore; - } - if (Val0(Tree0(n)) == RETURN) { - /* - * Set up the failure action of the return expression to do a - * procedure fail. - */ - if (nxt_scan != &scan_base) { - /* - * we must switch scanning environments if the expression fails. - */ - lbl1 = alc_lbl("return fail", 0); - cd_add(lbl1); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - on_failure = lbl1; - } - else - on_failure = p_fail_lbl; - - /* - * Produce code to place return value in procedure result location. - */ - genretval(n, Tree1(n), &proc_rslt); - - /* - * See if a scanning environment must be restored and - * transfer control to the procedure return code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_ret_lbl, cur_fnc)); - } - else { - /* - * fail. See if a scanning environment must be restored and - * transfer control to the procedure failure code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Scan: - rslt = gen_scan(n, rslt); - break; - - case N_Sect: - /* - * x[i+:j] or x[i-:j] (x[i:j] handled as ordinary operator) - */ - impl1 = Impl0(n); /* sectioning */ - if (impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - implproto(impl1); - - impl = Impl1(n); /* plus or minus */ - /* - * Allocate work area of temporary variables for sectioning. - */ - lifetm_ary = alc_lftm(3, NULL); - lifetm_ary[0].cur_status = Tree2(n)->postn; - lifetm_ary[0].lifetime = n->intrnl_lftm; - lifetm_ary[1].cur_status = Tree3(n)->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - lifetm_ary[2].cur_status = n->postn; - lifetm_ary[2].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(3, lifetm_ary); - for (i = 0; i < 3; ++i) - r1[i] = tmp_loc(tmp_indx++); - gencode(Tree2(n), r1[0]); /* generate code to compute x */ - gencode(Tree3(n), r1[1]); /* generate code compute i */ - - /* - * Allocate work area of temporary variables for arithmetic. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[0].lifetime = Tree3(n)->lifetime; - lifetm_ary[1].cur_status = Tree4(n)->postn; - lifetm_ary[1].lifetime = Tree4(n)->lifetime; - tmp_indx = alc_tmp(2, lifetm_ary); - for (i = 0; i < 2; ++i) - r2[i] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[1])); /* generate code to copy i */ - gencode(Tree4(n), r2[1]); /* generate code to compute j */ - - /* - * generate code for i op j. - */ - setloc(n); - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, r1[2], 0); - - /* - * generate code for x[i : (i op j)] - */ - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl1),impl1->ret_flag,r1[0],3,rslt,0); - free((char *)lifetm_ary); - break; - - case N_Slist: - bound(Tree0(n), &ignore, 1); - rslt = gencode(Tree1(n), rslt); - break; - - case N_SmplAsgn: { - struct val_loc *var, *val; - - /* - * Optimized assignment to a named variable. Use information - * from type inferencing to determine if the right-hand-side - * is a variable. - */ - var = var_ref(LSym0(Tree2(n))); - if (HasVar(varsubtyp(Tree3(n)->type, &single))) - Val0(n) = AsgnDeref; - if (single != NULL) { - /* - * Right-hand-side results in a named variable. Compute - * the expression but don't bother saving the result, we - * know what it is. Assignment just copies value from - * one variable to the other. - */ - gencode(Tree3(n), &ignore); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - gencode(Tree3(n), var); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = gencode(Tree3(n), NULL); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = gencode(Tree3(n), NULL); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - case N_SmplAug: { - /* - * Optimized augmented assignment to a named variable. - */ - struct val_loc *var, *val; - - impl = Impl1(n); /* the operation */ - if (impl == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - implproto(impl); /* insure prototype for operation */ - - /* - * Generate code to compute the arguments for the operation. - */ - frst_arg = gen_args(n, 2, 2); - setloc(n); - - /* - * Use information from type inferencing to determine if the - * operation produces a variable. - */ - if (HasVar(varsubtyp(Typ4(n), &single))) - Val0(n) = AsgnDeref; - var = var_ref(LSym0(Tree2(n))); - if (single != NULL) { - /* - * The operation results in a named variable. Call the operation - * but don't bother saving the result, we know what it is. - * Assignment just copies value from one variable to the other. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - &ignore, 0); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - var, 0); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - - /* - * Free any temporaries whose lifetime ends at this node. - */ - freetmp = n->freetmp; - while (freetmp != NULL) { - switch (freetmp->kind) { - case DescTmp: - tmp_status[freetmp->indx] = freetmp->old; - break; - case CIntTmp: - itmp_status[freetmp->indx] = freetmp->old; - break; - case CDblTmp: - dtmp_status[freetmp->indx] = freetmp->old; - break; - case SBuf: - sbuf_status[freetmp->indx] = freetmp->old; - break; - case CBuf: - cbuf_status[freetmp->indx] = freetmp->old; - break; - } - ft = freetmp->next; - freetmp->next = freetmp_pool; - freetmp_pool = freetmp; - freetmp = ft; - } - return rslt; - } - -/* - * chk_alc - make sure a result location has been allocated. If it is - * a temporary variable, indicate that it is now in use. - */ -struct val_loc *chk_alc(rslt, lifetime) -struct val_loc *rslt; -nodeptr lifetime; - { - struct tmplftm tmplftm; - - if (rslt == NULL) { - if (lifetime == NULL) - rslt = &ignore; - else { - tmplftm.cur_status = InUse; - tmplftm.lifetime = lifetime; - rslt = tmp_loc(alc_tmp(1, &tmplftm)); - } - } - else if (rslt->loc_type == V_Temp) - tmp_status[rslt->u.tmp] = InUse; - return rslt; - } - -/* - * mk_goto - make a code structure for goto label - */ -struct code *mk_goto(label) -struct code *label; - { - register struct code *cd; - - cd = NewCode(1); /* # fields == # fields of C_RetSig & C_Break */ - cd->cd_id = C_Goto; - cd->next = NULL; - cd->prev = NULL; - cd->Lbl = label; - ++label->RefCnt; - return cd; - } - -/* - * mk_cpyval - make code to copy a value from one location to another. - */ -static struct code *mk_cpyval(loc1, loc2) -struct val_loc *loc1; -struct val_loc *loc2; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = loc2; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - return cd; - } - -/* - * asgn_null - make code to assign the null value to a location. - */ -static struct code *asgn_null(loc1) -struct val_loc *loc1; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nulldesc;"; - return cd; - } - -/* - * oper_name - create the name for the most general implementation of an Icon - * operation. - */ -static char *oper_name(impl) -struct implement *impl; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "%c%c%c_%s", impl->oper_typ, impl->prefix[0], impl->prefix[1], - impl->name); - return sbuf; - } - -/* - * gen_args - generate code to evaluate an argument list. - */ -static struct val_loc *gen_args(n, frst_arg, nargs) -struct node *n; -int frst_arg; -int nargs; - { - struct tmplftm *lifetm_ary; - int i; - int tmp_indx; - - if (nargs == 0) - return NULL; - - lifetm_ary = alc_lftm(nargs, &n->n_field[frst_arg]); - tmp_indx = alc_tmp(nargs, lifetm_ary); - for (i = 0; i < nargs; ++i) - gencode(n->n_field[frst_arg + i].n_ptr, tmp_loc(tmp_indx + i)); - free((char *)lifetm_ary); - return tmp_loc(tmp_indx); - } - -/* - * gen_case - generate code for a case expression. - */ -static struct val_loc *gen_case(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *control; - struct node *cases; - struct node *deflt; - struct node *clause; - struct val_loc *r1; - struct val_loc *r2; - struct val_loc *r3; - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *skp_lbl; - struct code *cd_lbl; - struct code *end_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont = NULL; - - control = Tree0(n); - cases = Tree1(n); - deflt = Tree2(n); - - /* - * The control clause is bounded. - */ - r1 = chk_alc(NULL, n); - bound(control, r1, 0); - - /* - * Remember the context in which the case expression occurs and - * establish a label at the end of the expression. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - end_lbl = alc_lbl("end case", 0); - cd_add(end_lbl); - cur_fnc->cursor = end_lbl->prev; /* generate code before the end label */ - - /* - * All cases share the result location of the case expression. - */ - rslt = chk_alc(rslt, n->lifetime); - r2 = chk_alc(NULL, n); /* for result of selection clause */ - r3 = chk_alc(NULL, n); /* for dereferenced result of control clause */ - - while (cases != NULL) { - /* - * See if we are at the end of the case clause list. - */ - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * If the evaluation of the selection code or the comparison of - * its value to the control clause fail, execution will proceed - * to the "skip clause" label and on to the next case. - */ - skp_lbl = alc_lbl("skip clause", 0); - on_failure = skp_lbl; - cd_add(skp_lbl); - cur_fnc->cursor = skp_lbl->prev; /* generate code before end label */ - - /* - * Bound the selection code for this clause. - */ - cd_lbl = alc_lbl("selected code", Bounding); - cd_add(cd_lbl); - cur_fnc->cursor = cd_lbl->prev; - gencode(Tree0(clause), r2); - - /* - * Dereference the results of the control clause and the selection - * clause and compare them. - */ - setloc(clause); - deref_cd(r1, r3); - deref_cd(r2, r2); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!equiv(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = r3; - cd->Cond = cd1; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = r2; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - cd_add(sig_cd(cd_lbl, cur_fnc)); /* transfer control to bounding label */ - - /* - * Generate code for the body of this clause after the bounding label. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cd_lbl; - on_failure = fail_sav; - gencode(Tree1(clause), rslt); - - /* - * If this clause is a generator, call the success continuation - * for the case expression, otherwise branch to the end of the - * expression. - */ - if (cur_fnc->cursor->next != skp_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); /* allocate a continuation function */ - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - else - cd_add(mk_goto(end_lbl)); - - /* - * The code for the next clause goes after the "skip" label of - * this clause. - */ - cur_fnc->cursor = skp_lbl; - } - - if (deflt == NULL) - cd_add(sig_cd(fail_sav, cur_fnc)); /* default action is failure */ - else { - /* - * There is an explicit default action. - */ - on_failure = fail_sav; - gencode(deflt, rslt); - if (cur_fnc->cursor->next != end_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - } - cur_fnc->cursor = end_lbl; - - /* - * If some clauses are generators but others have transferred control - * to here, we must call the success continuation of the case - * expression and generate subsequent code there. - */ - if (succ_cont != NULL) { - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - } - return rslt; - } - -/* - * gen_creat - generate code to create a co-expression. - */ -static struct val_loc *gen_creat(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *fail_sav; - struct code *fail_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct val_loc *co_rslt; - struct freetmp *ft; - char sav_prfx[PrfxSz]; - int *tmp_sv; - int *itmp_sv; - int *dtmp_sv; - int *sbuf_sv; - int *cbuf_sv; - int ntmp_sv; - int nitmp_sv; - int ndtmp_sv; - int nsbuf_sv; - int ncbuf_sv; - int stat_sz_sv; - int istat_sz_sv; - int dstat_sz_sv; - int sstat_sz_sv; - int cstat_sz_sv; - int i; - - - rslt = chk_alc(rslt, n->lifetime); - - fail_sav = on_failure; - fnc_sav = cur_fnc; - for (i = 0; i < PrfxSz; ++i) - sav_prfx[i] = frm_prfx[i]; - - /* - * Temporary variables are allocated independently for the co-expression. - */ - tmp_sv = tmp_status; - itmp_sv = itmp_status; - dtmp_sv = dtmp_status; - sbuf_sv = sbuf_status; - cbuf_sv = cbuf_status; - stat_sz_sv = status_sz; - istat_sz_sv = istatus_sz; - dstat_sz_sv = dstatus_sz; - sstat_sz_sv = sstatus_sz; - cstat_sz_sv = cstatus_sz; - ntmp_sv = num_tmp; - nitmp_sv = num_itmp; - ndtmp_sv = num_dtmp; - nsbuf_sv = num_sbuf; - ncbuf_sv = num_cbuf; - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Put code for co-expression in separate function. We will need a new - * type of procedure frame which contains copies of local variables, - * copies of arguments, and temporaries for use by the co-expression. - */ - fnc = alc_fnc(); - fnc->ref_cnt = 1; - fnc->flag |= CF_Coexpr; - ChkPrefix(fnc->prefix); - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = fnc->frm_prfx[i] = fnc->prefix[i]; - cur_fnc = fnc; - - /* - * Set up a co-expression failure label followed by a context switch - * and a branch back to the failure label. - */ - fail_lbl = alc_lbl("co_fail", 0); - cd_add(fail_lbl); - lastline = 0; /* force setting line number so tracing matches interp */ - setloc(n); - cd = alc_ary(2); - cd->ElemTyp(0) = A_Str; - cd->ElemTyp(1) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)),"; - cd->Str(1) = "NULL, NULL, A_Cofail, 1);"; - cd_add(cd); - cd_add(mk_goto(fail_lbl)); - cur_fnc->cursor = fail_lbl->prev; /* code goes before failure label */ - on_failure = fail_lbl; - - /* - * Generate code for the co-expression body, using the same - * dereferencing rules as for procedure return. - */ - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - ++create_lvl; - co_rslt = genretval(n, Tree0(n), NULL); - --create_lvl; - - /* - * If the co-expression might produce a result, generate a co-expression - * context switch. - */ - if (co_rslt != NULL) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "++BlkLoc(k_current)->coexpr.size;"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)), &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = co_rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL, A_Coret, 1);"; - cd_add(cd); - cd_add(sig_cd(on_failure, cur_fnc)); /* if reactivated, resume expr */ - } - - /* - * Output the new frame definition. - */ - prt_frame(frm_prfx, cur_proc->tnd_loc + num_tmp + Abs(cur_proc->nargs), - num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Now return to original function and produce code to create the - * co-expression. - */ - cur_fnc = fnc_sav; - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = sav_prfx[i]; - on_failure = fail_sav; - - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - cd = NewCode(5); - cd->cd_id = C_Create; - cd->Rslt = rslt; - cd->Cont = fnc; - cd->NTemps = num_tmp; - cd->WrkSize = num_itmp; - cd->NextCreat = cur_fnc->creatlst; - cur_fnc->creatlst = cd; - cd_add(cd); - - /* - * Restore arrays for temporary variable allocation. - */ - free((char *)tmp_status); - free((char *)itmp_status); - free((char *)dtmp_status); - free((char *)sbuf_status); - free((char *)cbuf_status); - tmp_status = tmp_sv; - itmp_status = itmp_sv; - dtmp_status = dtmp_sv; - sbuf_status = sbuf_sv; - cbuf_status = cbuf_sv; - status_sz = stat_sz_sv; - istatus_sz = istat_sz_sv; - dstatus_sz = dstat_sz_sv; - sstatus_sz = sstat_sz_sv; - cstatus_sz = cstat_sz_sv; - num_tmp = ntmp_sv; - num_itmp = nitmp_sv; - num_dtmp = ndtmp_sv; - num_sbuf = nsbuf_sv; - num_cbuf = ncbuf_sv; - - /* - * Temporary variables that exist to the end of the co-expression - * have no meaning in the surrounding code and must not be - * deallocated there. - */ - while (n->freetmp != NULL) { - ft = n->freetmp->next; - n->freetmp->next = freetmp_pool; - freetmp_pool = n->freetmp; - n->freetmp = ft; - } - - return rslt; - } - -/* - * gen_lim - generate code for limitation. - */ -static struct val_loc *gen_lim(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *expr; - struct node *limit; - struct val_loc *lim_desc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct code *fail_sav; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont; - struct val_loc *lim_int; - struct lentry *single; - int deref; - - expr = Tree0(n); - limit = Tree1(n); - - /* - * Generate code to compute the limitation value and dereference it. - */ - deref = HasVar(varsubtyp(limit->type, &single)); - if (single != NULL) { - /* - * Limitation is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(limit, &ignore); - lim_desc = var_ref(single); - } - else { - lim_desc = gencode(limit, NULL); - if (deref) - deref_cd(lim_desc, lim_desc); - } - - setloc(n); - fail_sav = on_failure; - - /* - * Try to convert the limitation value into an integer. - */ - lim_int = itmp_loc(alc_itmp(n->intrnl_lftm)); - cur_symtyps = n->symtyps; - if (largeints || (eval_is(int_typ, 0) & MaybeFalse)) { - /* - * Must call the conversion routine. - */ - lbl = alc_lbl("limit is int", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* conversion goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_c_int(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_desc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = lim_int; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(101, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - /* - * The C integer is in the vword. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = lim_int; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = IntVal("; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = lim_desc; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - } - - /* - * Make sure the limitation value is positive. - */ - lbl = alc_lbl("limit positive", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " >= 0"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(205, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - - /* - * If the limitation value is 0, fail immediately. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * Establish where to go when limit has been reached. - */ - fnc_sav = cur_fnc; - lbl = alc_lbl("limit", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* limited expression goes before label */ - - /* - * Generate code for limited expression and to check the limit value. - */ - rslt = gencode(expr, rslt); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "--"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_int; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(lbl, cur_fnc); - cd_add(cd); - - /* - * Call the success continuation both here and after the limitation - * label. - */ - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl; - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - - return rslt; - } - -/* - * gen_apply - generate code for the apply operator, !. - */ -static struct val_loc *gen_apply(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct val_loc *callee; - struct val_loc *lst; - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - - /* - * Generate code to compute the two operands. - */ - callee = gencode(Tree0(n), NULL); - lst = gencode(Tree1(n), NULL); - rslt = chk_alc(rslt, n->lifetime); - setloc(n); - - /* - * Construct argument list for apply(). - */ - arg_lst = alc_ary(6); - arg_lst->ElemTyp(0) = A_Str; - arg_lst->Str(0) = "&"; - arg_lst->ElemTyp(1) = A_ValLoc; - arg_lst->ValLoc(1) = callee; - arg_lst->ElemTyp(2) = A_Str; - arg_lst->Str(2) = ", &"; - arg_lst->ElemTyp(3) = A_ValLoc; - arg_lst->ValLoc(3) = lst; - arg_lst->ElemTyp(4) = A_Str; - arg_lst->Str(4) = ", &"; - arg_lst->ElemTyp(5) = A_ValLoc; - arg_lst->ValLoc(5) = rslt; - - /* - * Generate code to call apply(). Assume the operation can suspend and - * allocate a continuation. If it returns a "continue" signal, - * just break out of the signal handling code and fall into a call - * to the continuation. - */ - on_ret = NewCode(1); /* #fields for C_Break == #fields for C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - fnc = alc_fnc(); /* success continuation */ - callo_add("apply", DoesFail | DoesRet | DoesSusp, fnc, 1, arg_lst, on_ret); - callc_add(fnc); - cur_fnc = fnc; /* subsequent code goes in the continuation */ - on_failure = &resume; - - return rslt; - } - - -/* - * gen_scan - generate code for string scanning. - */ -static struct val_loc *gen_scan(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *subj; - struct node *body; - struct scan_info *scanp; - struct val_loc *asgn_var; - struct val_loc *new_subj; - struct val_loc *scan_rslt; - struct tmplftm *lifetm_ary; - struct lentry *subj_single; - struct lentry *body_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int subj_deref; - int body_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node '?' or '?:=' */ - subj = Tree1(n); /* subject expression */ - body = Tree2(n); /* scanning expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * The location of the save areas for scanning environments is stored - * in list so they can be accessed by expressions that transfer - * control out of string scanning. Get the next list element and - * allocate the save areas in the procedure frame. - */ - scanp = nxt_scan; - if (nxt_scan->next == NULL) - nxt_scan->next = NewStruct(scan_info); - nxt_scan = nxt_scan->next; - scanp->outer_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->outer_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - scanp->inner_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->inner_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - - subj_deref = HasVar(varsubtyp(subj->type, &subj_single)); - if (subj_single != NULL) { - /* - * The subject value is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(subj, &ignore); - new_subj = var_ref(subj_single); - - if (op_tok == AUGQMARK) { - body_deref = HasVar(varsubtyp(body->type, &body_single)); - if (body_single != NULL) - scan_rslt = &ignore; /* we know where the value will be */ - else - scan_rslt = chk_alc(NULL, n->intrnl_lftm); - } - else - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - else if (op_tok == AUGQMARK) { - /* - * Augmented string scanning using general assignment. The operands - * must be in consecutive locations. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn_var = tmp_loc(tmp_indx++); - scan_rslt = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - gencode(subj, asgn_var); - new_subj = chk_alc(NULL, n->intrnl_lftm); - deref_cd(asgn_var, new_subj); - } - else { - new_subj = gencode(subj, NULL); - if (subj_deref) - deref_cd(new_subj, new_subj); - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - - /* - * Produce code to save the old scanning environment. - */ - setloc(op); - save_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle failure of the body of string scanning. - */ - lbl = alc_lbl("scan fail", 0); - cd_add(lbl); - restr_env(scanp->outer_sub, scanp->outer_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* body goes before label */ - on_failure = lbl; - - /* - * If necessary, try to convert the subject to a string. Note that if - * error conversion occurs, backtracking will restore old subject. - */ - cur_symtyps = n->symtyps; - if (eval_is(str_typ, 0) & MaybeFalse) { - lbl = alc_lbl("&subject is string", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_str(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = new_subj; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &k_subject)"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(103, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = 1;"; - cd_add(cd); - - scan_rslt = gencode(body, scan_rslt); - - setloc(op); - if (op_tok == AUGQMARK) { - /* - * '?:=' - perform assignment. - */ - if (subj_single != NULL) { - /* - * Assignment to a named variable. - */ - if (body_single != NULL) - cd_add(mk_cpyval(new_subj, var_ref(body_single))); - else if (body_deref) - deref_cd(scan_rslt, new_subj); - else - cd_add(mk_cpyval(new_subj, scan_rslt)); - } - else { - /* - * Use general assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, asgn_var, 2, rslt,0); - } - } - } - else { - /* - * '?' - */ - rslt = scan_rslt; - } - - /* - * Produce code restore subject and pos when the body of the - * scanning expression succeeds. The new subject and pos must - * be saved in case of resumption. - */ - save_env(scanp->inner_sub, scanp->inner_pos); - restr_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle resumption of string scanning. - */ - lbl = alc_lbl("scan resume", 0); - cd_add(lbl); - save_env(scanp->outer_sub, scanp->outer_pos); - restr_env(scanp->inner_sub, scanp->inner_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* success continuation goes before label */ - on_failure = lbl; - - nxt_scan = scanp; - return rslt; - } - -/* - * gen_act - generate code for co-expression activation. - */ -static struct val_loc *gen_act(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *transmit; - struct node *coexpr; - struct tmplftm *lifetm_ary; - struct val_loc *trans_loc; - struct val_loc *coexpr_loc; - struct val_loc *asgn1; - struct val_loc *asgn2; - struct val_loc *act_rslt; - struct lentry *c_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int c_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node for '@' or '@:=' */ - transmit = Tree1(n); /* expression for value to transmit */ - coexpr = Tree2(n); /* expression for co-expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * Produce code for the value to be transmitted. - */ - if (op_tok == AUGAT) { - /* - * Augmented activation. This is seldom used so don't try too - * hard to optimize it. Allocate contiguous temporaries for - * the operands to the assignment. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn1 = tmp_loc(tmp_indx++); - asgn2 = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - /* - * Generate code to produce the left-hand-side of the assignment. - * This is also the transmitted value. Activation may need a - * dereferenced value, so this must be in a different location. - */ - gencode(transmit, asgn1); - trans_loc = chk_alc(NULL, n->intrnl_lftm); - setloc(op); - deref_ret(asgn1, trans_loc, varsubtyp(transmit->type, NULL)); - } - else - trans_loc = genretval(op, transmit, NULL); /* ordinary activation */ - - /* - * Determine if the value to be activated needs dereferencing, and - * see if it can only come from a single named variable. - */ - c_deref = HasVar(varsubtyp(coexpr->type, &c_single)); - if (c_single == NULL) { - /* - * The value is something other than a single named variable. - */ - coexpr_loc = gencode(coexpr, NULL); - if (c_deref) - deref_cd(coexpr_loc, coexpr_loc); - } - else { - /* - * The value is in a named variable. Use it directly from the - * variable rather than saving the result of the expression. - */ - gencode(coexpr, &ignore); - coexpr_loc = var_ref(c_single); - } - - /* - * Make sure the value to be activated is a co-expression. Perform - * run-time checking if necessary. - */ - cur_symtyps = n->symtyps; - if (eval_is(coexp_typ, 1) & MaybeFalse) { - lbl = alc_lbl("is co-expression", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = coexpr_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Coexpr"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(118, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = coexpr_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - /* - * Make sure a result location has been allocated. For ordinary - * activation, this is where activate() puts its result. For - * augmented activation, this is where assignment puts its result. - */ - rslt = chk_alc(rslt, n->lifetime); - if (op_tok == AUGAT) - act_rslt = asgn2; - else - act_rslt = rslt; - - /* - * Generate code to call activate(). - */ - setloc(n); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(7); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "activate(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = trans_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (struct b_coexpr *)BlkLoc("; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = coexpr_loc; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = "), &"; - cd1->ElemTyp(5) = A_ValLoc; - cd1->ValLoc(5) = act_rslt; - cd1->ElemTyp(6) = A_Str; - cd1->Str(6) = ") == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * For augmented activation, generate code to call assignment. - */ - if (op_tok == AUGAT) { - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, asgn1, 2, rslt, 0); - } - } - - return rslt; - } - -/* - * save_env - generate code to save scanning environment. - */ -static void save_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = sub_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_subject;"; - cd_add(cd); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = pos_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_pos;"; - cd_add(cd); - } - -/* - * restr_env - generate code to restore scanning environment. - */ -static void restr_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = sub_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = pos_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - -/* - * mk_callop - produce the code to directly call an operation. - */ -static void mk_callop(oper_nm, ret_flag, arg1rslt, nargs, rslt, optim) -char *oper_nm; -int ret_flag; -struct val_loc *arg1rslt; -int nargs; -struct val_loc *rslt; -int optim; - { - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - int n; - int need_cont; - - /* - * If this operation can return an "continue" signal, we will need - * a break statement in the signal switch to handle it. - */ - if (ret_flag & DoesRet) { - on_ret = NewCode(1); /* #fields == #fields C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - } - else - on_ret = NULL; - - /* - * Construct argument list for the C function implementing the - * operation. First compute the size of the code array for the - * argument list; this varies if we are using an optimized calling - * interface. - */ - if (optim) { - n = 0; - if (arg1rslt != NULL) - n += 2; - if (ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) - ++n; - n += 2; - } - } - else - n = 7; - if (n == 0) - arg_lst = NULL; - else { - arg_lst = alc_ary(n); - n = 0; - if (!optim) { - arg_lst->ElemTyp(n) = A_Intgr; /* number of arguments */ - arg_lst->Intgr(n) = nargs; - ++n; - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - if (arg1rslt == NULL) { /* location of first argument */ - if (!optim) { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "NULL"; - ++n; - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = ""; /* nothing, but must fill slot */ - ++n; - } - } - else { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = arg1rslt; - ++n; - } - if (!optim || ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) { - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - arg_lst->ElemTyp(n) = A_Str; /* location of result */ - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = rslt; - } - } - - /* - * Generate code to call the operation and handle returned signals. - */ - if (ret_flag & DoesSusp) { - /* - * The operation suspends, so call it with a continuation, then - * proceed to generate code in the continuation. - */ - fnc = alc_fnc(); - callo_add(oper_nm, ret_flag, fnc, 1, arg_lst, on_ret); - if (ret_flag & DoesRet) - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - } - else { - /* - * No continuation is needed, but if standard calling conventions - * are used, a NULL continuation argument is required. - */ - if (optim) - need_cont = 0; - else - need_cont = 1; - callo_add(oper_nm, ret_flag, NULL, need_cont, arg_lst, on_ret); - } -} - -/* - * genretval - generate code for the expression in a return/suspend or - * for the expression for the value to be transmitted in a co-expression - * context switch. - */ -static struct val_loc *genretval(n, expr, dest) -struct node *n; -struct node *expr; -struct val_loc *dest; - { - int subtypes; - struct lentry *single; - struct val_loc *val; - - subtypes = varsubtyp(expr->type, &single); - - /* - * If we have a single local or argument, we don't need to construct - * a variable reference; we need the value and we know where it is. - */ - if (single != NULL && (subtypes & (HasLcl | HasPrm))) { - gencode(expr, &ignore); - val = var_ref(single); - if (dest == NULL) - dest = val; - else - cd_add(mk_cpyval(dest, val)); - } - else { - dest = gencode(expr, dest); - setloc(n); - deref_ret(dest, dest, subtypes); - } - - return dest; - } - -/* - * deref_ret - produced dereferencing code for values returned from - * procedures or transmitted to co-expressions. - */ -static void deref_ret(src, dest, subtypes) -struct val_loc *src; -struct val_loc *dest; -int subtypes; - { - struct code *cd; - struct code *lbl; - - if (src == NULL) - return; /* no value to dereference */ - - /* - * If there may be values that do not need dereferencing, insure that the - * values are in the destination and make it the source of dereferencing. - */ - if ((subtypes & (HasVal | HasGlb)) && (src != dest)) { - cd_add(mk_cpyval(dest, src)); - src = dest; - } - - if (subtypes & (HasLcl | HasPrm)) { - /* - * Some values may need to be dereferenced. - */ - lbl = NULL; - if (subtypes & HasVal) { - /* - * We may have a non-variable and must check at run time. - */ - lbl = check_var(dest, NULL); - } - - if (subtypes & HasGlb) { - /* - * Make sure we don't dereference any globals, use retderef(). - */ - if (subtypes & HasLcl) { - /* - * We must dereference any locals. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = - ", (word *)pfp->tend.d, (word *)(pfp->tend.d + pfp->tend.num));"; - cd_add(cd); - /* - * We may now have a value. We must check at run-time and skip - * any attempt to dereference an argument. - */ - lbl = check_var(dest, lbl); - } - - if (subtypes & HasPrm) { - /* - * We must dereference any arguments. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", (word *)glbl_argp, (word *)(glbl_argp + "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = Abs(cur_proc->nargs); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - } - } - else /* No globals */ - deref_cd(src, dest); - - if (lbl != NULL) - cur_fnc->cursor = lbl; /* continue after label */ - } - } - -/* - * check_var - generate code to make sure a descriptor contains a variable - * reference. If no label is given to jump to for a non-variable, allocate - * one and generate code before it. - */ -static struct code *check_var(d, lbl) -struct val_loc *d; -struct code *lbl; - { - struct code *cd, *cd1; - - if (lbl == NULL) { - lbl = alc_lbl("not variable", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - } - - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!Var("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = d; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - - return lbl; - } - -/* - * field_ref - generate code for a field reference. - */ -static struct val_loc *field_ref(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *rec; - struct node *fld; - struct fentry *fp; - struct par_rec *rp; - struct val_loc *rec_loc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct lentry *single; - int deref; - int num_offsets; - int offset; - int bad_recs; - - rec = Tree0(n); - fld = Tree1(n); - - /* - * Generate code to compute the record value and dereference it. - */ - deref = HasVar(varsubtyp(rec->type, &single)); - if (single != NULL) { - /* - * The record is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(rec, &ignore); - rec_loc = var_ref(single); - } - else { - rec_loc = gencode(rec, NULL); - if (deref) - deref_cd(rec_loc, rec_loc); - } - - setloc(fld); - - /* - * Make sure the operand is a record. - */ - cur_symtyps = n->symtyps; - if (eval_is(rec_typ, 0) & MaybeFalse) { - lbl = alc_lbl("is record", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rec_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Record"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(107, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - rslt = chk_alc(rslt, n->lifetime); - - /* - * Find the list of records containing this field. - */ - if ((fp = flookup(Str0(fld))) == NULL) { - nfatal(n, "invalid field", Str0(fld)); - return rslt; - } - - /* - * Generate code for declarations and to get the record block pointer. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "{"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "struct b_record *r_rp = (struct b_record *) BlkLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "int r_must_fail = 0;"; - cd_add(cd); - } - - /* - * Determine which records are in the record type. - */ - mark_recs(fp, cur_symtyps->types[0], &num_offsets, &offset, &bad_recs); - - /* - * Generate code to insure that the field belongs to the record - * and to index into the record block. - */ - if (num_offsets == 1 && !bad_recs) { - /* - * We already know the offset of the field. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)&r_rp->fields["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = offset; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "] - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - for (rp = fp->rlist; rp != NULL; rp = rp->next) - rp->mark = 0; - } - else { - /* - * The field appears in several records. generate code to determine - * which one it is. - */ - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "dptr r_dp;"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "switch (r_rp->recdesc->proc.recnum) {"; - cd_add(cd); - - rp = fp->rlist; - while (rp != NULL) { - offset = rp->offset; - while (rp != NULL && rp->offset == offset) { - if (rp->mark) { - rp->mark = 0; - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " case "; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = rp->rec->rec_num; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ":"; - cd_add(cd); - } - rp = rp->next; - } - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_dp = &r_rp->fields["; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = offset; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "];"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " break;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " default:"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " err_msg(207, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - /* - * The peephole analyzer doesn't know how to handle a goto or return - * in a switch statement, so just set a flag here. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_must_fail = 1;"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " }"; - cd_add(cd); - if (err_conv) { - /* - * Now that we are out of the switch statement, see if the flag - * was set to indicate error conversion. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "r_must_fail"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)r_dp - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "}"; - cd_add(cd); - return rslt; - } - -/* - * bound - bound the code for the given sub-tree. If catch_fail is true, - * direct failure to the bounding label. - */ -static struct val_loc *bound(n, rslt, catch_fail) -struct node *n; -struct val_loc *rslt; -int catch_fail; - { - struct code *lbl1; - struct code *fail_sav; - struct c_fnc *fnc_sav; - - fnc_sav = cur_fnc; - fail_sav = on_failure; - - lbl1 = alc_lbl("bound", Bounding); - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - if (catch_fail) - on_failure = lbl1; - - rslt = gencode(n, rslt); - - cd_add(sig_cd(lbl1, cur_fnc)); /* transfer control to bounding label */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl1; - - on_failure = fail_sav; - return rslt; - } - -/* - * cd_add - add a code struct at the cursor in the current function. - */ -void cd_add(cd) -struct code *cd; - { - register struct code *cursor; - - cursor = cur_fnc->cursor; - - cd->next = cursor->next; - cd->prev = cursor; - if (cursor->next != NULL) - cursor->next->prev = cd; - cursor->next = cd; - cur_fnc->cursor = cd; - } - -/* - * sig_cd - convert a signal/label into a goto or return signal in - * the context of the given function. - */ -struct code *sig_cd(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct code *cd; - - if (sig->cd_id == C_Label && sig->Container == fnc) - return mk_goto(sig); - else { - cd = NewCode(1); /* # fields <= # fields of C_Goto */ - cd->cd_id = C_RetSig; - cd->next = NULL; - cd->prev = NULL; - cd->SigRef = add_sig(sig, fnc); - return cd; - } - } - -/* - * add_sig - add signal to list of signals returned by function. - */ -struct sig_lst *add_sig(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct sig_lst *sl; - - for (sl = fnc->sig_lst; sl != NULL && sl->sig != sig; sl = sl->next) - ; - if (sl == NULL) { - sl = NewStruct(sig_lst); - sl->sig = sig; - sl->ref_cnt = 1; - sl->next = fnc->sig_lst; - fnc->sig_lst = sl; - } - else - ++sl->ref_cnt; - return sl; - } - -/* - * callc_add - add code to call a continuation. Note the action to be - * taken if the continuation returns resumption. The actual list - * signals returned and actions to take will be figured out after - * the continuation has been optimized. - */ -void callc_add(cont) -struct c_fnc *cont; - { - struct code *cd; - - cd = new_call(); - cd->OperName = NULL; - cd->Cont = cont; - cd->ArgLst = NULL; - cd->ContFail = on_failure; - cd->SigActs = NULL; - ++cont->ref_cnt; - } - -/* - * callo_add - add code to call an operation. - */ -void callo_add(oper_nm, ret_flag, cont, need_cont, arglist, on_ret) -char *oper_nm; -int ret_flag; -struct c_fnc *cont; -int need_cont; -struct code *arglist; -struct code *on_ret; - { - struct code *cd; - struct code *cd1; - - cd = new_call(); - cd->OperName = oper_nm; - cd->Cont = cont; - if (need_cont) - cd->Flags = NeedCont; - cd->ArgLst = arglist; - cd->ContFail = NULL; /* operation handles failure from the continuation */ - /* - * Decide how to handle the signals produced by the operation. (Those - * produced by the continuation will be examined after the continuation - * is optimized.) - */ - cd->SigActs = NULL; - if (MightFail(ret_flag)) - cd->SigActs = new_sgact(&resume, sig_cd(on_failure,cur_fnc), cd->SigActs); - if (ret_flag & DoesRet) - cd->SigActs = new_sgact(&contin, on_ret, cd->SigActs); - if (ret_flag & DoesFThru) { - cd1 = NewCode(1); /* #fields == #fields C_Goto */ - cd1->cd_id = C_Break; - cd1->next = NULL; - cd1->prev = NULL; - cd->SigActs = new_sgact(&fallthru, cd1, cd->SigActs); - } - if (cont != NULL) - ++cont->ref_cnt; /* increment reference count */ -} - -/* - * Create a call, add it to the code for the current function, and - * add it to the list of calls from the current function. - */ -static struct code *new_call() - { - struct code *cd; - - cd = NewCode(7); - cd->cd_id = C_CallSig; - cd_add(cd); - cd->Flags = 0; - cd->NextCall = cur_fnc->call_lst; - cur_fnc->call_lst = cd; - return cd; - } - -/* - * sig_act - create a new binding of an action to a signal. - */ -struct sig_act *new_sgact(sig, cd, next) -struct code *sig; -struct code *cd; -struct sig_act *next; - { - struct sig_act *sa; - - sa = NewStruct(sig_act); - sa->sig = sig; - sa->cd = cd; - sa->shar_act = NULL; - sa->next = next; - return sa; - } - - -#ifdef OptimizeLit -static int instr(const char *str, int chr) { - int i, found, go; - - found = 0; go = 1; - for(i=0; ((str[i] != '\0') && go) ;i++) { - if (str[i] == chr) { - go = 0; - found = 1; - if ((str[i+1] != '\0') && (chr == '=')) - if (str[i+1] == '=') - found = 0; - if ((chr == '=') && (i > 0)) { - if (str[i-1] == '>') - found = 0; - else if (str[i-1] == '<') - found = 0; - else if (str[i-1] == '!') - found = 0; - } - } - } - return found; -} - -static void tbl_add(struct lit_tbl *add) { - struct lit_tbl *ins; - static struct lit_tbl *ptr = NULL; - int go = 1; - - if (tbl == NULL) { - tbl = add; - ptr = add; - } - else { - ins = ptr; - while ((ins != NULL) && go) { - if (add->index != ins->index) - ins = ins->prev; - else - go = 0; - } - if (ins != NULL) { - if (ins->end == NULL) - ins->end = add->initial; - } - ptr->next = add; - add->prev = ptr; - ptr = add; - } -} - - -static void invalidate(struct val_loc *val, struct code *end, int code) { - struct lit_tbl *ptr, *back; - int index, go = 1; - - if (val == NULL) - return; - if (val->loc_type == V_NamedVar) { - index = val->u.nvar->val.index; - return; - } - else if (val->loc_type == V_Temp) - index = val->u.tmp + cur_proc->tnd_loc; - else - return; - if (tbl == NULL) - return; - back = tbl; - while (back->next != NULL) - back = back->next; - go = 1; - for(ptr=back; ((ptr != NULL) && go) ; ptr=ptr->prev) { - if ((ptr->index == index) && (ptr->modified != NO_TOUCH)) { - ptr->modified = code; - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if ((ptr->index == index) && (ptr->modified == NO_TOUCH)) { - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if (ptr->index == index) - go = 0; - } -} - - -static int eval_code(struct code *cd, struct lit_tbl *cur) { - struct code *tmp; - struct lit_tbl *tmp_tbl; - int i, j; - char *str; - - for (i=0; cd->ElemTyp(i) != A_End ;i++) { - switch(cd->ElemTyp(i)) { - case A_ValLoc: - if (cd->ValLoc(i)->mod_access != M_CInt) - break; - if ((cd->ValLoc(i)->u.tmp + cur_proc->tnd_loc) == cur->index) { - switch (cd->ValLoc(i)->loc_type) { - case V_Temp: - if (cur->csym->flag == F_StrLit) { -#if 0 - cd->ElemTyp(i) = A_Str; - str = (char *)alloc(strlen(cur->csym->image)+8); - sprintf(str, "\"%s\"/*Z*/", cur->csym->image); - cd->Str(i) = str; -#endif - } - else if (cur->csym->flag == F_IntLit) { - cd->ElemTyp(i) = A_Str; - cd->Str(i) = cur->csym->image; - } - break; - default: - break; - } - } - break; - case A_Ary: - for(tmp=cd->Array(i); tmp != NULL ;tmp=tmp->next) - eval_code(tmp, cur); - break; - default: - break; - } - } -} - -static void propagate_literals() { - struct lit_tbl *ptr; - struct code *cd, *arg; - int ret; - - for(ptr=tbl; ptr != NULL ;ptr=ptr->next) { - if (ptr->modified != NO_TOUCH) { - for(cd=ptr->initial; cd != ptr->end ;cd=cd->next) { - switch (cd->cd_id) { - case C_If: - for(arg=cd->Cond; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - /* - * Again, don't take the 'then' portion. - * It might lead to infinite loops. - * for(arg=cd->ThenStmt; arg != NULL ;arg=arg->next) - * ret = eval_code(arg, ptr); - */ - break; - case C_CdAry: - ret = eval_code(cd, ptr); - break; - case C_CallSig: - for(arg=cd->ArgLst; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - break; - default: - break; - } - } - } - } -} - -/* - * analyze_literals - analyzes the generated code to replace - * complex record dereferences with C - * literals. - */ -static void analyze_literals(struct code *start, struct code *top, int lvl) { - struct code *ptr, *tmp, *not_null; - struct lit_tbl *new_tbl; - struct lbl_tbl *new_lbl; - struct val_loc *prev = NULL; - int i, inc=0, addr=0, assgn=0, equal = 0; - - for (ptr = start; ptr != NULL ; ptr = ptr->next) { - if (!lvl) - not_null = ptr; - else - not_null = top; - switch (ptr->cd_id) { - case C_NamedVar: - break; - case C_CallSig: - analyze_literals(ptr->ArgLst, not_null, lvl+1); - break; - case C_Goto: - break; - case C_Label: - break; - case C_Lit: - new_tbl = alc_tbl(); - new_tbl->initial = ptr; - new_tbl->vloc = ptr->Rslt; - new_tbl->csym = ptr->Literal; - switch (ptr->Rslt->loc_type) { - case V_NamedVar: - new_tbl->index = ptr->Rslt->u.nvar->val.index; - tbl_add(new_tbl); - break; - case V_Temp: - new_tbl->index = ptr->Rslt->u.tmp + cur_proc->tnd_loc; - tbl_add(new_tbl); - break; - default: - new_tbl->index = -1; - free(new_tbl); - break; - } - break; - case C_If: - analyze_literals(ptr->Cond, not_null, lvl+1); - /* - * Don't analyze the 'then' portion such as in: - * analyze_literals(ptr->ThenStmt, not_null, lvl+1); - * Apparently, all the intermediate code does is maintain - * a pointer to where the flow of execution jumps to in - * case the 'then' is taken. These are all goto statments - * and can result in infinite loops of analyzation. - */ - break; - case C_CdAry: - for(i=0; ptr->ElemTyp(i) != A_End ;i++) { - switch(ptr->ElemTyp(i)) { - case A_Str: - if (ptr->Str(i) != NULL) { - if ( (strstr(ptr->Str(i), "-=")) || - (strstr(ptr->Str(i), "+=")) || - (strstr(ptr->Str(i), "*=")) || - (strstr(ptr->Str(i), "/=")) ) - invalidate(prev, not_null, NO_TOUCH); - else if (instr(ptr->Str(i), '=')) { - invalidate(prev, not_null, LIMITED); - assgn = 1; - } - else if ( (strstr(ptr->Str(i), "++")) || - (strstr(ptr->Str(i), "--")) ) - inc = 1; - else if (instr(ptr->Str(i), '&')) - addr = 1; - else if (strstr(ptr->Str(i), "==")) - equal = 1; - } - break; - case A_ValLoc: - if (inc) { - invalidate(ptr->ValLoc(i), not_null, NO_TOUCH); - inc = 0; - } - if (addr) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - addr = 0; - } - if ((assgn) && (ptr->ValLoc(i)->mod_access == M_None)) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - assgn = 0; - } - else if (assgn) - assgn = 0; - if (equal) { - invalidate(ptr->ValLoc(i), not_null, LIMITED_TO_INT); - equal = 0; - } - prev = ptr->ValLoc(i); - break; - case A_Intgr: - break; - case A_SBuf: - break; - case A_Ary: - for(tmp=ptr->Array(i); tmp != NULL ;tmp=tmp->next) - analyze_literals(tmp, not_null, lvl+1); - break; - default: - break; - } - } - break; - default: - break; - } - } -} -#endif /* OptimizeLit */ - -/* - * analyze_poll - analyzes the internal C code representation from - * the position of the last Poll() function call to - * the current position in the code. - * Returns a 0 if the last Poll() function should not - * be removed. - */ -#ifdef OptimizePoll -static int analyze_poll(void) { - struct code *cursor, *ptr; - int cont = 1; - - ptr = lastpoll; - if (ptr == NULL) - return 0; - cursor = cur_fnc->cursor; - while ((cursor != ptr) && (ptr != NULL) && (cont)) { - switch (ptr->cd_id) { - case C_Null : - case C_NamedVar : - case C_Label : - case C_Lit : - case C_Resume : - case C_Continue : - case C_FallThru : - case C_PFail : - case C_Goto : - case C_Create : - case C_If : - case C_SrcLoc : - case C_CdAry : - break; - case C_CallSig : - case C_RetSig : - case C_LBrack : - case C_RBrack : - case C_PRet : - case C_PSusp : - case C_Break : - cont = 0; - break; - } - ptr = ptr->next; - } - return cont; -} - -/* - * remove_poll - removes the ccode structure that represents the last - * call to the "Poll()" function by simply changing the code ID to - * C_Null code. - */ -static void remove_poll(void) { - - if (lastpoll == NULL) - return; - lastpoll->cd_id = C_Null; -} -#endif /* OptimizePoll */ - -/* - * setloc produces code to set the file name and line number to the - * source location of node n. Code is only produced if the corresponding - * value has changed since the last time setloc was called. - */ -static void setloc(n) -nodeptr n; - { - struct code *cd; - static int count=0; - - if (n == NULL || File(n) == NULL || Line(n) == 0) - return; - - if (File(n) != lastfiln || Line(n) != lastline) { -#ifdef OptimizePoll - if (analyze_poll()) - remove_poll(); - cd = alc_ary(1); - lastpoll = cd; -#else /* OptimizePoll */ - cd = alc_ary(1); -#endif /* OptimizePoll */ - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "Poll();"; - cd_add(cd); - - if (line_info) { - cd = NewCode(2); - cd->cd_id = C_SrcLoc; - - if (File(n) == lastfiln) - cd->FileName = NULL; - else { - lastfiln = File(n); - cd->FileName = lastfiln; - } - - if (Line(n) == lastline) - cd->LineNum = 0; - else { - lastline = Line(n); - cd->LineNum = lastline; - } - - cd_add(cd); - } - } - } - -/* - * alc_ary - create an array for a sequence of code fragments. - */ -struct code *alc_ary(n) -int n; - { - struct code *cd; - static cnt=1; - - cd = NewCode(2 * n + 1); - cd->cd_id = C_CdAry; - cd->next = NULL; - cd->prev = NULL; - cd->ElemTyp(n) = A_End; - return cd; - } - - -/* - * alc_lbl - create a label. - */ -struct code *alc_lbl(desc, flag) -char *desc; -int flag; - { - register struct code *cd; - - cd = NewCode(5); - cd->cd_id = C_Label; - cd->next = NULL; - cd->prev = NULL; - cd->Container = cur_fnc; /* function containing label */ - cd->SeqNum = 0; /* sequence number is allocated later */ - cd->Desc = desc; /* identifying comment */ - cd->RefCnt = 0; /* reference count */ - cd->LabFlg = flag; - return cd; - } - -/* - * alc_fnc - allocate a function structure; - */ -static struct c_fnc *alc_fnc() - { - register struct c_fnc *cf; - int i; - - cf = NewStruct(c_fnc); - cf->prefix[0] = '\0'; /* prefix is allocated later */ - cf->prefix[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->flag = 0; - for (i = 0; i < PrfxSz; ++i) - cf->frm_prfx[i] = frm_prfx[i]; /* note procedure frame prefix */ - cf->frm_prfx[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->cd.cd_id = C_Null; /* base of code sequence in function */ - cf->cd.next = NULL; - cf->cursor = &cf->cd; /* current place to insert code */ - cf->call_lst = NULL; /* functions called by this function */ - cf->creatlst = NULL; /* creates within this function */ - cf->sig_lst = NULL; /* signals returned by this function */ - cf->ref_cnt = 0; - cf->next = NULL; - *flst_end = cf; /* link entry onto global list */ - flst_end = &(cf->next); - return cf; - } - -/* - * tmp_loc - allocate a value location structure for nth temporary descriptor - * variable in procedure frame. - */ -static struct val_loc *tmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Temp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * itmp_loc - allocate a value location structure for nth temporary integer - * variable in procedure frame. - */ -struct val_loc *itmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_ITemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * dtmp_loc - allocate a value location structure for nth temporary double - * variable in procedure frame. - */ -struct val_loc *dtmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_DTemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * vararg_sz - allocate a value location structure that refers to the size - * of the variable part of an argument list. - */ -static struct val_loc *vararg_sz(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Const; - r->mod_access = M_None; - r->u.int_const = n; - return r; - } - -/* - * cvar_loc - allocate a value location structure for a C variable. - */ -struct val_loc *cvar_loc(name) -char *name; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_CVar; - r->mod_access = M_None; - r->u.name = name; - return r; - } - -/* - * var_ref - allocate a value location structure for an Icon named variable. - */ -static struct val_loc *var_ref(sym) -struct lentry *sym; - { - struct val_loc *loc; - - loc = NewStruct(val_loc); - loc->loc_type = V_NamedVar; - loc->mod_access = M_None; - loc->u.nvar = sym; - return loc; - } - -/* - * deref_cd - generate code to dereference a descriptor. - */ -static void deref_cd(src, dest) -struct val_loc *src; -struct val_loc *dest; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "deref(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = src; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &"; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = dest; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - } - -/* - * inv_op - directly invoke a run-time operation, in-lining it if possible. - */ -static struct val_loc *inv_op(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct implement *impl; - struct code *scont_strt; - struct code *scont_fail; - struct c_fnc *fnc; - struct val_loc *frst_arg; - struct val_loc *arg_rslt; - struct val_loc *r; - struct val_loc **varg_rslt; - struct op_symentry *symtab; - struct lentry **single; - struct tmplftm *lifetm_ary; - nodeptr rslt_lftm; - char *sbuf; - int *maybe_var; - int may_mod; - int nsyms; - int nargs; - int nparms; - int cont_loc; - int flag; - int refs; - int var_args; - int n_varargs; - int arg_loc; - int dcl_var; - int i; - int j; - int v; - - nargs = Val0(n); - impl = Impl1(n); - if (impl == NULL) { - /* - * We have already printed an error, just make sure we can - * continue. - */ - return &ignore; - } - - /* - * If this operation uses its result location as a work area, it must - * be given a tended result location and the value must be retained - * as long as the operation can be resumed. - */ - rslt_lftm = n->lifetime; - if (impl->use_rslt) { - rslt_lftm = max_lftm(rslt_lftm, n->intrnl_lftm); - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - } - - /* - * Determine if this operation takes a variable number of arguments - * and determine the size of the variable part of the arg list. - */ - nparms = impl->nargs; - if (nparms > 0 && impl->arg_flgs[nparms - 1] & VarPrm) { - var_args = 1; - n_varargs = nargs - nparms + 1; - if (n_varargs < 0) - n_varargs = 0; - } - else { - var_args = 0; - n_varargs = 0; - } - - /* - * Construct a symbol table (implemented as an array) for the operation. - * The symbol table includes parameters, and both the tended and - * ordinary variables from the RTL declare statement. - */ - nsyms = (n->symtyps == NULL ? 0 : n->symtyps->nsyms); - if (var_args) - ++nsyms; - nsyms += impl->ntnds + impl->nvars; - if (nsyms > 0) - symtab = (struct op_symentry *)alloc((unsigned int)(nsyms * - sizeof(struct op_symentry))); - else - symtab = NULL; - for (i = 0; i < nsyms; ++i) { - symtab[i].n_refs = 0; /* number of non-modifying references */ - symtab[i].n_mods = 0; /* number of modifying references */ - symtab[i].n_rets = 0; /* number of times returned directly */ - symtab[i].var_safe = 0; /* Icon variable arg can be passed directly */ - symtab[i].adjust = 0; /* adjustments needed to "dereference" */ - symtab[i].itmp_indx = -1; /* loc after "in-place" convert to C integer */ - symtab[i].dtmp_indx = -1; /* loc after "in-place" convert to C double */ - symtab[i].loc = NULL; /* location as a descriptor */ - } - - /* - * If in-lining has not been disabled or the operation is a keyword, - * check to see if it can reasonably be in-lined and gather information - * needed to in-line it. - */ - if ((allow_inline || impl->oper_typ == 'K') && - do_inlin(impl, n, &cont_loc, symtab, n_varargs)) { - /* - * In-line the operation. - */ - - if (impl->ret_flag & DoesRet || impl->ret_flag & DoesSusp) - rslt = chk_alc(rslt, rslt_lftm); /* operation produces a result */ - - /* - * Allocate arrays to hold information from type inferencing about - * whether arguments are variables. This is used to optimize - * dereferencing. - */ - if (nargs > 0) { - maybe_var = (int *)alloc((unsigned int)(nargs * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nargs * - sizeof(struct lentry *))); - } - - if (var_args) - --nparms; /* don't deal with varargs parameter yet. */ - - /* - * Match arguments with parameters and generate code for the - * arguments. The type of code generated depends on the kinds - * of dereferencing optimizations that are possible, though - * in general, dereferencing must wait until all arguments are - * computed. Because there may be both dereferenced and undereferenced - * parameters for an argument, the symbol table index does not always - * match the argument index. - */ - i = 0; /* symbol table index */ - for (j = 0; j < nparms && j < nargs; ++j) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j] = HasVar(varsubtyp(n->n_field[FrstArg + j].n_ptr->type, - &(single[j]))); - - /* - * Determine how many times the argument is referenced. If we - * optimize away return statements because we don't need the - * result, those references don't count. Take into account - * that there may be both dereferenced and undereferenced - * parameters for this argument. - */ - if (rslt == &ignore) - symtab[i].n_refs -= symtab[i].n_rets; - refs = symtab[i].n_refs + symtab[i].n_mods; - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - if (flag == (RtParm | DrfPrm)) - refs += symtab[i + 1].n_refs + symtab[i + 1].n_mods; - if (refs == 0) { - /* - * Indicate that we don't need the argument value (we must - * still perform the computation in case it has side effects). - */ - arg_rslt = &ignore; - symtab[i].adjust = AdjNone; - } - else { - /* - * Decide whether the result location for the argument can be - * used directly as the parameter. - */ - if (flag == (RtParm | DrfPrm) && symtab[i].n_refs + - symtab[i].n_mods == 0) { - /* - * We have both dereferenced and undereferenced parameters, - * but don't use the undereferenced one so ignore it. - */ - symtab[i].adjust = AdjNone; - ++i; - flag = DrfPrm; - } - if (flag == DrfPrm && single[j] != NULL) { - /* - * We need only a dereferenced value, but know what variable - * it is in. We don't need the computed argument value, we will - * get it directly from the variable. If it is safe to do - * so, we will pass a pointer to the variable as the argument - * to the operation. - */ - arg_rslt = &ignore; - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * Determine if the argument descriptor is modified by the - * operation; dereferencing a variable is a modification. - */ - may_mod = (symtab[i].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j]; - if (n->n_field[FrstArg + j].n_ptr->reuse && may_mod) { - /* - * The parameter may be reused without recomputing - * the argument and the value may be modified. The - * argument result location and the parameter location - * must be separate so the parameter is reloaded upon - * each invocation. - */ - arg_rslt = chk_alc(NULL, - n->n_field[FrstArg + j].n_ptr->lifetime); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjNDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjCpy; /* value only: just copy */ - } - else { - /* - * Argument result location will act as parameter location. - * Its lifetime must be as long as both that of the - * the argument and the parameter (operation internal - * lifetime). - */ - arg_rslt = chk_alc(NULL, max_lftm(n->intrnl_lftm, - n->n_field[FrstArg + j].n_ptr->lifetime)); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjNone; - } - symtab[i].loc = arg_rslt; - } - } - - /* - * Generate the code for the argument. - */ - gencode(n->n_field[FrstArg + j].n_ptr, arg_rslt); - - if (flag == (RtParm | DrfPrm)) { - /* - * We have computed the value for the undereferenced parameter, - * decide how to get the dereferenced value. - */ - ++i; - if (symtab[i].n_refs + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; /* not needed, ignore */ - else { - if (single[j] != NULL) { - /* - * The value is in a specific Icon variable, get it from - * there. If is is safe to pass the variable directly - * to the operation, do so. - */ - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * If there might be a variable reference, note that it - * must be dereferenced. Otherwise decide whether the - * argument location can be used for both the dereferenced - * and undereferenced parameter. - */ - symtab[i].loc = arg_rslt; - if (maybe_var[j]) - symtab[i].adjust = AdjNDrf; - else if (symtab[i - 1].n_mods + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - } - } - ++i; - } - - /* - * Fill out parameter list with null values. - */ - while (j < nparms) { - int k, kn; - kn = 0; - if (impl->arg_flgs[j] & RtParm) - ++kn; - if (impl->arg_flgs[j] & DrfPrm) - ++kn; - for (k = 0; k < kn; ++k) { - if (symtab[i].n_refs + symtab[i].n_mods > 0) { - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(asgn_null(arg_rslt)); - symtab[i].loc = arg_rslt; - } - symtab[i].adjust = AdjNone; - ++i; - } - ++j; - } - - if (var_args) { - /* - * Compute variable part of argument list. - */ - ++nparms; /* add varargs parameter back into parameter list */ - - /* - * The variable part of the parameter list must be in contiguous - * descriptors. Create location and lifetime arrays for use in - * allocating the descriptors. - */ - if (n_varargs > 0) { - varg_rslt = (struct val_loc **)alloc((unsigned int)(n_varargs * - sizeof(struct val_loc *))); - lifetm_ary = alc_lftm(n_varargs, NULL); - } - - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - - /* - * Compute the lifetime of the elements of the varargs parameter array. - */ - for (v = 0; v < n_varargs; ++v) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j + v] = HasVar(varsubtyp( - n->n_field[FrstArg+j+v].n_ptr->type, &(single[j + v]))); - - /* - * Determine if the elements of the vararg parameter array - * might be modified. If it is a variable, dereferencing - * modifies it. - */ - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - - if ((flag == DrfPrm && single[j + v] != NULL) || - (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod)) { - /* - * The argument value is only placed in the vararg parameter - * array during "dereferencing". So the lifetime of the array - * element is the lifetime of the parameter and the element - * is not used until dereferencing. - */ - lifetm_ary[v].lifetime = n->intrnl_lftm; - lifetm_ary[v].cur_status = n->postn; - } - else { - /* - * The argument is computed into the vararg parameter array. - * The lifetime of the array element encompasses both - * the lifetime of the argument and the parameter. The - * element is used as soon as the argument is computed. - */ - lifetm_ary[v].lifetime = max_lftm(n->intrnl_lftm, - n->n_field[FrstArg+j+v].n_ptr->lifetime); - lifetm_ary[v].cur_status = n->n_field[FrstArg+j+v].n_ptr->postn; - } - } - - /* - * Allocate (reserve) the array of temporary variables for the - * vararg list. - */ - if (n_varargs > 0) { - arg_loc = alc_tmp(n_varargs, lifetm_ary); - free((char *)lifetm_ary); - } - - /* - * Generate code to compute arguments. - */ - for (v = 0; v < n_varargs; ++v) { - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * We need a dereferenced value and it is in a known place: a - * named variable; don't bother saving the result of the - * argument computation. - */ - r = &ignore; - } - else if (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod) { - /* - * The argument can be reused without being recomputed and - * the parameter may be modified, so we cannot safely - * compute the argument into the vararg parameter array; we - * must compute it elsewhere and copy (dereference) it at the - * beginning of the operation. Let gencode allocate an argument - * result location. - */ - r = NULL; - } - else { - /* - * We can compute the argument directly into the vararg - * parameter array. - */ - r = tmp_loc(arg_loc + v); - } - varg_rslt[v] = gencode(n->n_field[FrstArg + j + v].n_ptr, r); - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in vararg - * parameter list. Preceding arguments are dereferenced later, but - * it is okay if dereferencing is out-of-order. - */ - for (v = 0; v < n_varargs; ++v) { - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * Copy the value from the known named variable into the - * parameter list. - */ - varg_rslt[v] = var_ref(single[j + v]); - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - else if (flag == DrfPrm && maybe_var[j + v]) { - /* - * Dereference the argument into the parameter list. - */ - deref_cd(varg_rslt[v], tmp_loc(arg_loc + v)); - } - else if (arg_loc + v != varg_rslt[v]->u.tmp) { - /* - * The argument is a dereferenced value, but is not yet - * in the parameter list; copy it there. - */ - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - tmp_status[arg_loc + v] = InUse; /* parameter location in use */ - } - - /* - * The vararg parameter gets the address of the first element - * in the variable part of the argument list and the size - * parameter gets the number of elements in the list. - */ - if (n_varargs > 0) { - free((char *)varg_rslt); - symtab[i].loc = tmp_loc(arg_loc); - } - else - symtab[i].loc = chk_alc(NULL, n); /* dummy arg location */ - symtab[i].loc->mod_access = M_Addr; - ++i; - symtab[i].loc = vararg_sz(n_varargs); - ++i; - } - else { - /* - * Compute extra arguments, but discard the results. - */ - while (j < nargs) { - gencode(n->n_field[FrstArg + j].n_ptr, &ignore); - ++j; - } - } - - if (nargs > 0) { - free((char *)maybe_var); - free((char *)single); - } - - /* - * If execution does not continue through the parameter evaluation, - * don't try to generate in-line code. A lack of parameter types - * will cause problems with some in-line type conversions. - */ - if (!past_prms(n)) - return rslt; - - setloc(n); - - dcl_var = i; - - /* - * Perform any needed copying or dereferencing. - */ - for (i = 0; i < nsyms; ++i) { - switch (symtab[i].adjust) { - case AdjNDrf: - /* - * Dereference into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - deref_cd(symtab[i].loc, arg_rslt); - symtab[i].loc = arg_rslt; - break; - case AdjDrf: - /* - * Dereference in place. - */ - deref_cd(symtab[i].loc, symtab[i].loc); - break; - case AdjCpy: - /* - * Copy into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(mk_cpyval(arg_rslt, symtab[i].loc)); - symtab[i].loc = arg_rslt; - break; - case AdjNone: - break; /* nothing need be done */ - } - } - - switch (cont_loc) { - case SepFnc: - /* - * success continuation must be in a separate function. - */ - fnc = alc_fnc(); - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put oper before label */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, fnc, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - break; - case SContIL: - /* - * one suspend an no return: success continuation is put in-line. - */ - gen_inlin(impl->in_line, rslt, &scont_strt, &scont_fail, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - on_failure = scont_fail; - break; - case EndOper: - /* - * no suspends: success continuation goes at end of operation. - */ - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put operation before lbl */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - break; - } - } - else { - /* - * Do not in-line operation. - */ - implproto(impl); - frst_arg = gen_args(n, 2, nargs); - setloc(n); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, rslt_lftm); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, nargs, rslt, - 0); - } - if (symtab != NULL) - free((char *)symtab); - return rslt; - } - -/* - * max_lftm - given two lifetimes (in the form of nodes) return the - * maximum one. - */ -static nodeptr max_lftm(n1, n2) -nodeptr n1; -nodeptr n2; - { - if (n1 == NULL) - return n2; - else if (n2 == NULL) - return n1; - else if (n1->postn > n2->postn) - return n1; - else - return n2; - } - -/* - * inv_prc - directly invoke a procedure. - */ -static struct val_loc *inv_prc(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct pentry *proc; - struct val_loc *r; - struct val_loc *arg1rslt; - struct val_loc *var_part; - int *must_deref; - struct lentry **single; - struct val_loc **arg_rslt; - struct code *cd; - struct tmplftm *lifetm_ary; - char *sbuf; - int nargs; - int nparms; - int i, j; - int arg_loc; - int var_sz; - int var_loc; - - /* - * This procedure is implemented without argument list adjustment or - * dereferencing, so they must be done before the call. - */ - nargs = Val0(n); /* number of arguments */ - proc = Proc1(n); - nparms = Abs(proc->nargs); - - if (nparms > 0) { - must_deref = (int *)alloc((unsigned int)(nparms * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nparms * - sizeof(struct lentry *))); - arg_rslt = (struct val_loc **)alloc((unsigned int)(nparms * - sizeof(struct val_loc *))); - } - - /* - * Allocate a work area of temporaries to use as argument list. If - * an argument can be reused without being recomputed, it must not - * be computed directly into the work area. It will be copied or - * dereferenced into the work area when execution reaches the - * operation. If an argument is a single named variable, it can - * be dereferenced directly into the argument location. These - * conditions affect when the temporary will receive a value. - */ - if (nparms > 0) - lifetm_ary = alc_lftm(nparms, NULL); - for (i = 0; i < nparms; ++i) - lifetm_ary[i].lifetime = n->intrnl_lftm; - for (i = 0; i < nparms && i < nargs; ++i) { - must_deref[i] = HasVar(varsubtyp(n->n_field[FrstArg + i].n_ptr->type, - &(single[i]))); - if (single[i] != NULL || n->n_field[FrstArg + i].n_ptr->reuse) - lifetm_ary[i].cur_status = n->postn; - else - lifetm_ary[i].cur_status = n->n_field[FrstArg + i].n_ptr->postn; - } - while (i < nparms) { - lifetm_ary[i].cur_status = n->postn; /* arg list extension */ - ++i; - } - if (proc->nargs < 0) - lifetm_ary[nparms - 1].cur_status = n->postn; /* variable part */ - - if (nparms > 0) { - arg_loc = alc_tmp(nparms, lifetm_ary); - free((char *)lifetm_ary); - } - if (proc->nargs < 0) - --nparms; /* treat variable part specially */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (single[i] != NULL) - r = &ignore; /* we know where the dereferenced value is */ - else if (n->n_field[FrstArg + i].n_ptr->reuse) - r = NULL; /* let gencode allocate a new temporary */ - else - r = tmp_loc(arg_loc + i); - arg_rslt[i] = gencode(n->n_field[FrstArg + i].n_ptr, r); - } - - /* - * If necessary, fill out argument list with nulls. - */ - while (i < nparms) { - cd_add(asgn_null(tmp_loc(arg_loc + i))); - tmp_status[arg_loc + i] = InUse; - ++i; - } - - if (proc->nargs < 0) { - /* - * handle variable part of list. - */ - var_sz = nargs - nparms; - - if (var_sz > 0) { - lifetm_ary = alc_lftm(var_sz, &n->n_field[FrstArg + nparms]); - var_loc = alc_tmp(var_sz, lifetm_ary); - free((char *)lifetm_ary); - for (j = 0; j < var_sz; ++j) { - gencode(n->n_field[FrstArg + nparms + j].n_ptr, - tmp_loc(var_loc + j)); - } - } - } - else { - /* - * If there are extra arguments, compute them, but discard the - * results. - */ - while (i < nargs) { - gencode(n->n_field[FrstArg + i].n_ptr, &ignore); - ++i; - } - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in argument - * list as dereferenced values. - */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (must_deref[i]) { - if (single[i] == NULL) { - deref_cd(arg_rslt[i], tmp_loc(arg_loc + i)); - } - else { - arg_rslt[i] = var_ref(single[i]); - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - } - } - else if (n->n_field[FrstArg + i].n_ptr->reuse) - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - tmp_status[arg_loc + i] = InUse; - } - - if (proc->nargs < 0) { - var_part = tmp_loc(arg_loc + nparms); - tmp_status[arg_loc + nparms] = InUse; - if (var_sz <= 0) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(NULL, 0, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = var_part; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - } - else { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = tmp_loc(var_loc); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = var_sz; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", &"; - cd->ElemTyp(5) = A_ValLoc; - cd->ValLoc(5) = var_part; - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ");"; - } - cd_add(cd); - ++nparms; /* include variable part in call */ - } - - if (nparms > 0) { - free((char *)must_deref); - free((char *)single); - free((char *)arg_rslt); - } - - sbuf = (char *)alloc((unsigned int)(strlen(proc->name) + PrfxSz + 3)); - sprintf(sbuf, "P%s_%s", proc->prefix, proc->name); - if (nparms > 0) - arg1rslt = tmp_loc(arg_loc); - else - arg1rslt = NULL; - if (proc->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(sbuf, proc->ret_flag, arg1rslt, nargs, rslt, 1); - return rslt; - } - -/* - * endlife - link a temporary variable onto the list to be freed when - * execution reaches a node. - */ -static void endlife(kind, indx, old, n) -int kind; -int indx; -int old; -nodeptr n; - { - struct freetmp *freetmp; - - if ((freetmp = freetmp_pool) == NULL) - freetmp = NewStruct(freetmp); - else - freetmp_pool = freetmp_pool->next; - freetmp->kind = kind; - freetmp->indx = indx; - freetmp->old = old; - freetmp->next = n->freetmp; - n->freetmp = freetmp; - } - -/* - * alc_tmp - allocate a block of temporary variables with the given lifetimes. - */ -static int alc_tmp(num, lifetm_ary) -int num; -struct tmplftm *lifetm_ary; - { - int i, j, k; - register int status; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > status_sz) { - /* - * The status array is too small, expand it. - */ - new_size = status_sz + Max(num, status_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < status_sz) { - new_status[k] = tmp_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)tmp_status); - tmp_status = new_status; - status_sz = new_size; - } - for (j = 0; j < num; ++j) { - status = tmp_status[i + j]; - if (status != NotAlloc && - (status == InUse || status <= lifetm_ary[j].lifetime->postn)) - break; - } - /* - * Did we find a block of temporaries that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(DescTmp, i + j, tmp_status[i + j], lifetm_ary[j].lifetime); - tmp_status[i + j] = lifetm_ary[j].cur_status; - } - if (i + num > num_tmp) - num_tmp = i + num; - return i; - } - ++i; - } - } - -/* - * alc_lftm - allocate an array of lifetime information for an argument - * list. - */ -static struct tmplftm *alc_lftm(num, args) -int num; -union field *args; - { - struct tmplftm *lifetm_ary; - int i; - - lifetm_ary = (struct tmplftm *)alloc((unsigned int)(num * - sizeof(struct tmplftm))); - if (args != NULL) - for (i = 0; i < num; ++i) { - lifetm_ary[i].cur_status = args[i].n_ptr->postn; /* reserved for arg */ - lifetm_ary[i].lifetime = args[i].n_ptr->lifetime; - } - return lifetm_ary; - } - -/* - * alc_itmp - allocate a temporary C integer variable. - */ -int alc_itmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < istatus_sz && itmp_status[i] == InUse) - ++i; - if (i >= istatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)itmp_status); - new_size = istatus_sz * 2; - itmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < istatus_sz) - itmp_status[j++] = InUse; - while (j < new_size) - itmp_status[j++] = NotAlloc; - istatus_sz = new_size; - } - endlife(CIntTmp, i, NotAlloc, lifetime); - itmp_status[i] = InUse; - if (num_itmp < i + 1) - num_itmp = i + 1; - return i; - } - -/* - * alc_dtmp - allocate a temporary C integer variable. - */ -int alc_dtmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < dstatus_sz && dtmp_status[i] == InUse) - ++i; - if (i >= dstatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)dtmp_status); - new_size = dstatus_sz * 2; - dtmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < dstatus_sz) - dtmp_status[j++] = InUse; - while (j < new_size) - dtmp_status[j++] = NotAlloc; - dstatus_sz = new_size; - } - endlife(CDblTmp, i, NotAlloc, lifetime); - dtmp_status[i] = InUse; - if (num_dtmp < i + 1) - num_dtmp = i + 1; - return i; - } - -/* - * alc_sbufs - allocate a block of string buffers with the given lifetime. - */ -int alc_sbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > sstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = sstatus_sz + Max(num, sstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < sstatus_sz) { - new_status[k] = sbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)sbuf_status); - sbuf_status = new_status; - sstatus_sz = new_size; - } - for (j = 0; j < num && sbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(SBuf, i + j, sbuf_status[i + j], lifetime); - sbuf_status[i + j] = InUse; - } - if (i + num > num_sbuf) - num_sbuf = i + num; - return i; - } - ++i; - } - } - -/* - * alc_cbufs - allocate a block of cset buffers with the given lifetime. - */ -int alc_cbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > cstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = cstatus_sz + Max(num, cstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < cstatus_sz) { - new_status[k] = cbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)cbuf_status); - cbuf_status = new_status; - cstatus_sz = new_size; - } - for (j = 0; j < num && cbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(CBuf, i + j, cbuf_status[i + j], lifetime); - cbuf_status[i + j] = InUse; - } - if (i + num > num_cbuf) - num_cbuf = i + num; - return i; - } - ++i; - } - } diff --git a/src/iconc/ccode.h b/src/iconc/ccode.h deleted file mode 100644 index 2d0cb6f..0000000 --- a/src/iconc/ccode.h +++ /dev/null @@ -1,252 +0,0 @@ -/* - * ccode.h - definitions used in code generation. - */ - -/* - * ChkPrefix - allocate a prefix to x if it has not already been done. - */ -#define ChkPrefix(x) if ((x)[0] == '\0') nxt_pre(x, pre, PrfxSz); - -/* - * sig_act - list of possible signals returned by a call and the action to be - * to be taken when the signal is returned: in effect a switch statement. - */ -struct sig_act { - struct code *sig; /* signal */ - struct code *cd; /* action to be taken: goto, return, break */ - struct sig_act *shar_act; /* signals that share this action */ - struct sig_act *next; - }; - -/* - * val_loc - location of a value. Used for intermediate and final results - * of expressions. - */ -#define V_NamedVar 1 /* Icon named variable indicated by nvar */ -#define V_Temp 2 /* temporary variable indicated by tmp */ -#define V_ITemp 3 /* C integer temporary variable indicated by tmp */ -#define V_DTemp 4 /* C double temporary variable indicated by tmp */ -#define V_PRslt 5 /* procedure result location */ -#define V_Const 6 /* integer constant - used for size of varargs */ -#define V_CVar 7 /* C named variable */ -#define V_Ignore 8 /* "trashcan" - a write-only location */ - -#define M_None 0 /* access simply as descriptor */ -#define M_CharPtr 1 /* access v-word as "char *" */ -#define M_BlkPtr 2 /* access v-word as block pointer using blk_name */ -#define M_CInt 3 /* access v-word as C integer */ -#define M_Addr 4 /* address of descriptor for varargs */ - -struct val_loc { - int loc_type; /* manifest constants V_* */ - int mod_access; /* manifest constants M_* */ - char *blk_name; /* used with M_BlkPtr */ - union { - struct lentry *nvar; /* Icon named variable */ - int tmp; /* index of temporary variable */ - int int_const; /* integer constant value */ - char *name; /* C named variable */ - } u; - }; - -/* - * "code" contains the information needed to print a piece of C code. - * C_... manifest constants are cd_id's. These are followed by - * corresponding field access expressions. - */ -#define Rslt fld[0].vloc /* place to put result of expression */ -#define Cont fld[1].fnc /* continuation function or null */ - -#define C_Null 0 /* no code */ - -#define C_NamedVar 1 /* reference to a named variable */ -/* uses Rslt */ -#define NamedVar fld[1].nvar - -#define C_CallSig 2 /* call and handling of returned signal */ -#define OperName fld[0].oper_nm /* run-time routine name or null */ -/* uses Cont */ -#define Flags fld[2].n /* flag: NeedCont, ForeignSig */ -#define ArgLst fld[3].cd /* argument list */ -#define ContFail fld[4].cd /* label/signal to goto/return on failure */ -#define SigActs fld[5].sa /* actions to take for returned signals */ -#define NextCall fld[6].cd /* for chaining calls within a continuation*/ -#define NeedCont 1 /* pass NULL continuation if Cont == NULL */ -#define ForeignSig 2 /* may get foreign signal from a suspend */ - -#define C_RetSig 3 /* return signal */ -#define SigRef fld[0].sigref /* pointer to func's reference to signal */ - -#define C_Goto 4 /* goto label */ -#define Lbl fld[0].cd /* label */ - -#define C_Label 5 /* statment label "Ln:" and signal "n" */ -#define Container fld[0].fnc /* continuation containing label */ -#define SeqNum fld[1].n /* sequence number, n */ -#define Desc fld[2].s /* description of how label/signal is used */ -#define RefCnt fld[3].n /* reference count for label */ -#define LabFlg fld[4].n /* flag: FncPtrd, BndSig */ -#define FncPrtd 1 /* function sig_n has been printed */ -#define Bounding 2 /* this is a bounding label */ - -#define C_Lit 6 /* literal (integer, real, string, cset) */ -/* uses Rslt */ -#define Literal fld[1].lit - -#define C_Resume 7 /* resume signal */ -#define C_Continue 8 /* continue signal */ -#define C_FallThru 9 /* fall through signal */ -#define C_PFail 10 /* procedure failure */ -#define C_PRet 11 /* procedure return (result already set) */ -#define C_PSusp 12 /* procedure suspend */ -#define C_Break 13 /* break out of signal handling switch */ -#define C_LBrack 14 /* '{' */ -#define C_RBrack 15 /* '}' */ - -#define C_Create 16 /* call of create() for create expression */ -/* uses Rslt */ -/* uses Cont */ -#define NTemps fld[2].n /* number of temporary descriptors needed */ -#define WrkSize fld[3].n /* size of non-descriptor work area */ -#define NextCreat fld[4].cd /* for chaining creates in a continuation */ - - -#define C_If 17 /* conditional (goto or return) */ -#define Cond fld[0].cd /* condition */ -#define ThenStmt fld[1].cd /* what to do if condition is true */ - -#define C_SrcLoc 18 -#define FileName fld[0].s /* name of source file */ -#define LineNum fld[1].n /* line number within source file */ - -#define C_CdAry 19 /* array of code pieces, each with type code*/ -#define A_Str 0 /* code represented as a string */ -#define A_ValLoc 1 /* value location */ -#define A_Intgr 2 /* integer */ -#define A_ProcCont 3 /* procedure continuation */ -#define A_SBuf 4 /* string buffer (integer index) */ -#define A_CBuf 5 /* cset buffer (integer index) */ -#define A_Ary 6 /* pointer to subarray of code pieces */ -#define A_End 7 /* marker for end of array */ -#define ElemTyp(i) fld[2*i].n /* type of element i (A_* codes) */ -#define Str(i) fld[2*i+1].s /* string in element i */ -#define ValLoc(i) fld[2*i+1].vloc /* value location in element i */ -#define Intgr(i) fld[2*i+1].n /* integer in element i */ -#define Array(i) fld[2*i+1].cd /* pointer to subarray in element i */ - -/* - * union cd_fld - fields within a code struct. - */ -union cd_fld { - int n; /* various integer values */ - char *s; /* various string values */ - struct lentry *nvar; /* symbol table entry for a named variable */ - struct code *cd; /* various pointers to other pieces of code */ - struct c_fnc *fnc; /* pointer to function information */ - struct centry *lit; /* symbol table entry for a literal */ - struct sig_act *sa; /* actions to take for a returned signal */ - struct sig_lst *sigref; /* pointer to func's reference to signal */ - struct val_loc *vloc; /* value location */ - char *oper_nm; /* name of run-time operation or NULL */ - }; - -/* - * code - struct used to hold the internal representation of generated code. - */ -struct code { - int cd_id; /* kind of code: C_* */ - struct code *next; /* next code fragment in list */ - struct code *prev; /* previous code fragment in list */ - union cd_fld fld[1]; /* fields of code fragment, actual number varies */ - }; - -/* - * NewCode - allocate a code structure with "size" fields. - */ -#define NewCode(size) (struct code *)alloc((unsigned int)\ - (sizeof(struct code) + (size-1) * sizeof(union cd_fld))) - -/* - * c_fnc contains information about a C function that implements a continuation. - */ -#define CF_SigOnly 1 /* this function only returns a signal */ -#define CF_ForeignSig 2 /* may return foreign signal from a suspend */ -#define CF_Mark 4 /* this function has been visited by fix_fncs() */ -#define CF_Coexpr 8 /* this function implements a co-expression */ -struct c_fnc { - char prefix[PrfxSz+1]; /* function prefix */ - char frm_prfx[PrfxSz+1]; /* procedure frame prefix */ - int flag; /* CF_* flags */ - struct code cd; /* start of code sequence */ - struct code *cursor; /* place to insert more code into sequence */ - struct code *call_lst; /* functions called by this function */ - struct code *creatlst; /* list of creates in this function */ - struct sig_lst *sig_lst; /* signals returned by this function */ - int ref_cnt; /* reference count for this function */ - struct c_fnc *next; - }; - - -/* - * sig_lst - a list of signals returned by a continuation along with a count - * of the number of places each signal is returned. - */ -struct sig_lst { - struct code *sig; /* signal */ - int ref_cnt; /* number of places returned */ - struct sig_lst *next; - }; - -/* - * op_symentry - entry in symbol table for an operation - */ -#define AdjNone 1 /* no adjustment to this argument */ -#define AdjDrf 2 /* deref in place */ -#define AdjNDrf 3 /* deref into a new temporary */ -#define AdjCpy 4 /* copy into a new temporary */ -struct op_symentry { - int n_refs; /* number of non-modifying references */ - int n_mods; /* number of modifying referenced */ - int n_rets; /* number of times directly returned from operation */ - int var_safe; /* if arg is named var, it may be used directly */ - int adjust; /* AdjNone, AdjInplc, or AdjToNew */ - int itmp_indx; /* index of temporary C integer variable */ - int dtmp_indx; /* index of temporary C double variable */ - struct val_loc *loc; - }; - -extern int num_tmp; /* number of temporary descriptor variables */ -extern int num_itmp; /* number of temporary C integer variables */ -extern int num_dtmp; /* number of temporary C double variables */ -extern int num_sbuf; /* number of string buffers */ -extern int num_cbuf; /* number of cset buffers */ - -extern struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -extern struct code resume; -extern struct code contin; -extern struct code fallthru; -extern struct code next_fail; - -extern struct val_loc ignore; /* no values, just something to point at */ -extern struct c_fnc *cur_fnc; /* C function currently being built */ -extern struct code *on_failure; /* place to go on failure */ - -extern int lbl_seq_num; /* next label sequence number */ - -extern char pre[PrfxSz]; /* next unused prefix */ - -extern struct op_symentry *cur_symtab; /* current operation symbol table */ - -#define SepFnc 1 /* success continuation goes in separate function */ -#define SContIL 2 /* in line success continuation */ -#define EndOper 3 /* success continuation goes at end of operation */ - -#define HasVal 1 /* type contains values */ -#define HasLcl 2 /* type contains local variables */ -#define HasPrm 4 /* type contains parameters */ -#define HasGlb 8 /* type contains globals (including statics and elements) */ -#define HasVar(x) ((x) & (HasLcl | HasPrm | HasGlb)) diff --git a/src/iconc/ccomp.c b/src/iconc/ccomp.c deleted file mode 100644 index 5b86189..0000000 --- a/src/iconc/ccomp.c +++ /dev/null @@ -1,130 +0,0 @@ -/* - * ccomp.c - routines for compiling and linking the C program produced - * by the translator. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "ctree.h" -#include "ccode.h" -#include "csym.h" -#include "cproto.h" - -extern char *refpath; - -#define ExeFlag "-o" -#define LinkLibs " -lm" - -/* - * Structure to hold the list of Icon run-time libraries that must be - * linked in. - */ -struct lib { - char *libname; - int nm_sz; - struct lib *next; - }; -static struct lib *liblst; -static int lib_sz = 0; - -/* - * addlib - add a new library to the list the must be linked. - */ -void addlib(libname) -char *libname; - { - static struct lib **nxtlib = &liblst; - struct lib *l; - - l = NewStruct(lib); - l->libname = libname; - l->nm_sz = strlen(libname); - l->next = NULL; - *nxtlib = l; - nxtlib = &l->next; - lib_sz += l->nm_sz + 1; - } - -/* - * ccomp - perform C compilation and linking. - */ -int ccomp(srcname, exename) -char *srcname; -char *exename; - { - struct lib *l; - char sbuf[MaxPath]; /* file name construction buffer */ - char *buf; - char *s; - char *dlrgint; - int cmd_sz, opt_sz, flg_sz, exe_sz, src_sz; - - /* - * Compute the sizes of the various parts of the command line - * to do the compilation. - */ - cmd_sz = strlen(c_comp); - opt_sz = strlen(c_opts); - flg_sz = strlen(ExeFlag); - exe_sz = strlen(exename); - src_sz = strlen(srcname); - lib_sz += strlen(LinkLibs); - if (!largeints) { - dlrgint = makename(sbuf, refpath, "dlrgint", ObjSuffix); - lib_sz += strlen(dlrgint) + 1; - } - -#ifdef Graphics - lib_sz += strlen(" -L") + - strlen(refpath) + - strlen(" -lIgpx "); - lib_sz += strlen(ICONC_XLIB); -#endif /* Graphics */ - - buf = alloc((unsigned int)cmd_sz + opt_sz + flg_sz + exe_sz + src_sz + - lib_sz + 5); - strcpy(buf, c_comp); - s = buf + cmd_sz; - *s++ = ' '; - strcpy(s, c_opts); - s += opt_sz; - *s++ = ' '; - strcpy(s, ExeFlag); - s += flg_sz; - *s++ = ' '; - strcpy(s, exename); - s += exe_sz; - *s++ = ' '; - strcpy(s, srcname); - s += src_sz; - if (!largeints) { - *s++ = ' '; - strcpy(s, dlrgint); - s += strlen(dlrgint); - } - for (l = liblst; l != NULL; l = l->next) { - *s++ = ' '; - strcpy(s, l->libname); - s += l->nm_sz; - } - -#ifdef Graphics - strcpy(s," -L"); - strcat(s, refpath); - strcat(s," -lIgpx "); - strcat(s, ICONC_XLIB); - s += strlen(s); -#endif /* Graphics */ - - strcpy(s, LinkLibs); - - if (system(buf) != 0) - return EXIT_FAILURE; - strcpy(buf, "strip "); - s = buf + 6; - strcpy(s, exename); - system(buf); - - - return EXIT_SUCCESS; - } diff --git a/src/iconc/cglobals.h b/src/iconc/cglobals.h deleted file mode 100644 index 301a602..0000000 --- a/src/iconc/cglobals.h +++ /dev/null @@ -1,50 +0,0 @@ -/* - * Global variables. - */ - -extern char *runtime; - -#ifndef Global -#define Global extern -#define Init(v) -#endif /* Global */ - -/* - * Variables related to command processing. - */ -Global char *progname Init("iconc"); /* program name for diagnostics */ - -Global int debug_info Init(0); /* -fd, -t: generate debugging info */ -Global int err_conv Init(0); /* -fe: support error conversion */ - -#ifdef LargeInts - Global int largeints Init(1); /* -fl: support large integers */ -#else /* LargeInts */ - Global int largeints Init(0); /* -fl: support large integers */ -#endif /* LargeInts */ - -Global int line_info Init(0); /* -fn, -fd, -t: generate line info */ -Global int m4pre Init(0); /* -m: use m4 preprocessor? */ -Global int str_inv Init(0); /* -fs: enable full string invocation */ -Global int trace Init(0); /* -t: initial &trace value */ -Global int uwarn Init(0); /* -u: warn about undefined ids? */ -Global int just_type_trace Init(0); /* -T: suppress C code */ -Global int verbose Init(1); /* -s, -v: level of verbosity */ -Global int pponly Init(0); /* -E: preprocess only */ - -Global char *c_comp Init(CComp); /* -C: C compiler */ -Global char *c_opts Init(COpts); /* -p: options for C compiler */ - -/* - * Flags turned off by the -n option. - */ -Global int opt_cntrl Init(1); /* do control flow optimization */ -Global int opt_sgnl Init(1); /* do signal handling optimizations */ -Global int do_typinfer Init(1); /* do type inference */ -Global int allow_inline Init(1); /* allow expanding operations in line */ - -/* - * Files. - */ -Global FILE *codefile Init(0); /* C code output - primary file */ -Global FILE *inclfile Init(0); /* C code output - include file */ diff --git a/src/iconc/cgrammar.c b/src/iconc/cgrammar.c deleted file mode 100644 index a48e621..0000000 --- a/src/iconc/cgrammar.c +++ /dev/null @@ -1,221 +0,0 @@ -/* - * cgrammar.c - includes and macros for building the parse tree. - */ -#include "../h/define.h" -#include "../common/yacctok.h" - -%{ -/* - * These commented directives are passed through the first application - * of cpp, then turned into real directives in cgram.g by fixgram.icn. - */ -/*#include "../h/gsupport.h"*/ -/*#include "../h/lexdef.h"*/ -/*#include "ctrans.h"*/ -/*#include "csym.h"*/ -/*#include "ctree.h"*/ -/*#include "ccode.h" */ -/*#include "cproto.h"*/ -/*#undef YYSTYPE*/ -/*#define YYSTYPE nodeptr*/ -/*#define YYMAXDEPTH 500*/ - -int idflag; - -#define EmptyNode tree1(N_Empty) - -#define Alt(x1,x2,x3) $$ = tree4(N_Alt,x2,x1,x3) -#define Apply(x1,x2,x3) $$ = tree4(N_Apply,x2,x1,x3) -#define Arglist1() /* empty */ -#define Arglist2(x) /* empty */ -#define Arglist3(x1,x2,x3) proc_lst->nargs = -proc_lst->nargs -#define Bact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) -#define Bamper(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Baugact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) -#define Baugamper(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugeq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugeqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauggt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauglcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauglt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugneqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) -#define Baugseq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsgt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugslt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bcaret(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bcareta(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bdiff(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bdiffa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Beq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Beqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Binter(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bintera(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Blcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Ble(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Blim(x1,x2,x3) $$ = tree4(N_Limit,x2,x1,x3) -#define Blt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bminus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bminusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bmod(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bmoda(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bneqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bplus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bplusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) -#define Brace(x1,x2,x3) $$ = x2 -#define Brack(x1,x2,x3) $$ = list_nd(x1,x2) -#define Brassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Break(x1,x2) $$ = tree3(N_Break,x1,x2) -#define Brswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bseq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslash(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslasha(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bsle(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bstar(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bstara(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bunion(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Buniona(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Case(x1,x2,x3,x4,x5,x6) $$ = case_nd(x1,x2,x5) -#define Caselist(x1,x2,x3) $$ = tree4(N_Clist,x2,x1,x3) -#define Cclause0(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) -#define Cclause1(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) -#define Cliter(x) CSym0(x) = putlit(Str0(x),F_CsetLit,(int)Val1(x)) -#define Colon(x) $$ = x -#define Compound(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) -#define Create(x1,x2) $$ = tree3(N_Create,x1,x2);\ - proc_lst->has_coexpr = 1; -#define Elst0(x) $$ = x; -#define Elst1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,x3); -#define Every0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Every1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define Fail(x) $$ = tree4(N_Ret,x,x,EmptyNode) -#define Field(x1,x2,x3) $$ = tree4(N_Field,x2,x1,x3) -#define Global0(x) idflag = F_Global -#define Global1(x1,x2,x3) /* empty */ -#define Globdcl(x) /* empty */ -#define Ident(x) install(Str0(x),idflag) -#define Idlist(x1,x2,x3) install(Str0(x3),idflag) -#define If0(x1,x2,x3,x4) $$ = tree5(N_If,x1,x2,x4,EmptyNode) -#define If1(x1,x2,x3,x4,x5,x6) $$ = tree5(N_If,x1,x2,x4,x6) -#define Iliter(x) CSym0(x) = putlit(Str0(x),F_IntLit,0) -#define Initial1() $$ = EmptyNode -#define Initial2(x1,x2,x3) $$ = x2 -#define Invocdcl(x) /* empty */ -#define Invocable(x1,x2) /* empty */ -#define Invoclist(x1,x2, x3) /* empty */ -#define Invocop1(x) invoc_grp(Str0(x)); -#define Invocop2(x) invocbl(x, -1); -#define Invocop3(x1,x2,x3) invocbl(x1, atoi(Str0(x3))); -#define Invoke(x1,x2,x3,x4) $$ = invk_nd(x2,x1,x3) -#define Keyword(x1,x2) $$ = key_leaf(x1,Str0(x2)) -#define Kfail(x1,x2) $$ = key_leaf(x1,spec_str("fail")) -#define Link(x1,x2) /* empty */ -#define Linkdcl(x) /* empty */ -#define Lnkfile1(x) lnkdcl(Str0(x)); -#define Lnkfile2(x) lnkdcl(Str0(x)); -#define Lnklist(x1,x2,x3) /* empty */ -#define Local(x) idflag = F_Dynamic -#define Locals1() /* empty */ -#define Locals2(x1,x2,x3,x4) /* empty */ -#define Mcolon(x) $$ = x -#define Nexpr() $$ = EmptyNode -#define Next(x) $$ = tree2(N_Next,x) -#define Paren(x1,x2,x3) if ((x2)->n_type == N_Elist)\ - $$ = invk_nd(x1,EmptyNode,x2);\ - else\ - $$ = x2 -#define Pcolon(x) $$ = x -#define Pdco0(x1,x2,x3) $$ = invk_nd(x2,x1,list_nd(x2,EmptyNode)) -#define Pdco1(x1,x2,x3,x4) $$ = invk_nd(x2,x1,list_nd(x2,x3)) -#define Pdcolist0(x) $$ = tree3(N_Create,x,x);\ - proc_lst->has_coexpr = 1; -#define Pdcolist1(x1,x2,x3) $$ =tree4(N_Elist,x2,x1,tree3(N_Create,x2,x3));\ - proc_lst->has_coexpr = 1; -#define Proc1(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Proc,x1,x1,x4,x5,x6) -#define Procbody1() $$ = EmptyNode -#define Procbody2(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) -#define Procdcl(x) proc_lst->tree = x -#define Prochead1(x1,x2) init_proc(Str0(x2));\ - idflag = F_Argument -#define Prochead2(x1,x2,x3,x4,x5,x6) /* empty */ -#define Progend(x1,x2) /* empty */ -#define Recdcl(x) /* empty */ -#define Record1(x1, x2) init_rec(Str0(x2));\ - idflag = F_Field -#define Record2(x1,x2,x3,x4,x5,x6) /* empty */ -#define Repeat(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Return(x1,x2) $$ = tree4(N_Ret,x1,x1,x2) -#define Rliter(x) CSym0(x) = putlit(Str0(x),F_RealLit,0) -#define Section(x1,x2,x3,x4,x5,x6) $$ = sect_nd(x4,x1,x3,x5) -#define Sliter(x) CSym0(x) = putlit(Str0(x),F_StrLit,(int)Val1(x)) -#define Static(x) idflag = F_Static -#define Subscript(x1,x2,x3,x4) $$ = buildarray(x1,x2,x3) -#define Suspend0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Suspend1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define To0(x1,x2,x3) $$ = to_nd(x2,x1,x3) -#define To1(x1,x2,x3,x4,x5) $$ = toby_nd(x2,x1,x3,x5) -#define Uat(x1,x2) $$ = tree5(N_Activat,x1,x1,EmptyNode,x2) -#define Ubackslash(x1,x2) $$ = unary_nd(x1,x2) -#define Ubang(x1,x2) $$ = unary_nd(x1,x2) -#define Ubar(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Ucaret(x1,x2) $$ = unary_nd(x1,x2) -#define Uconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Udiff(x1,x2) $$ = MultiUnary(x1,x2) -#define Udot(x1,x2) $$ = unary_nd(x1,x2) -#define Uequiv(x1,x2) $$ = MultiUnary(x1,x2) -#define Uinter(x1,x2) $$ = MultiUnary(x1,x2) -#define Ulconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Ulexeq(x1,x2) $$ = MultiUnary(x1,x2) -#define Ulexne(x1,x2) $$ = MultiUnary(x1,x2) -#define Uminus(x1,x2) $$ = unary_nd(x1,x2) -#define Unot(x1,x2) $$ = tree3(N_Not,x2,x2) -#define Unotequiv(x1,x2) $$ = MultiUnary(x1,x2) -#define Until0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Until1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define Unumeq(x1,x2) $$ = unary_nd(x1,x2) -#define Unumne(x1,x2) $$ = MultiUnary(x1,x2) -#define Uplus(x1,x2) $$ = unary_nd(x1,x2) -#define Uqmark(x1,x2) $$ = unary_nd(x1,x2) -#define Uslash(x1,x2) $$ = unary_nd(x1,x2) -#define Ustar(x1,x2) $$ = unary_nd(x1,x2) -#define Utilde(x1,x2) $$ = unary_nd(x1,x2) -#define Uunion(x1,x2) $$ = MultiUnary(x1,x2) -#define Var(x) LSym0(x) = putloc(Str0(x),0) -#define While0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define While1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -%} - -%% -#include "../h/grammar.h" -%% - -/* - * xfree(p) -- used with free(p) macro to avoid compiler errors from - * miscast free calls generated by Yacc. - */ -#undef free -static void xfree(p) -char *p; -{ - free(p); -} - -/*#define free(p) xfree((char*)p)*/ diff --git a/src/iconc/chkinv.c b/src/iconc/chkinv.c deleted file mode 100644 index af4298f..0000000 --- a/src/iconc/chkinv.c +++ /dev/null @@ -1,545 +0,0 @@ -/* - * chkinv.c - routines to determine which global names are only - * used as immediate operand to invocation and to directly invoke - * the corresponding operations. In addition, simple assignments to - * names variables are recognized and it is determined whether - * procedures return, suspend, or fail. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" - -/* - * prototypes for static functions. - */ -static int chg_ret (int flag); -static void chksmpl (struct node *n, int smpl_invk); -static int seq_exec (int exec_flg1, int exec_flg2); -static int spcl_inv (struct node *n, struct node *asgn); - -static ret_flag; - -/* - * chkinv - check for invocation and assignment optimizations. - */ -void chkinv() - { - struct gentry *gp; - struct pentry *proc; - int exec_flg; - int i; - - if (debug_info) - return; /* The following analysis is not valid */ - - /* - * start off assuming that global variables for procedure, etc. are - * only used as immediate operands to invocations then mark any - * which are not. Any variables retaining the property are never - * changed. Go through the code and change invocations to such - * variables to invocations directly to the operation. - */ - for (i = 0; i < GHSize; i++) - for (gp = ghash[i]; gp != NULL; gp = gp->blink) { - if (gp->flag & (F_Proc | F_Builtin | F_Record) && - !(gp->flag & F_StrInv)) - gp->flag |= F_SmplInv; - /* - * However, only optimize normal cases for main. - */ - if (strcmp(gp->name, "main") == 0 && (gp->flag & F_Proc) && - (gp->val.proc->nargs < 0 || gp->val.proc->nargs > 1)) - gp->flag &= ~(uword)F_SmplInv; - /* - * Work-around to problem that a co-expression block needs - * block for enclosing procedure: just keep procedure in - * a variable to force outputting the block. Note, this - * inhibits tailored calling conventions for the procedure. - */ - if ((gp->flag & F_Proc) && gp->val.proc->has_coexpr) - gp->flag &= ~(uword)F_SmplInv; - } - - /* - * Analyze code in each procedure. - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) { - chksmpl(Tree1(proc->tree), 0); /* initial expression */ - chksmpl(Tree2(proc->tree), 0); /* procedure body */ - } - - /* - * Go through each procedure performing "naive" optimizations on - * invocations and assignments. Also determine whether the procedure - * returns, suspends, or fails (possibly by falling through to - * the end). - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) { - ret_flag = 0; - spcl_inv(Tree1(proc->tree), NULL); - exec_flg = spcl_inv(Tree2(proc->tree), NULL); - if (exec_flg & DoesFThru) - ret_flag |= DoesFail; - proc->ret_flag = ret_flag; - } - } - -/* - * smpl_invk - find any global variable uses that are not a simple - * invocation and mark the variables. - */ -static void chksmpl(n, smpl_invk) -struct node *n; -int smpl_invk; - { - struct node *cases; - struct node *clause; - struct lentry *var; - int i; - int lst_arg; - - switch (n->n_type) { - case N_Alt: - case N_Apply: - case N_Limit: - case N_Slist: - chksmpl(Tree0(n), 0); - chksmpl(Tree1(n), 0); - break; - - case N_Activat: - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Augop: - chksmpl(Tree2(n), 0); - chksmpl(Tree3(n), 0); - break; - - case N_Bar: - case N_Break: - case N_Create: - case N_Field: - case N_Not: - chksmpl(Tree0(n), 0); - break; - - case N_Case: - chksmpl(Tree0(n), 0); /* 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); - } - - chksmpl(Tree0(clause), 0); /* value of clause */ - chksmpl(Tree1(clause), 0); /* body of clause */ - } - if (Tree2(n) != NULL) - chksmpl(Tree2(n), 0); /* default */ - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - case N_Empty: - case N_Next: - break; - - case N_Id: - if (!smpl_invk) { - /* - * The variable is being used somewhere other than in a simple - * invocation. - */ - var = LSym0(n); - if (var->flag & F_Global) - var->val.global->flag &= ~F_SmplInv; - } - break; - - case N_If: - chksmpl(Tree0(n), 0); - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Invok: - lst_arg = 1 + Val0(n); - /* - * Check the thing being invoked, noting that it is in fact being - * invoked. - */ - chksmpl(Tree1(n), 1); - for (i = 2; i <= lst_arg; ++i) - chksmpl(n->n_field[i].n_ptr, 0); /* arg i - 1 */ - break; - - case N_InvOp: - lst_arg = 1 + Val0(n); - for (i = 2; i <= lst_arg; ++i) - chksmpl(n->n_field[i].n_ptr, 0); /* arg i */ - break; - - case N_Loop: { - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - case WHILE: - case UNTIL: - chksmpl(Tree1(n), 0); /* control clause */ - chksmpl(Tree2(n), 0); /* do clause */ - break; - - case REPEAT: - chksmpl(Tree1(n), 0); /* clause */ - break; - } - } - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) - chksmpl(Tree1(n), 0); - break; - - case N_Scan: - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Sect: - chksmpl(Tree2(n), 0); - chksmpl(Tree3(n), 0); - chksmpl(Tree4(n), 0); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * spcl_inv - look for general invocations that can be replaced by - * special invocations. Simple assignment to a named variable is - * is a particularly special case. Also, determine whether execution - * might "fall through" this code and whether the code might fail. - */ -static int spcl_inv(n, asgn) -struct node *n; -struct node *asgn; /* the result goes into this special-cased assignment */ - { - struct node *cases; - struct node *clause; - struct node *invokee; - struct gentry *gvar; - struct loop { - int exec_flg; - struct node *asgn; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - int exec_flg; - int i; - int lst_arg; - static struct loop *cur_loop = NULL; - - switch (n->n_type) { - case N_Activat: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* assume worst case */ - return seq_exec(spcl_inv(Tree1(n), NULL), spcl_inv(Tree2(n), NULL)); - - case N_Alt: - exec_flg = spcl_inv(Tree0(n), asgn) & DoesFThru; - return exec_flg | spcl_inv(Tree1(n), asgn); - - case N_Apply: - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - return seq_exec(spcl_inv(Tree0(n), NULL), spcl_inv(Tree1(n), NULL)); - - case N_Augop: - exec_flg = chg_ret(Impl1(n)->ret_flag); - if (Tree2(n)->n_type == N_Id) { - /* - * This is an augmented assignment to a named variable. - * An optimized version of assignment can be used. - */ - n->n_type = N_SmplAug; - if (Impl1(n)->use_rslt) - Val0(n) = AsgnCopy; - else - Val0(n) = AsgnDirect; - } - else { - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* this operation produces a variable */ - exec_flg = seq_exec(exec_flg, spcl_inv(Tree2(n), NULL)); - exec_flg = seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); - } - return seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); - - case N_Bar: - return spcl_inv(Tree0(n), asgn); - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return 0; - } - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - loop_sav->exec_flg |= spcl_inv(Tree0(n), loop_sav->asgn); - cur_loop = loop_sav; - return 0; - - case N_Create: - spcl_inv(Tree0(n), NULL); - return DoesFThru; - - case N_Case: - exec_flg = spcl_inv(Tree0(n), NULL) & DoesFail; /* 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); - } - - spcl_inv(Tree0(clause), NULL); - exec_flg |= spcl_inv(Tree1(clause), asgn); - } - if (Tree2(n) != NULL) - exec_flg |= spcl_inv(Tree2(n), asgn); /* default */ - else - exec_flg |= DoesFail; - return exec_flg; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - case N_Empty: - return DoesFThru; - - case N_Field: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* operation produces variable */ - return spcl_inv(Tree0(n), NULL); - - case N_Id: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* variable */ - return DoesFThru; - - case N_If: - spcl_inv(Tree0(n), NULL); - exec_flg = spcl_inv(Tree1(n), asgn); - if (Tree2(n)->n_type == N_Empty) - exec_flg |= DoesFail; - else - exec_flg |= spcl_inv(Tree2(n), asgn); - return exec_flg; - - case N_Invok: - lst_arg = 1 + Val0(n); - invokee = Tree1(n); - exec_flg = DoesFThru; - for (i = 2; i <= lst_arg; ++i) - exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, NULL)); - if (invokee->n_type == N_Id && LSym0(invokee)->flag & F_Global) { - /* - * This is an invocation of a global variable. If we can - * convert this to a direct invocation, determine whether - * it is an invocation of a procedure, built-in function, - * or record constructor; each has a difference kind of - * direct invocation node. - */ - gvar = LSym0(invokee)->val.global; - if (gvar->flag & F_SmplInv) { - switch (gvar->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - n->n_type = N_InvProc; - Proc1(n) = gvar->val.proc; - return DoesFThru | DoesFail; /* assume worst case */ - case F_Builtin: - n->n_type = N_InvOp; - Impl1(n) = gvar->val.builtin; - if (asgn != NULL && Impl1(n)->use_rslt) - Val0(asgn) = AsgnCopy; - return seq_exec(exec_flg, chg_ret( - gvar->val.builtin->ret_flag)); - case F_Record: - n->n_type = N_InvRec; - Rec1(n) = gvar->val.rec; - return seq_exec(exec_flg, DoesFThru | - (err_conv ? DoesFail : 0)); - } - } - } - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - spcl_inv(invokee, NULL); - return DoesFThru | DoesFail; /* assume worst case */ - - case N_InvOp: - if (Impl1(n)->op != NULL && strcmp(Impl1(n)->op, ":=") == 0 && - Tree2(n)->n_type == N_Id) { - /* - * This is a simple assignment to a named variable. - * An optimized version of assignment can be used. - */ - n->n_type = N_SmplAsgn; - - /* - * For now, assume rhs of := can compute directly into a - * variable. This may be changed when the rhs is examined - * in the recursive call to spcl_inv(). - */ - Val0(n) = AsgnDirect; - return spcl_inv(Tree3(n), n); - } - else { - /* - * No special cases. - */ - lst_arg = 1 + Val0(n); - exec_flg = chg_ret(Impl1(n)->ret_flag); - for (i = 2; i <= lst_arg; ++i) - exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, - NULL)); /* arg i */ - if (asgn != NULL && Impl1(n)->use_rslt) - Val0(asgn) = AsgnCopy; - return exec_flg; - } - - case N_Limit: - return seq_exec(spcl_inv(Tree0(n), asgn), - spcl_inv(Tree1(n), NULL)) | DoesFail; - - case N_Loop: { - loop_info.prev = cur_loop; - loop_info.exec_flg = 0; - loop_info.asgn = asgn; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - case WHILE: - case UNTIL: - spcl_inv(Tree1(n), NULL); /* control clause */ - spcl_inv(Tree2(n), NULL); /* do clause */ - exec_flg = DoesFail; - break; - - case SUSPEND: - spcl_inv(Tree1(n), NULL); /* control clause */ - spcl_inv(Tree2(n), NULL); /* do clause */ - ret_flag |= DoesSusp; - exec_flg = DoesFail; - break; - - case REPEAT: - spcl_inv(Tree1(n), NULL); /* clause */ - exec_flg = 0; - break; - } - exec_flg |= cur_loop->exec_flg; - cur_loop = cur_loop->prev; - return exec_flg; - } - - case N_Next: - return 0; - - case N_Not: - exec_flg = spcl_inv(Tree0(n), NULL); - return ((exec_flg & DoesFail) ? DoesFThru : 0) | - ((exec_flg & DoesFThru) ? DoesFail: 0); - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - exec_flg = spcl_inv(Tree1(n), NULL); - ret_flag |= DoesRet; - if (exec_flg & DoesFail) - ret_flag |= DoesFail; - } - else - ret_flag |= DoesFail; - return 0; - - case N_Scan: - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - return seq_exec(spcl_inv(Tree1(n), NULL), - spcl_inv(Tree2(n), NULL)); - - case N_Sect: - if (asgn != NULL && Impl0(n)->use_rslt) - Val0(asgn) = AsgnCopy; - exec_flg = spcl_inv(Tree2(n), NULL); - exec_flg = seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); - exec_flg = seq_exec(exec_flg, spcl_inv(Tree4(n), NULL)); - return seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); - - case N_Slist: - exec_flg = spcl_inv(Tree0(n), NULL); - if (exec_flg & (DoesFThru | DoesFail)) - exec_flg = DoesFThru; - return seq_exec(exec_flg, spcl_inv(Tree1(n), asgn)); - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * seq_exec - take the execution flags for sequential pieces of code - * and compute the flags for the combined code. - */ -static int seq_exec(exec_flg1, exec_flg2) -int exec_flg1; -int exec_flg2; - { - return (exec_flg1 & exec_flg2 & DoesFThru) | - ((exec_flg1 | exec_flg2) & DoesFail); - } - -/* - * chg_ret - take a return flag and change suspend and return to - * "fall through". If error conversion is supported, change error - * failure to failure. - * - */ -static int chg_ret(flag) -int flag; - { - int flg1; - - flg1 = flag & DoesFail; - if (flag & (DoesRet | DoesSusp)) - flg1 |= DoesFThru; - if (err_conv && (flag & DoesEFail)) - flg1 |= DoesFail; - return flg1; - } - - diff --git a/src/iconc/clex.c b/src/iconc/clex.c deleted file mode 100644 index 8e7d657..0000000 --- a/src/iconc/clex.c +++ /dev/null @@ -1,18 +0,0 @@ -/* - * clex.c -- the lexical analyzer for iconc. - */ -#define Iconc - -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "ctoken.h" -#include "ctree.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -#include "../h/parserr.h" -#include "../common/lextab.h" -#include "../common/yylex.h" -#include "../common/error.h" diff --git a/src/iconc/cmain.c b/src/iconc/cmain.c deleted file mode 100644 index 6daf5c4..0000000 --- a/src/iconc/cmain.c +++ /dev/null @@ -1,424 +0,0 @@ -/* - * cmain.c - main program icon compiler. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "ctree.h" -#include "ccode.h" -#include "csym.h" -#include "cproto.h" - -/* - * Prototypes. - */ -static void execute (char *ofile, char **args); -static FILE *open_out (char *fname); -static void rmfile (char *fname); -static void report (char *s); -static void usage (void); - -char *refpath; - -char patchpath[MaxPath+18] = "%PatchStringHere->"; - -/* - * Define global variables. - */ - -#define Global -#define Init(v) = v -#include "cglobals.h" - -/* - * getopt() variables - */ -extern int optind; /* index into parent argv vector */ -extern int optopt; /* character checked for validity */ -extern char *optarg; /* argument associated with option */ - -/* - * main program - */ -int main(argc,argv) -int argc; -char **argv; - { - int no_c_comp = 0; /* suppress C compile and link? */ - int errors = 0; /* compilation errors */ - char *cfile = NULL; /* name of C file - primary */ - char *hfile = NULL; /* name of C file - include */ - char *ofile = NULL; /* name of executable result */ - - char *db_name = "rt.db"; /* data base name */ - char *incl_file = "rt.h"; /* header file name */ - - char *db_path; /* path to data base */ - char *db_lst; /* list of private data bases */ - char *incl_path; /* path to header file */ - char *s, c1; - char buf[MaxPath]; /* file name construction buffer */ - int c; - int ret_code; - struct fileparts *fp; - - if ((int)strlen(patchpath) > 18) - refpath = patchpath+18; - else - refpath = relfile(argv[0], "/../"); - - /* - * Process options. - */ - while ((c = getopt(argc,argv,"+C:ELS:Tcf:mn:o:p:r:stuv:x")) != EOF) - switch (c) { - case 'C': /* -C C-comp: C compiler*/ - c_comp = optarg; - break; - case 'E': /* -E: preprocess only */ - pponly = 1; - no_c_comp = 1; - break; - case 'L': /* Ignore: interpreter only */ - break; - case 'S': /* Ignore: interpreter only */ - break; - case 'T': - just_type_trace = 1; - break; - case 'c': /* -c: produce C file only */ - no_c_comp = 1; - break; - case 'f': /* -f: enable features */ - for (s = optarg; *s != '\0'; ++s) { - switch (*s) { - case 'a': /* -fa: enable all features */ - line_info = 1; - debug_info = 1; - err_conv = 1; - largeints = 1; - str_inv = 1; - break; - case 'd': /* -fd: enable debugging features */ - line_info = 1; - debug_info = 1; - break; - case 'e': /* -fe: enable error conversion */ - err_conv = 1; - break; - case 'l': /* -fl: support large integers */ - largeints = 1; - break; - case 'n': /* -fn: enable line numbers */ - line_info = 1; - break; - case 's': /* -fs: enable full string invocation */ - str_inv = 1; - break; - default: - quitf("-f option must be a, d, e, l, n, or s. found: %s", - optarg); - } - } - break; - case 'm': /* -m: preprocess using m4(1) */ - m4pre = 1; - break; - case 'n': /* -n: disable optimizations */ - for (s = optarg; *s != '\0'; ++s) { - switch (*s) { - case 'a': /* -na: disable all optimizations */ - opt_cntrl = 0; - allow_inline = 0; - opt_sgnl = 0; - do_typinfer = 0; - break; - case 'c': /* -nc: disable control flow opts */ - opt_cntrl = 0; - break; - case 'e': /* -ne: disable expanding in-line */ - allow_inline = 0; - break; - case 's': /* -ns: disable switch optimizations */ - opt_sgnl = 0; - break; - case 't': /* -nt: disable type inference */ - do_typinfer = 0; - break; - default: - usage(); - } - } - break; - case 'o': /* -o file: name output file */ - ofile = optarg; - break; - case 'p': /* -p C-opts: options for C comp */ - if (*optarg == '\0') /* if empty string, clear options */ - c_opts = optarg; - else { /* else append to current set */ - s = (char *)alloc(strlen(c_opts) + 1 + strlen(optarg) + 1); - sprintf(s, "%s %s", c_opts, optarg); - c_opts = s; - } - break; - case 'r': /* -r path: primary runtime system */ - refpath = optarg; - break; - case 's': /* -s: suppress informative messages */ - verbose = 0; - break; - case 't': /* -t: &trace = -1 */ - line_info = 1; - debug_info = 1; - trace = 1; - break; - case 'u': /* -u: warn about undeclared ids */ - uwarn = 1; - break; - case 'v': /* -v: set level of verbosity */ - if (sscanf(optarg, "%d%c", &verbose, &c1) != 1) - quitf("bad operand to -v option: %s",optarg); - break; - default: - case 'x': /* -x illegal until after file list */ - usage(); - } - - init(); /* initialize memory for translation */ - - /* - * Load the data bases of information about run-time routines and - * determine what libraries are needed for linking (these libraries - * go before any specified on the command line). - */ - db_lst = getenv("DBLIST"); - if (db_lst != NULL) - db_lst = salloc(db_lst); - s = db_lst; - while (s != NULL) { - db_lst = s; - while (isspace(*db_lst)) - ++db_lst; - if (*db_lst == '\0') - break; - for (s = db_lst; !isspace(*s) && *s != '\0'; ++s) - ; - if (*s == '\0') - s = NULL; - else - *s++ = '\0'; - readdb(db_lst); - addlib(salloc(makename(buf,SourceDir, db_lst, LibSuffix))); - } - db_path = (char *)alloc((unsigned int)strlen(refpath) + strlen(db_name) + 1); - strcpy(db_path, refpath); - strcat(db_path, db_name); - readdb(db_path); - addlib(salloc(makename(buf,SourceDir, db_path, LibSuffix))); - - /* - * Scan the rest of the command line for file name arguments. - */ - while (optind < argc) { - if (strcmp(argv[optind],"-x") == 0) /* stop at -x */ - break; - else if (strcmp(argv[optind],"-") == 0) - src_file("-"); /* "-" means standard input */ - else if (argv[optind][0] == '-') - addlib(argv[optind]); /* assume linker option */ - else { - fp = fparse(argv[optind]); /* parse file name */ - if (*fp->ext == '\0' || smatch(fp->ext, SourceSuffix)) { - makename(buf,SourceDir,argv[optind], SourceSuffix); - src_file(buf); - } - else - /* - * Assume all files that are not Icon source go to linker. - */ - addlib(argv[optind]); - } - optind++; - } - - if (srclst == NULL) - usage(); /* error -- no files named */ - - if (pponly) { - if (trans() == 0) - exit (EXIT_FAILURE); - else - exit (EXIT_SUCCESS); - } - - if (ofile == NULL) { /* if no -o file, synthesize a name */ - if (strcmp(srclst->name,"-") == 0) - ofile = salloc(makename(buf,TargetDir,"stdin",ExecSuffix)); - else - ofile = salloc(makename(buf,TargetDir,srclst->name,ExecSuffix)); - } else { /* add extension if necessary */ - fp = fparse(ofile); - if (*fp->ext == '\0' && *ExecSuffix != '\0') - ofile = salloc(makename(buf,NULL,ofile,ExecSuffix)); - } - - /* - * Make name of intermediate C files. - */ - cfile = salloc(makename(buf,TargetDir,ofile,CSuffix)); - hfile = salloc(makename(buf,TargetDir,ofile,HSuffix)); - - codefile = open_out(cfile); - fprintf(codefile, "#include \"%s\"\n", hfile); - - inclfile = open_out(hfile); - fprintf(inclfile, "#define COMPILER 1\n"); - - incl_path = (char *)alloc((unsigned int)(strlen(refpath) + - strlen(incl_file) + 1)); - strcpy(incl_path, refpath); - strcat(incl_path, incl_file); - fprintf(inclfile,"#include \"%s\"\n", incl_path); - - /* - * Translate .icn files to make C file. - */ - if ((verbose > 0) && !just_type_trace) - report("Translating to C"); - - errors = trans(); - if ((errors > 0) || just_type_trace) { /* exit if errors seen */ - rmfile(cfile); - rmfile(hfile); - if (errors > 0) - exit(EXIT_FAILURE); - else exit(EXIT_SUCCESS); - } - - fclose(codefile); - fclose(inclfile); - - /* - * Compile and link C file. - */ - if (no_c_comp) /* exit if no C compile wanted */ - exit(EXIT_SUCCESS); - - if (verbose > 0) - report("Compiling and linking C code"); - - ret_code = ccomp(cfile, ofile); - if (ret_code == EXIT_FAILURE) { - fprintf(stderr, "*** C compile and link failed ***\n"); - rmfile(ofile); - } - - /* - * Finish by removing C files. - */ - rmfile(cfile); - rmfile(hfile); - rmfile(makename(buf,TargetDir,cfile,ObjSuffix)); - - if (ret_code == EXIT_SUCCESS && optind < argc) { - if (verbose > 0) - report("Executing"); - execute (ofile, argv+optind+1); - } - - return ret_code; - } - -/* - * execute - execute compiled Icon program - */ -static void execute(ofile,args) -char *ofile, **args; - { - - int n; - char **argv, **p; - char buf[MaxPath]; /* file name construction buffer */ - - ofile = salloc(makename(buf,"./",ofile,ExecSuffix)); - - for (n = 0; args[n] != NULL; n++) /* count arguments */ - ; - p = argv = (char **)alloc((unsigned int)((n + 2) * sizeof(char *))); - - *p++ = ofile; /* set executable file */ - - while (*p++ = *args++) /* copy args into argument vector */ - ; - *p = NULL; - - execvp(ofile,argv); - quitf("could not run %s",ofile); - } - -/* - * Report phase. - */ -static void report(s) -char *s; - { - fprintf(stderr,"%s:\n",s); - } - -/* - * rmfile - remove a file - */ - -static void rmfile(fname) -char *fname; - { - remove(fname); - } - -/* - * open_out - open a C output file and write identifying information - * to the front. - */ -static FILE *open_out(fname) -char *fname; - { - FILE *f; - static char *ident = "/*ICONC*/"; - int c; - int i; - - /* - * If the file already exists, make sure it is old output from iconc - * before overwriting it. Note, this test doesn't work if the file - * is writable but not readable. - */ - f = fopen(fname, "r"); - if (f != NULL) { - for (i = 0; i < (int)strlen(ident); ++i) { - c = getc(f); - if (c == EOF) - break; - if ((char)c != ident[i]) - quitf("%s not in iconc format; rename or delete, and rerun", fname); - } - fclose(f); - } - - f = fopen(fname, "w"); - if (f == NULL) - quitf("cannot create %s", fname); - fprintf(f, "%s\n", ident); /* write "belongs to iconc" comment */ - id_comment(f); /* write detailed comment for human readers */ - fflush(f); - return f; - } - -/* - * Print an error message if called incorrectly. The message depends - * on the legal options for this system. - */ -static void usage() - { - fprintf(stderr,"usage: %s %s file ... [-x args]\n", progname, CUsage); - exit(EXIT_FAILURE); - } diff --git a/src/iconc/cmem.c b/src/iconc/cmem.c deleted file mode 100644 index 720a495..0000000 --- a/src/iconc/cmem.c +++ /dev/null @@ -1,114 +0,0 @@ -/* - * cmem.c -- memory initialization and allocation for the translator. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" - -struct centry *chash[CHSize]; /* hash area for constant table */ -struct fentry *fhash[FHSize]; /* hash area for field table */ -struct gentry *ghash[GHSize]; /* hash area for global table */ - -struct implement *bhash[IHSize]; /* hash area for built-in functions */ -struct implement *khash[IHSize]; /* hash area for keywords */ -struct implement *ohash[IHSize]; /* hash area for operators */ - -struct implement *spec_op[NumSpecOp]; /* table of ops with special syntax */ - -char pre[PrfxSz] = {'0', '0', '0'}; /* initial function name prefix */ - -extern struct str_buf lex_sbuf; - - -/* - * init - initialize memory for the translator - */ - -void init() -{ - int i; - - init_str(); - init_sbuf(&lex_sbuf); - - /* - * Zero out the hash tables. - */ - for (i = 0; i < CHSize; i++) - chash[i] = NULL; - for (i = 0; i < FHSize; i++) - fhash[i] = NULL; - for (i = 0; i < GHSize; i++) - ghash[i] = NULL; - for (i = 0; i < IHSize; i++) { - bhash[i] = NULL; - khash[i] = NULL; - ohash[i] = NULL; - } - - /* - * Clear table of operators with non-standard operator syntax. - */ - for (i = 0; i < NumSpecOp; ++i) - spec_op[i] = NULL; - } - -/* - * init_proc - add a new entry on front of procedure list. - */ -void init_proc(name) -char *name; - { - register struct pentry *p; - int i; - struct gentry *sym_ent; - - p = NewStruct(pentry); - p->name = name; - nxt_pre(p->prefix, pre, PrfxSz); - p->prefix[PrfxSz] = '\0'; - p->nargs = 0; - p->args = NULL; - p->ndynam = 0; - p->dynams = NULL; - p->nstatic = 0; - p->has_coexpr = 0; - p->statics = NULL; - p->ret_flag = DoesRet | DoesFail | DoesSusp; /* start out pessimistic */ - p->arg_lst = 0; - p->lhash = - (struct lentry **)alloc((unsigned int)((LHSize)*sizeof(struct lentry *))); - for (i = 0; i < LHSize; i++) - p->lhash[i] = NULL; - p->next = proc_lst; - proc_lst = p; - sym_ent = instl_p(name, F_Proc); - sym_ent->val.proc = proc_lst; - } - -/* - * init_rec - add a new entry on the front of the record list. - */ -void init_rec(name) -char *name; - { - register struct rentry *r; - struct gentry *sym_ent; - static int rec_num = 0; - - r = NewStruct(rentry); - r->name = name; - nxt_pre(r->prefix, pre, PrfxSz); - r->prefix[PrfxSz] = '\0'; - r->rec_num = rec_num++; - r->nfields = 0; - r->fields = NULL; - r->next = rec_lst; - rec_lst = r; - sym_ent= instl_p(name, F_Record); - sym_ent->val.rec = r; - } diff --git a/src/iconc/codegen.c b/src/iconc/codegen.c deleted file mode 100644 index 8ca5bd1..0000000 --- a/src/iconc/codegen.c +++ /dev/null @@ -1,1918 +0,0 @@ -/* - * codegen.c - routines to write out C code. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "cproto.h" - -#ifndef LoopThreshold -#define LoopThreshold 7 -#endif /* LoopThreshold */ - -/* - * MinOne - arrays sizes must be at least 1. - */ -#define MinOne(n) ((n) > 0 ? (n) : 1) - -/* - * ChkSeqNum - make sure a label has been given a sequence number. - */ -#define ChkSeqNum(x) if ((x)->SeqNum == 0) (x)->SeqNum = ++lbl_seq_num - -/* - * ChkBound - for a given procedure, signals that transfer control to a - * bounding label all use the same signal number. - */ -#define ChkBound(x) (((x)->LabFlg & Bounding) ? bound_sig : (x)) - -/* - * When a switch statement for signal handling is optimized, there - * are three possible forms of default clauses. - */ -#define DfltNone 0 /* no default clause */ -#define DfltBrk 1 /* default is just a break */ -#define DfltRetSig 2 /* default is to return the signal from the call */ - -/* - * Prototypes for static functions. - */ -static int arg_nms (struct lentry *lptr, int prt); -static void bi_proc (char *name, struct implement *ip); -static void chkforgn (int outer); -static int dyn_nms (struct lentry *lptr, int prt); -static void fldnames (struct fldname *fields); -static void fnc_blk (struct gentry *gptr); -static void frame (int outer); -static void good_clsg (struct code *call, int outer); -static void initpblk (FILE *f, int c, char *prefix, char *name, - int nquals, int nparam, int ndynam, int nstatic, - int frststat); -static char *is_builtin (struct gentry *gptr); -static void proc_blk (struct gentry *gptr, int init_glbl); -static void prt_ary (struct code *cd, int outer); -static void prt_cond (struct code *cond); -static void prt_cont (struct c_fnc *cont); -static void prt_var (struct lentry *var, int outer); -static void prtcall (struct code *call, int outer); -static void prtcode (struct code *cd, int outer); -static void prtpccall (int outer); -static void rec_blk (struct gentry *gptr, int init_glbl); -static void smpl_clsg (struct code *call, int outer); -static void stat_nms (struct lentry *lptr, int prt); -static void val_loc (struct val_loc *rslt, int outer); - -static int n_stat = -1; /* number of static variables */ - -/* - * var_dcls - produce declarations necessary to implement variables - * and to initialize globals and statics: procedure blocks, procedure - * frames, record blocks, declarations for globals and statics, the - * C main program. - */ -void var_dcls() - { - register int i; - register struct gentry *gptr; - struct gentry *gbl_main; - struct pentry *prc_main; - int n_glob = 0; - int flag; - int init_glbl; - int first; - char *pfx; - - /* - * Output initialized array of descriptors for globals. - */ - fprintf(codefile, "\nstatic struct {word dword; union block *vword;}"); - fprintf(codefile, " init_globals[NGlobals] = {\n"); - prc_main = NULL; - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag & ~(F_Global | F_StrInv); - if (strcmp(gptr->name, "main") == 0 && (gptr->flag & F_Proc)) { - /* - * Remember main procedure. - */ - gbl_main = gptr; - prc_main = gbl_main->val.proc; - } - if (flag == 0) { - /* - * Ordinary variable. - */ - gptr->index = n_glob++; - fprintf(codefile, " {D_Null},\n"); - } - else { - /* - * Procedure, function, or record constructor. If the variable - * has not been optimized away, initialize the it to reference - * the procedure block. - */ - if (flag & F_SmplInv) { - init_glbl = 0; - flag &= ~(uword)F_SmplInv; - } - else { - init_glbl = 1; - gptr->index = n_glob++; - fprintf(codefile, " {D_Proc, "); - } - switch (flag) { - case F_Proc: - proc_blk(gptr, init_glbl); - break; - case F_Builtin: - if (init_glbl) - fnc_blk(gptr); - break; - case F_Record: - rec_blk(gptr, init_glbl); - } - } - } - if (n_glob == 0) - fprintf(codefile, " {D_Null} /* place holder */\n"); - fprintf(codefile, " };\n"); - - if (prc_main == NULL) { - nfatal(NULL, "main procedure missing", NULL); - return; - } - - /* - * Output array of descriptors initialized to the names of the - * global variables that have not been optimized away. - */ - if (n_glob == 0) - fprintf(codefile, "\nstruct sdescrip init_gnames[1];\n"); - else { - fprintf(codefile, "\nstruct sdescrip init_gnames[NGlobals] = {\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) - if (!(gptr->flag & F_SmplInv)) - fprintf(codefile, " {%d, \"%s\"},\n", strlen(gptr->name), - gptr->name); - fprintf(codefile, " };\n"); - } - - /* - * Output array of pointers to builtin functions that correspond to - * names of the global variables. - */ - if (n_glob == 0) - fprintf(codefile, "\nstruct b_proc *builtins[1];\n"); - else { - fprintf(codefile, "\nstruct b_proc *builtins[NGlobals] = {\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) - if (!(gptr->flag & F_SmplInv)) { - /* - * Need to output *something* to stay in step with other arrays. - */ - if (pfx = is_builtin(gptr)) { - fprintf(codefile, " (struct b_proc *)&BF%c%c_%s,\n", - pfx[0], pfx[1], gptr->name); - } - else - fprintf(codefile, " 0,\n"); - } - fprintf(codefile, " };\n"); - } - - /* - * Output C main function that initializes the run-time system and - * calls the main procedure. - */ - fprintf(codefile, "\n"); - fprintf(codefile, "int main(argc, argv)\n"); - fprintf(codefile, "int argc;\n"); - fprintf(codefile, "char **argv;\n"); - fprintf(codefile, " {\n"); - - /* - * If the main procedure requires a command-line argument list, we - * need a place to construct the Icon argument list. - */ - if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { - fprintf(codefile, " struct {\n"); - fprintf(codefile, " struct tend_desc *previous;\n"); - fprintf(codefile, " int num;\n"); - fprintf(codefile, " struct descrip arg_lst;\n"); - fprintf(codefile, " } t;\n"); - fprintf(codefile, "\n"); - } - - /* - * Produce code to initialize run-time system variables. Some depend - * on compiler options. - */ - fprintf(codefile, " op_tbl = (struct b_proc *)init_op_tbl;\n"); - fprintf(codefile, " globals = (dptr)init_globals;\n"); - fprintf(codefile, " eglobals = &globals[%d];\n", n_glob); - fprintf(codefile, " gnames = (dptr)init_gnames;\n"); - fprintf(codefile, " egnames = &gnames[%d];\n", n_glob); - fprintf(codefile, " estatics = &statics[%d];\n", n_stat + 1); - if (debug_info) - fprintf(codefile, " debug_info = 1;\n"); - else - fprintf(codefile, " debug_info = 0;\n"); - if (line_info) { - fprintf(codefile, " line_info = 1;\n"); - fprintf(codefile, " file_name = \"\";\n"); - fprintf(codefile, " line_num = 0;\n"); - } - else - fprintf(codefile, " line_info = 0;\n"); - if (err_conv) - fprintf(codefile, " err_conv = 1;\n"); - else - fprintf(codefile, " err_conv = 0;\n"); - if (largeints) - fprintf(codefile, " largeints = 1;\n"); - else - fprintf(codefile, " largeints = 0;\n"); - - /* - * Produce code to call the routine to initialize the runtime system. - */ - if (trace) - fprintf(codefile, " init(*argv, &argc, argv, -1);\n"); - else - fprintf(codefile, " init(*argv, &argc, argv, 0);\n"); - fprintf(codefile, "\n"); - - /* - * If the main procedure requires an argument list (perhaps because - * it uses standard, rather than tailored calling conventions), - * set up the argument list. - */ - if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { - fprintf(codefile, " t.arg_lst = nulldesc;\n"); - fprintf(codefile, " t.num = 1;\n"); - fprintf(codefile, " t.previous = NULL;\n"); - fprintf(codefile, " tend = (struct tend_desc *)&t;\n"); - if (prc_main->nargs == 0) - fprintf(codefile, - " /* main() takes no arguments: construct no list */\n"); - else - fprintf(codefile, " cmd_line(argc, argv, &t.arg_lst);\n"); - fprintf(codefile, "\n"); - } - else - fprintf(codefile, " tend = NULL;\n"); - - if (gbl_main->flag & F_SmplInv) { - /* - * procedure main only has a simplified implementation if it - * takes either 0 or 1 argument. - */ - first = 1; - if (prc_main->nargs == 0) - fprintf(codefile, " P%s_main(", prc_main->prefix); - else { - fprintf(codefile, " P%s_main(&t.arg_lst", prc_main->prefix); - first = 0; - } - if (prc_main->ret_flag & (DoesRet | DoesSusp)) { - if (!first) - fprintf(codefile, ", "); - fprintf(codefile, "&trashcan"); - first = 0; - } - if (prc_main->ret_flag & DoesSusp) - fprintf(codefile, ", (continuation)NULL"); - fprintf(codefile, ");\n"); - } - else /* the main procedure uses standard calling conventions */ - fprintf(codefile, - " P%s_main(1, &t.arg_lst, &trashcan, (continuation)NULL);\n", - prc_main->prefix); - fprintf(codefile, " \n"); - fprintf(codefile, " c_exit(EXIT_SUCCESS);\n"); - fprintf(codefile, " }\n"); - - /* - * Output to header file definitions related to global and static - * variables. - */ - fprintf(inclfile, "\n"); - if (n_glob == 0) { - fprintf(inclfile, "#define NGlobals 1\n"); - fprintf(inclfile, "int n_globals = 0;\n"); - } - else { - fprintf(inclfile, "#define NGlobals %d\n", n_glob); - fprintf(inclfile, "int n_globals = NGlobals;\n"); - } - ++n_stat; - fprintf(inclfile, "\n"); - fprintf(inclfile, "int n_statics = %d;\n", n_stat); - fprintf(inclfile, "struct descrip statics[%d]", MinOne(n_stat)); - if (n_stat > 0) { - fprintf(inclfile, " = {\n"); - for (i = 0; i < n_stat; ++i) - fprintf(inclfile, " {D_Null},\n"); - fprintf(inclfile, " };\n"); - } - else - fprintf(inclfile, ";\n"); - } - -/* - * proc_blk - create procedure block and initialize global variable, also - * compute offsets for local procedure variables. - */ -static void proc_blk(gptr, init_glbl) -struct gentry *gptr; -int init_glbl; - { - struct pentry *p; - register char *name; - int nquals; - - name = gptr->name; - p = gptr->val.proc; - - /* - * If we don't initialize a global variable for this procedure, we - * need only compute offsets for variables. - */ - if (init_glbl) { - fprintf(codefile, "(union block *)&BP%s_%s},\n", p->prefix, name); - nquals = 1 + Abs(p->nargs) + p->ndynam + p->nstatic; - fprintf(inclfile, "\n"); - fprintf(inclfile, "static int P%s_%s (int r_nargs, dptr r_args,", - p->prefix, name); - fprintf(inclfile, "dptr r_rslt, continuation r_s_cont);\n"); - initpblk(inclfile, 'P', p->prefix, name, nquals, p->nargs, p->ndynam, - p->nstatic, n_stat + 1); - fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); - } - arg_nms(p->args, init_glbl); - p->tnd_loc = dyn_nms(p->dynams, init_glbl); - stat_nms(p->statics, init_glbl); - if (init_glbl) - fprintf(inclfile, " }};\n"); - } - -/* - * arg_nms - compute offsets of arguments and, if needed, output the - * initializer for a descriptor for the argument name. - */ -static int arg_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - register int n; - - if (lptr == NULL) - return 0; - n = arg_nms(lptr->next, prt); - lptr->val.index = n; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - return n + 1; - } - -/* - * dyn_nms - compute offsets of dynamic locals and, if needed, output the - * initializer for a descriptor for the variable name. - */ -static int dyn_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - register int n; - - if (lptr == NULL) - return 0; - n = dyn_nms(lptr->next, prt); - lptr->val.index = n; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - return n + 1; - } - -/* - * stat_nams - compute offsets of static locals and, if needed, output the - * initializer for a descriptor for the variable name. - */ -static void stat_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - if (lptr == NULL) - return; - stat_nms(lptr->next, prt); - lptr->val.index = ++n_stat; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - } - -/* - * is_builtin - check if a global names or hides a builtin, returning prefix. - * If it hides one, we must also generate the prototype and block here. - */ -static char *is_builtin(gptr) -struct gentry *gptr; - { - struct implement *iptr; - - if (!(gptr->flag & F_StrInv)) /* if not eligible for string invoc */ - return 0; - if (gptr->flag & F_Builtin) /* if global *is* a builtin */ - return gptr->val.builtin->prefix; - iptr = db_ilkup(gptr->name, bhash); - if (iptr == NULL) /* if no builtin by this name */ - return NULL; - bi_proc(gptr->name, iptr); /* output prototype and proc block */ - return iptr->prefix; - } - -/* - * fnc_blk - output vword of descriptor for a built-in function and its - * procedure block. - */ -static void fnc_blk(gptr) -struct gentry *gptr; - { - struct implement *iptr; - char *name, *pfx; - - name = gptr->name; - iptr = gptr->val.builtin; - pfx = iptr->prefix; - /* - * output prototype and procedure block to inclfile. - */ - bi_proc(name, iptr); - /* - * vword of descriptor references the procedure block. - */ - fprintf(codefile, "(union block *)&BF%c%c_%s}, \n", pfx[0], pfx[1], name); - } - -/* - * bi_proc - output prototype and procedure block for builtin function. - */ -static void bi_proc(name, ip) -char *name; - struct implement *ip; - { - int nargs; - char prefix[3]; - - prefix[0] = ip->prefix[0]; - prefix[1] = ip->prefix[1]; - prefix[2] = '\0'; - nargs = ip->nargs; - if (nargs > 0 && ip->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; - fprintf(inclfile, "\n"); - implproto(ip); - initpblk(inclfile, 'F', prefix, name, 1, nargs, -1, 0, 0); - fprintf(inclfile, "{%d, \"%s\"}}};\n", strlen(name), name); - } - -/* - * rec_blk - if needed, output vword of descriptor for a record - * constructor and output its procedure block. - */ -static void rec_blk(gptr, init_glbl) -struct gentry *gptr; -int init_glbl; - { - struct rentry *r; - register char *name; - int nfields; - - name = gptr->name; - r = gptr->val.rec; - nfields = r->nfields; - - /* - * If the variable is not optimized away, output vword of descriptor. - */ - if (init_glbl) - fprintf(codefile, "(union block *)&BR%s_%s},\n", r->prefix, name); - - fprintf(inclfile, "\n"); - /* - * Prototype for C function implementing constructor. If no optimizations - * have been performed on the variable, the standard calling conventions - * are used and we need a continuation parameter. - */ - fprintf(inclfile, - "static int R%s_%s (int r_nargs, dptr r_args, dptr r_rslt", - r->prefix, name); - if (init_glbl) - fprintf(inclfile, ", continuation r_s_cont"); - fprintf(inclfile, ");\n"); - - /* - * Procedure block, including record name and field names. - */ - initpblk(inclfile, 'R', r->prefix, name, nfields + 1, nfields, -2, - r->rec_num, 1); - fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); - fldnames(r->fields); - fprintf(inclfile, " }};\n"); - } - - -/* - * fldnames - output the initializer for a descriptor for the field name. - */ -static void fldnames(fields) -struct fldname *fields; - { - register char *name; - - if (fields == NULL) - return; - fldnames(fields->next); - name = fields->name; - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(name), name); - } - -/* - * implproto - print prototype for function implementing a run-time operation. - */ -void implproto(ip) -struct implement *ip; - { - if (ip->iconc_flgs & ProtoPrint) - return; /* only print prototype once */ - fprintf(inclfile, "int %c%c%c_%s ", ip->oper_typ, ip->prefix[0], - ip->prefix[1], ip->name); - fprintf(inclfile, "(int r_nargs, dptr r_args, dptr r_rslt, "); - fprintf(inclfile,"continuation r_s_cont);\n"); - ip->iconc_flgs |= ProtoPrint; - } - -/* - * const_blks - output blocks for cset and real constants. - */ -void const_blks() - { - register int i; - register struct centry *cptr; - - fprintf(inclfile, "\n"); - for (i = 0; i < CHSize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { - switch (cptr->flag) { - case F_CsetLit: - nxt_pre(cptr->prefix, pre, PrfxSz); - cptr->prefix[PrfxSz] = '\0'; - fprintf(inclfile, "struct b_cset BDC%s = ", cptr->prefix); - cset_init(inclfile, cptr->u.cset); - break; - case F_RealLit: - nxt_pre(cptr->prefix, pre, PrfxSz); - cptr->prefix[PrfxSz] = '\0'; - fprintf(inclfile, "struct b_real BDR%s = {T_Real, %s};\n", - cptr->prefix, cptr->image); - break; - } - } - } - -/* - * reccnstr - output record constructors. - */ -void recconstr(r) -struct rentry *r; - { - register char *name; - int optim; - int nfields; - - if (r == NULL) - return; - recconstr(r->next); - - name = r->name; - nfields = r->nfields; - - /* - * Does this record constructor use optimized calling conventions? - */ - optim = glookup(name)->flag & F_SmplInv; - - fprintf(codefile, "\n"); - fprintf(codefile, "static int R%s_%s(r_nargs, r_args, r_rslt", r->prefix, - name); - if (!optim) - fprintf(codefile, ", r_s_cont"); /* continuation is passed */ - fprintf(codefile, ")\n"); - fprintf(codefile, "int r_nargs;\n"); - fprintf(codefile, "dptr r_args;\n"); - fprintf(codefile, "dptr r_rslt;\n"); - if (!optim) - fprintf(codefile, "continuation r_s_cont;\n"); - fprintf(codefile, " {\n"); - fprintf(codefile, " register int i;\n"); - fprintf(codefile, " register struct b_record *rp;\n"); - fprintf(codefile, "\n"); - fprintf(codefile, " rp = alcrecd(%d, (union block *)&BR%s_%s);\n", - nfields, r->prefix, name); - fprintf(codefile, " if (rp == NULL) {\n"); - fprintf(codefile, " err_msg(307, NULL);\n"); - if (err_conv) - fprintf(codefile, " return A_Resume;\n"); - fprintf(codefile, " }\n"); - fprintf(codefile, " for (i = %d; i >= 0; i--)\n", nfields - 1); - fprintf(codefile, " if (i < r_nargs)\n"); - fprintf(codefile, " deref(&r_args[i], &rp->fields[i]);\n"); - fprintf(codefile, " else\n"); - fprintf(codefile, " rp->fields[i] = nulldesc;\n"); - fprintf(codefile, " r_rslt->vword.bptr = (union block *)rp;\n"); - fprintf(codefile, " r_rslt->dword = D_Record;\n"); - fprintf(codefile, " return A_Continue;\n"); - fprintf(codefile, " }\n"); - } - -/* - * outerfnc - output code for the outer function implementing a procedure. - */ -void outerfnc(fnc) -struct c_fnc *fnc; - { - char *prefix; - char *name; - char *cnt_var; - char *sep; - int ntend; - int first_arg; - int nparms; - int optim; /* optimized interface: no arg list adjustment */ - int ret_flag; -#ifdef OptimizeLoop - int i; -#endif /* OptimizeLoop */ - - prefix = cur_proc->prefix; - name = cur_proc->name; - ntend = cur_proc->tnd_loc + num_tmp; - ChkPrefix(fnc->prefix); - optim = glookup(name)->flag & F_SmplInv; - nparms = Abs(cur_proc->nargs); - ret_flag = cur_proc->ret_flag; - - fprintf(codefile, "\n"); - if (optim) { - /* - * Arg list adjustment and dereferencing are done at call site. - * Use simplified interface. Output both function header and - * prototype. - */ - sep = ""; - fprintf(inclfile, "static int P%s_%s (", prefix, name); - fprintf(codefile, "static int P%s_%s(", prefix, name); - if (nparms != 0) { - fprintf(inclfile, "dptr r_args"); - fprintf(codefile, "r_args"); - sep = ", "; - } - if (ret_flag & (DoesRet | DoesSusp)) { - fprintf(inclfile, "%sdptr r_rslt", sep); - fprintf(codefile, "%sr_rslt", sep); - sep = ", "; - } - if (ret_flag & DoesSusp) { - fprintf(inclfile, "%scontinuation r_s_cont", sep); - fprintf(codefile, "%sr_s_cont", sep); - sep = ", "; - } - if (*sep == '\0') - fprintf(inclfile, "void"); - fprintf(inclfile, ");\n"); - fprintf(codefile, ")\n"); - if (nparms != 0) - fprintf(codefile, "dptr r_args;\n"); - if (ret_flag & (DoesRet | DoesSusp)) - fprintf(codefile, "dptr r_rslt;\n"); - if (ret_flag & DoesSusp) - fprintf(codefile, "continuation r_s_cont;\n"); - } - else { - /* - * General invocation interface. Output function header; prototype has - * already been produced. - */ - fprintf(codefile, - "static int P%s_%s(r_nargs, r_args, r_rslt, r_s_cont)\n", prefix, - name); - fprintf(codefile, "int r_nargs;\n"); - fprintf(codefile, "dptr r_args;\n"); - fprintf(codefile, "dptr r_rslt;\n"); - fprintf(codefile, "continuation r_s_cont;\n"); - } - - fprintf(codefile, "{\n"); - fprintf(codefile, " struct PF%s_%s r_frame;\n", prefix, name); - fprintf(codefile, " register int r_signal;\n"); - fprintf(codefile, " int i;\n"); - if (Type(Tree1(cur_proc->tree)) != N_Empty) - fprintf(codefile, " static int first_time = 1;"); - fprintf(codefile, "\n"); - fprintf(codefile, " r_frame.old_pfp = pfp;\n"); - fprintf(codefile, " pfp = (struct p_frame *)&r_frame;\n"); - fprintf(codefile, " r_frame.old_argp = glbl_argp;\n"); - if (!optim || ret_flag & (DoesRet | DoesSusp)) - fprintf(codefile, " r_frame.rslt = r_rslt;\n"); - else - fprintf(codefile, " r_frame.rslt = NULL;\n"); - if (!optim || ret_flag & DoesSusp) - fprintf(codefile, " r_frame.succ_cont = r_s_cont;\n"); - else - fprintf(codefile, " r_frame.succ_cont = NULL;\n"); - fprintf(codefile, "\n"); -#ifdef OptimizeLoop - if (ntend > 0) { - if (ntend < LoopThreshold) - for (i=0; i < ntend ;i++) - fprintf(codefile, " r_frame.tend.d[%d] = nulldesc;\n", i); - else { - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); - fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); - } - } -#else /* OptimizeLoop */ - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); - fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); -#endif /* OptimizeLoop */ - if (optim) { - /* - * Dereferencing and argument list adjustment is done at the call - * site. There is not much to do here. - */ - if (nparms == 0) - fprintf(codefile, " glbl_argp = NULL;\n"); - else - fprintf(codefile, " glbl_argp = r_args;\n"); - } - else { - /* - * Dereferencing and argument list adjustment must be done by - * the procedure itself. - */ - first_arg = ntend; - ntend += nparms; - if (cur_proc->nargs < 0) { - /* - * varargs - construct a list into the last argument. - */ - nparms -= 1; - if (nparms == 0) - cnt_var = "r_nargs"; - else { - fprintf(codefile, " i = r_nargs - %d;\n", nparms); - cnt_var = "i"; - } - fprintf(codefile," if (%s <= 0)\n", cnt_var); - fprintf(codefile," varargs(NULL, 0, &r_frame.tend.d[%d]);\n", - first_arg + nparms); - fprintf(codefile," else\n"); - fprintf(codefile, - " varargs(&r_args[%d], %s, &r_frame.tend.d[%d]);\n", nparms, - cnt_var, first_arg + nparms); - } - if (nparms > 0) { - /* - * Output code to dereference argument or supply default null - * value. - */ -#ifdef OptimizeLoop - fprintf(codefile, " for (i = 0; i < r_nargs ; ++i)\n"); - fprintf(codefile, " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", first_arg); - fprintf(codefile, " for(i = r_nargs; i < %d ; ++i)\n", nparms); - fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", - first_arg); -#else /* OptimizeLoop */ - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", nparms); - fprintf(codefile, " if (i < r_nargs)\n"); - fprintf(codefile, - " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", - first_arg); - fprintf(codefile, " else\n"); - fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", - first_arg); -#endif /* OptimizeLoop */ - } - fprintf(codefile, " glbl_argp = &r_frame.tend.d[%d];\n", first_arg); - } - fprintf(codefile, " r_frame.tend.num = %d;\n", ntend); - fprintf(codefile, " r_frame.tend.previous = tend;\n"); - fprintf(codefile, " tend = (struct tend_desc *)&r_frame.tend;\n"); - if (line_info) { - fprintf(codefile, " r_frame.debug.old_line = line_num;\n"); - fprintf(codefile, " r_frame.debug.old_fname = file_name;\n"); - } - if (debug_info) { - fprintf(codefile, " r_frame.debug.proc = (struct b_proc *)&BP%s_%s;\n", - prefix, name); - fprintf(codefile, " if (k_trace) ctrace();\n"); - fprintf(codefile, " ++k_level;\n\n"); - } - fprintf(codefile, "\n"); - - /* - * Output definition for procedure frame. - */ - prt_frame(prefix, ntend, num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Output code to implement procedure body. - */ - prtcode(&(fnc->cd), 1); - fprintf(codefile, " }\n"); - } - -/* - * prt_fnc - output C function that implements a continuation. - */ -void prt_fnc(fnc) -struct c_fnc *fnc; - { - struct code *sig; - char *name; - char *prefix; - - if (fnc->flag & CF_SigOnly) { - /* - * This function only returns a signal. A shared function is used in - * its place. Make sure that function has been printed. - */ - sig = fnc->cd.next->SigRef->sig; - if (sig->cd_id != C_Resume) { - sig = ChkBound(sig); - if (!(sig->LabFlg & FncPrtd)) { - ChkSeqNum(sig); - fprintf(inclfile, "static int sig_%d (void);\n", - sig->SeqNum); - - fprintf(codefile, "\n"); - fprintf(codefile, "static int sig_%d()\n", sig->SeqNum); - fprintf(codefile, " {\n"); - fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, - sig->Desc); - fprintf(codefile, " }\n"); - sig->LabFlg |= FncPrtd; - } - } - } - else { - ChkPrefix(fnc->prefix); - prefix = fnc->prefix; - name = cur_proc->name; - - fprintf(inclfile, "static int P%s_%s (void);\n", prefix, name); - - fprintf(codefile, "\n"); - fprintf(codefile, "static int P%s_%s()\n", prefix, name); - fprintf(codefile, " {\n"); - if (fnc->flag & CF_Coexpr) - fprintf(codefile, "#ifdef Coexpr\n"); - - prefix = fnc->frm_prfx; - - fprintf(codefile, " register int r_signal;\n"); - fprintf(codefile, " register struct PF%s_%s *r_pfp;\n", prefix, name); - fprintf(codefile, "\n"); - fprintf(codefile, " r_pfp = (struct PF%s_%s *)pfp;\n", prefix, name); - prtcode(&(fnc->cd), 0); - if (fnc->flag & CF_Coexpr) { - fprintf(codefile, "#else\t\t\t\t\t/* Coexpr */\n"); - fprintf(codefile, " fatalerr(401, NULL);\n"); - fprintf(codefile, "#endif\t\t\t\t\t/* Coexpr */\n"); - } - fprintf(codefile, " }\n"); - } - } - -/* - * prt_frame - output the definition for a procedure frame. - */ -void prt_frame(prefix, ntend, n_itmp, n_dtmp, n_sbuf, n_cbuf) -char *prefix; -int ntend; -int n_itmp; -int n_dtmp; -int n_sbuf; -int n_cbuf; - { - int i; - - /* - * Output standard part of procedure frame including tended - * descriptors. - */ - fprintf(inclfile, "\n"); - fprintf(inclfile, "struct PF%s_%s {\n", prefix, cur_proc->name); - fprintf(inclfile, " struct p_frame *old_pfp;\n"); - fprintf(inclfile, " dptr old_argp;\n"); - fprintf(inclfile, " dptr rslt;\n"); - fprintf(inclfile, " continuation succ_cont;\n"); - fprintf(inclfile, " struct {\n"); - fprintf(inclfile, " struct tend_desc *previous;\n"); - fprintf(inclfile, " int num;\n"); - fprintf(inclfile, " struct descrip d[%d];\n", MinOne(ntend)); - fprintf(inclfile, " } tend;\n"); - - if (line_info) { /* must be true if debug_info is true */ - fprintf(inclfile, " struct debug debug;\n"); - } - - /* - * Output declarations for the integer, double, string buffer, - * and cset buffer work areas of the frame. - */ - for (i = 0; i < n_itmp; ++i) - fprintf(inclfile, " word i%d;\n", i); - for (i = 0; i < n_dtmp; ++i) - fprintf(inclfile, " double d%d;\n", i); - if (n_sbuf > 0) - fprintf(inclfile, " char sbuf[%d][MaxCvtLen];", n_sbuf); - if (n_cbuf > 0) - fprintf(inclfile, " struct b_cset cbuf[%d];", n_cbuf); - fprintf(inclfile, " };\n"); - } - -/* - * prtcode - print a list of C code. - */ -static void prtcode(cd, outer) -struct code *cd; -int outer; - { - struct lentry *var; - struct centry *lit; - struct code *sig; - int n; - - for ( ; cd != NULL; cd = cd->next) { - switch (cd->cd_id) { - case C_Null: - break; - - case C_NamedVar: - /* - * Construct a reference to a named variable in a result - * location. - */ - var = cd->NamedVar; - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = D_Var;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.descptr = &"); - prt_var(var, outer); - fprintf(codefile, ";\n"); - break; - - case C_CallSig: - /* - * Call to C function that returns a signal along with signal - * handling code. - */ - if (opt_sgnl) - good_clsg(cd, outer); - else - smpl_clsg(cd, outer); - break; - - case C_RetSig: - /* - * Return a signal. - */ - sig = cd->SigRef->sig; - if (sig->cd_id == C_Resume) - fprintf(codefile, " return A_Resume;\n"); - else { - sig = ChkBound(sig); - ChkSeqNum(sig); - fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, - sig->Desc); - } - break; - - case C_Goto: - /* - * goto label. - */ - ChkSeqNum(cd->Lbl); - fprintf(codefile, " goto L%d /* %s */;\n", cd->Lbl->SeqNum, - cd->Lbl->Desc); - break; - - case C_Label: - /* - * numbered label. - */ - if (cd->RefCnt > 0) { - ChkSeqNum(cd); - fprintf(codefile, "L%d: ; /* %s */\n", cd->SeqNum, cd->Desc); - } - break; - - case C_Lit: - /* - * Assign literal value to a result location. - */ - lit = cd->Literal; - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - switch (lit->flag) { - case F_CsetLit: - fprintf(codefile, ".dword = D_Cset;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.bptr = (union block *)&BDC%s;\n", - lit->prefix); - break; - case F_IntLit: - if (lit->u.intgr == -1) { - /* - * Large integer literal - output string and convert - * to integer. - */ - fprintf(codefile, ".vword.sptr = \"%s\";\n", lit->image); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = %d;\n", strlen(lit->image)); - fprintf(codefile, " cnv_int(&"); - val_loc(cd->Rslt, outer); - fprintf(codefile, ", &"); - val_loc(cd->Rslt, outer); - fprintf(codefile, ");\n"); - } - else { - /* - * Ordinary integer literal. - */ - fprintf(codefile, ".dword = D_Integer;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.integr = %ld;\n", lit->u.intgr); - } - break; - case F_RealLit: - fprintf(codefile, ".dword = D_Real;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.bptr = (union block *)&BDR%s;\n", - lit->prefix); - break; - case F_StrLit: - fprintf(codefile, ".vword.sptr = "); - if (lit->length == 0) { - /* - * Placing an empty string at the end of the string region - * allows some concatenation optimizations at run time. - */ - fprintf(codefile, "strfree;\n"); - n = 0; - } - else { - fprintf(codefile, "\""); - n = prt_i_str(codefile, lit->image, lit->length); - fprintf(codefile, "\";\n"); - } - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = %d;\n", n); - break; - } - break; - - case C_PFail: - /* - * Procedure failure - this code occurs once near the end of - * the procedure. - */ - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) failtrace();\n"); - } - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " pfp = r_frame.old_pfp;\n"); - fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); - fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); - } - fprintf(codefile, " return A_Resume;\n"); - break; - - case C_PRet: - /* - * Procedure return - this code occurs once near the end of - * the procedure. - */ - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) rtrace();\n"); - } - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " pfp = r_frame.old_pfp;\n"); - fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); - fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); - } - fprintf(codefile, " return A_Continue;\n"); - break; - - case C_PSusp: - /* - * Procedure suspend - call success continuation. - */ - prtpccall(outer); - break; - - case C_Break: - fprintf(codefile, " break;\n"); - break; - - case C_If: - /* - * C if statement. - */ - fprintf(codefile, " if ("); - prt_ary(cd->Cond, outer); - fprintf(codefile, ")\n "); - prtcode(cd->ThenStmt, outer); - break; - - case C_CdAry: - /* - * Array of code fragments. - */ - fprintf(codefile, " "); - prt_ary(cd, outer); - fprintf(codefile, "\n"); - break; - - case C_LBrack: - fprintf(codefile, " {\n"); - break; - - case C_RBrack: - fprintf(codefile, " }\n"); - break; - - case C_Create: - /* - * Code to create a co-expression and assign it to a result - * location. - */ - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile , ".vword.bptr = (union block *)create("); - prt_cont(cd->Cont); - fprintf(codefile, - ", (struct b_proc *)&BP%s_%s, %d, sizeof(word) * %d);\n", - cur_proc->prefix, cur_proc->name, cd->NTemps, cd->WrkSize); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = D_Coexpr;\n"); - break; - - case C_SrcLoc: - /* - * Update file name and line number information. - */ - if (cd->FileName != NULL) { - fprintf(codefile, " file_name = \""); - prt_i_str(codefile, cd->FileName, strlen(cd->FileName)); - fprintf(codefile, "\";\n"); - } - if (cd->LineNum != 0) - fprintf(codefile, " line_num = %d;\n", cd->LineNum); - break; - } - } - } - -/* - * prt_var - output C code to reference an Icon named variable. - */ -static void prt_var(var, outer) -struct lentry *var; -int outer; - { - switch (var->flag) { - case F_Global: - fprintf(codefile, "globals[%d]", var->val.global->index); - break; - case F_Static: - fprintf(codefile, "statics[%d]", var->val.index); - break; - case F_Dynamic: - frame(outer); - fprintf(codefile, ".tend.d[%d]", var->val.index); - break; - case F_Argument: - fprintf(codefile, "glbl_argp[%d]", var->val.index); - } - - /* - * Include an identifying comment. - */ - fprintf(codefile, " /* %s */", var->name); - } - -/* - * prt_ary - print an array of code fragments. - */ -static void prt_ary(cd, outer) -struct code *cd; -int outer; - { - int i; - - for (i = 0; cd->ElemTyp(i) != A_End; ++i) - switch (cd->ElemTyp(i)) { - case A_Str: - /* - * Simple C code in a string. - */ - fprintf(codefile, "%s", cd->Str(i)); - break; - case A_ValLoc: - /* - * Value location (usually variable of some sort). - */ - val_loc(cd->ValLoc(i), outer); - break; - case A_Intgr: - /* - * Integer. - */ - fprintf(codefile, "%d", cd->Intgr(i)); - break; - case A_ProcCont: - /* - * Current procedure call's success continuation. - */ - if (outer) - fprintf(codefile, "r_s_cont"); - else - fprintf(codefile, "r_pfp->succ_cont"); - break; - case A_SBuf: - /* - * One of the string buffers. - */ - frame(outer); - fprintf(codefile, ".sbuf[%d]", cd->Intgr(i)); - break; - case A_CBuf: - /* - * One of the cset buffers. - */ - fprintf(codefile, "&("); - frame(outer); - fprintf(codefile, ".cbuf[%d])", cd->Intgr(i)); - break; - case A_Ary: - /* - * A subarray of code fragments. - */ - prt_ary(cd->Array(i), outer); - break; - } - } - -/* - * frame - access to the procedure frame. Access directly from outer function, - * but access through r_pfp from a continuation. - */ -static void frame(outer) -int outer; - { - if (outer) - fprintf(codefile, "r_frame"); - else - fprintf(codefile, "(*r_pfp)"); - } - -/* - * prtpccall - print procedure continuation call. - */ -static void prtpccall(outer) -int outer; - { - int first_arg; - int optim; /* optimized interface: no arg list adjustment */ - - first_arg = cur_proc->tnd_loc + num_tmp; - optim = glookup(cur_proc->name)->flag & F_SmplInv; - - /* - * The only signal to be handled in this procedure is - * resumption, the rest must be passed on. - */ - if (cur_proc->nargs != 0 && optim && !outer) { - fprintf(codefile, " {\n"); - fprintf(codefile, " dptr r_argp_sav;\n"); - fprintf(codefile, "\n"); - fprintf(codefile, " r_argp_sav = glbl_argp;\n"); - } - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) strace();\n"); - } - fprintf(codefile, " pfp = "); - frame(outer); - fprintf(codefile, ".old_pfp;\n"); - fprintf(codefile, " glbl_argp = "); - frame(outer); - fprintf(codefile, ".old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = "); - frame(outer); - fprintf(codefile, ".debug.old_line;\n"); - fprintf(codefile, " file_name = "); - frame(outer); - fprintf(codefile , ".debug.old_fname;\n"); - } - fprintf(codefile, " r_signal = (*"); - if (outer) - fprintf(codefile, "r_s_cont)();\n"); - else - fprintf(codefile, "r_pfp->succ_cont)();\n"); - fprintf(codefile, " if (r_signal != A_Resume) {\n"); - if (outer) - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " return r_signal;\n"); - fprintf(codefile, " }\n"); - fprintf(codefile, " pfp = (struct p_frame *)&"); - frame(outer); - fprintf(codefile, ";\n"); - if (cur_proc->nargs == 0) - fprintf(codefile, " glbl_argp = NULL;\n"); - else { - if (optim) { - if (outer) - fprintf(codefile, " glbl_argp = r_args;\n"); - else - fprintf(codefile, " glbl_argp = r_argp_sav;\n"); - } - else { - fprintf(codefile, " glbl_argp = &"); - if (outer) - fprintf(codefile, "r_frame."); - else - fprintf(codefile, "r_pfp->"); - fprintf(codefile, "tend.d[%d];\n", first_arg); - } - } - if (debug_info) { - fprintf(codefile, " if (k_trace) atrace();\n"); - fprintf(codefile, " ++k_level;\n"); - } - if (cur_proc->nargs != 0 && optim && !outer) - fprintf(codefile, " }\n"); - } - -/* - * smpl_clsg - print call and signal handling code, but nothing fancy. - */ -static void smpl_clsg(call, outer) -struct code *call; -int outer; - { - struct sig_act *sa; - - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - if (call->Flags & ForeignSig) - chkforgn(outer); - fprintf(codefile, " switch (r_signal) {\n"); - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - fprintf(codefile, " case "); - prt_cond(sa->sig); - fprintf(codefile, ":\n "); - prtcode(sa->cd, outer); - } - fprintf(codefile, " }\n"); - } - -/* - * chkforgn - produce code to see if the current signal belongs to a - * procedure higher up the call chain and pass it along if it does. - */ -static void chkforgn(outer) -int outer; - { - fprintf(codefile, " if (pfp != (struct p_frame *)"); - if (outer) { - fprintf(codefile, "&r_frame) {\n"); - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - } - else - fprintf(codefile, "r_pfp) {\n"); - fprintf(codefile, " return r_signal;\n"); - fprintf(codefile, " }\n"); - } - -/* - * good_clsg - print call and signal handling code and do a good job. - */ -static void good_clsg(call, outer) -struct code *call; -int outer; - { - struct sig_act *sa, *sa1, *nxt_sa; - int ncases; /* the number of cases - each may have multiple case labels */ - int ncaselbl; /* the number of case labels */ - int nbreak; /* the number of cases that just break out of the switch */ - int nretsig; /* the number of cases that just pass along signal */ - int sig_var; - int dflt; - struct code *cond; - struct code *then_cd; - - /* - * Decide whether to use "break;", "return r_signal;", or nothing as - * the default case. - */ - nretsig = 0; - nbreak = 0; - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - if (sa->cd->cd_id == C_RetSig && sa->sig == sa->cd->SigRef->sig) { - /* - * The action returns the same signal detected by this case. - */ - ++nretsig; - } - else if (sa->cd->cd_id == C_Break) { - cond = sa->sig; /* if there is only one break, we may want this */ - ++nbreak; - } - } - dflt = DfltNone; - ncases = 0; - if (nbreak > 0 && nbreak >= nretsig) { - /* - * There are at least as many "break;"s as "return r_signal;"s, so - * use "break;" for default clause. - */ - dflt = DfltBrk; - ncases = 1; - } - else if (nretsig > 1) { - /* - * There is more than one case that returns the same signal it - * detects and there are more of them than "break;"s, to make - * "return r_signal;" the default clause. - */ - dflt = DfltRetSig; - ncases = 1; - } - - /* - * Gather case labels together for each case, ignoring cases that - * fall under the default. This involves constructing a new - * improved call->SigActs list. - */ - ncaselbl = ncases; - sa = call->SigActs; - call->SigActs = NULL; - for ( ; sa != NULL; sa = nxt_sa) { - nxt_sa = sa->next; - /* - * See if we have already found a case with the same action. - */ - sa1 = call->SigActs; - switch (sa->cd->cd_id) { - case C_Break: - if (dflt == DfltBrk) - continue; - while (sa1 != NULL && sa1->cd->cd_id != C_Break) - sa1 = sa1->next; - break; - case C_RetSig: - if (dflt == DfltRetSig && sa->cd->SigRef->sig == sa->sig) - continue; - while (sa1 != NULL && (sa1->cd->cd_id != C_RetSig || - sa1->cd->SigRef->sig != sa->cd->SigRef->sig)) - sa1 = sa1->next; - break; - default: /* C_Goto */ - while (sa1 != NULL && (sa1->cd->cd_id != C_Goto || - sa1->cd->Lbl != sa->cd->Lbl)) - sa1 = sa1->next; - break; - } - ++ncaselbl; - if (sa1 == NULL) { - /* - * First time we have seen this action, create a new case. - */ - ++ncases; - sa->next = call->SigActs; - call->SigActs = sa; - } - else { - /* - * We can share the action of another case label. - */ - sa->shar_act = sa1->shar_act; - sa1->shar_act = sa; - } - } - - /* - * If we might receive a "foreign" signal that belongs to a procedure - * further down the call chain, put the signal in "r_signal" then - * check for this condition. - */ - sig_var = 0; - if (call->Flags & ForeignSig) { - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - chkforgn(outer); - sig_var = 1; - } - - /* - * Determine the best way to handle the signal returned from the call. - */ - if (ncases == 0) { - /* - * Any further signal checking has been optimized away. Execution - * just falls through to subsequent code. If the call has not - * been done, do it. - */ - if (!sig_var) { - fprintf(codefile, " "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - } - else if (ncases == 1) { - if (dflt == DfltRetSig || ncaselbl == nretsig) { - /* - * All this call does is pass the signal on. See if we have - * done the call yet. - */ - if (sig_var) - fprintf(codefile, " return r_signal;"); - else { - fprintf(codefile, " return "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - } - else { - /* - * We know what to do without looking at the signal. Make sure - * we have done the call. If the action is not simply "break" - * out signal checking, execute it. - */ - if (!sig_var) { - fprintf(codefile, " "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - if (dflt != DfltBrk) - prtcode(call->SigActs->cd, outer); - } - } - else { - /* - * We have at least two cases. If we have a default action of returning - * the signal without looking at it, make sure it is in "r_signal". - */ - if (!sig_var && dflt == DfltRetSig) { - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - sig_var = 1; - } - - if (ncaselbl == 2) { - /* - * We can use an if statement. If we need the signal in "r_signal", - * it is already there. - */ - fprintf(codefile, " if ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - - cond = call->SigActs->sig; - then_cd = call->SigActs->cd; - - /* - * If the "then" clause is a no-op ("break;" from a switch), - * prepare to eliminate it by reversing the test in the - * condition. - */ - if (then_cd->cd_id == C_Break) - fprintf(codefile, " != "); - else - fprintf(codefile, " == "); - - prt_cond(cond); - fprintf(codefile, ")\n "); - - if (then_cd->cd_id == C_Break) { - /* - * We have reversed the test, so we need to use the default - * code. However, because a "break;" exists and it is not - * default, "return r_signal;" must be the default. - */ - fprintf(codefile, " return r_signal;\n"); - } - else { - /* - * Print the "then" clause and determine what the "else" clause - * is. - */ - prtcode(then_cd, outer); - if (call->SigActs->next != NULL) { - fprintf(codefile, " else\n "); - prtcode(call->SigActs->next->cd, outer); - } - else if (dflt == DfltRetSig) { - fprintf(codefile, " else\n"); - fprintf(codefile, " return r_signal;\n"); - } - } - } - else if (ncases == 2 && nbreak == 1) { - /* - * We can use an if-then statement with a negated test. Note, - * the non-break case is not "return r_signal" or we would have - * ncaselbl = 2, making the last test true. This also means that - * break is the default (the break condition was saved). - */ - fprintf(codefile, " if ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - fprintf(codefile, " != "); - prt_cond(cond); - fprintf(codefile, ") {\n "); - prtcode(call->SigActs->cd, outer); - fprintf(codefile, " }\n"); - } - else { - /* - * We must use a full case statement. If we need the signal in - * "r_signal", it is already there. - */ - fprintf(codefile, " switch ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - fprintf(codefile, ") {\n"); - - /* - * Print the cases - */ - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - for (sa1 = sa; sa1 != NULL; sa1 = sa1->shar_act) { - fprintf(codefile, " case "); - prt_cond(sa1->sig); - fprintf(codefile, ":\n"); - } - fprintf(codefile, " "); - prtcode(sa->cd, outer); - } - - /* - * If we have a default action and it is not break, print it. - */ - if (dflt == DfltRetSig) { - fprintf(codefile, " default:\n"); - fprintf(codefile, " return r_signal;\n"); - } - - fprintf(codefile, " }\n"); - } - } - } - -/* - * prtcall - print call. - */ -static void prtcall(call, outer) -struct code *call; -int outer; - { - /* - * Either the operation or the continuation may be missing, but not - * both. - */ - if (call->OperName == NULL) { - prt_cont(call->Cont); - fprintf(codefile, "()"); - } - else { - fprintf(codefile, "%s(", call->OperName); - if (call->ArgLst != NULL) - prt_ary(call->ArgLst, outer); - if (call->Cont == NULL) { - if (call->Flags & NeedCont) { - /* - * The operation requires a continuation argument even though - * this call does not include one, pass the NULL pointer. - */ - if (call->ArgLst != NULL) - fprintf(codefile, ", "); - fprintf(codefile, "(continuation)NULL"); - } - } - else { - /* - * Pass the success continuation. - */ - if (call->ArgLst != NULL) - fprintf(codefile, ", "); - prt_cont(call->Cont); - } - fprintf(codefile, ")"); - } - } - -/* - * prt_cont - print the name of a continuation. - */ -static void prt_cont(cont) -struct c_fnc *cont; - { - struct code *sig; - - if (cont->flag & CF_SigOnly) { - /* - * This continuation only returns a signal. All continuations - * returning the same signal are implemented by the same C function. - */ - sig = cont->cd.next->SigRef->sig; - if (sig->cd_id == C_Resume) - fprintf(codefile, "sig_rsm"); - else { - sig = ChkBound(sig); - ChkSeqNum(sig); - fprintf(codefile, "sig_%d", sig->SeqNum); - } - } - else { - /* - * Regular continuation. - */ - ChkPrefix(cont->prefix); - fprintf(codefile, "P%s_%s", cont->prefix, cur_proc->name); - } - } - -/* - * val_loc - output code referencing a value location (usually variable of - * some sort). - */ -static void val_loc(loc, outer) -struct val_loc *loc; -int outer; - { - /* - * See if we need to cast a block pointer to a specific block type - * or if we need to take the address of a location. - */ - if (loc->mod_access == M_BlkPtr && loc->blk_name != NULL) - fprintf(codefile, "(*(struct %s **)&", loc->blk_name); - if (loc->mod_access == M_Addr) - fprintf(codefile, "(&"); - - switch (loc->loc_type) { - case V_Ignore: - fprintf(codefile, "trashcan"); - break; - case V_Temp: - /* - * Temporary descriptor variable. - */ - frame(outer); - fprintf(codefile, ".tend.d[%d]", cur_proc->tnd_loc + loc->u.tmp); - break; - case V_ITemp: - /* - * Temporary C integer variable. - */ - frame(outer); - fprintf(codefile, ".i%d", loc->u.tmp); - break; - case V_DTemp: - /* - * Temporary C double variable. - */ - frame(outer); - fprintf(codefile, ".d%d", loc->u.tmp); - break; - case V_Const: - /* - * Integer constant (used for size of variable part of arg list). - */ - fprintf(codefile, "%d", loc->u.int_const); - break; - case V_NamedVar: - /* - * Icon named variable. - */ - prt_var(loc->u.nvar, outer); - break; - case V_CVar: - /* - * C variable from in-line code. - */ - fprintf(codefile, "%s", loc->u.name); - break; - case V_PRslt: - /* - * Procedure result location. - */ - if (!outer) - fprintf(codefile, "(*r_pfp->rslt)"); - else - fprintf(codefile, "(*r_rslt)"); - break; - } - - /* - * See if we are accessing the vword of a descriptor. - */ - switch (loc->mod_access) { - case M_CharPtr: - fprintf(codefile, ".vword.sptr"); - break; - case M_BlkPtr: - fprintf(codefile, ".vword.bptr"); - if (loc->blk_name != NULL) - fprintf(codefile, ")"); - break; - case M_CInt: - fprintf(codefile, ".vword.integr"); - break; - case M_Addr: - fprintf(codefile, ")"); - break; - } - } - -/* - * prt_cond - print a condition (signal number). - */ -static void prt_cond(cond) -struct code *cond; - { - if (cond == &resume) - fprintf(codefile, "A_Resume"); - else if (cond == &contin) - fprintf(codefile, "A_Continue"); - else if (cond == &fallthru) - fprintf(codefile, "A_FallThru"); - else { - cond = ChkBound(cond); - ChkSeqNum(cond); - fprintf(codefile, "%d /* %s */", cond->SeqNum, cond->Desc); - } - } - -/* - * initpblk - write a procedure block along with initialization up to the - * the array of qualifiers. - */ -static void initpblk(f, c, prefix, name, nquals, nparam, ndynam, nstatic, - frststat) -FILE *f; /* output file */ -int c; /* distinguishes procedures, functions, record constructors */ -char* prefix; /* prefix for name */ -char *name; /* name of routine */ -int nquals; /* number of qualifiers at end of block */ -int nparam; /* number of parameters */ -int ndynam; /* number of dynamic locals or function/record indicator */ -int nstatic; /* number of static locals or record number */ -int frststat; /* index into static array of first static local */ - { - fprintf(f, "B_IProc(%d) B%c%s_%s = ", nquals, c, prefix, name); - fprintf(f, "{T_Proc, %d, %c%s_%s, %d, %d, %d, %d, {", 9 + 2 * nquals, c, - prefix, name, nparam, ndynam, nstatic, frststat); - } - diff --git a/src/iconc/cparse.c b/src/iconc/cparse.c deleted file mode 100644 index b29986d..0000000 --- a/src/iconc/cparse.c +++ /dev/null @@ -1,1940 +0,0 @@ -# define IDENT 257 -# define INTLIT 258 -# define REALLIT 259 -# define STRINGLIT 260 -# define CSETLIT 261 -# define EOFX 262 -# define BREAK 263 -# define BY 264 -# define CASE 265 -# define CREATE 266 -# define DEFAULT 267 -# define DO 268 -# define ELSE 269 -# define END 270 -# define EVERY 271 -# define FAIL 272 -# define GLOBAL 273 -# define IF 274 -# define INITIAL 275 -# define INVOCABLE 276 -# define LINK 277 -# define LOCAL 278 -# define NEXT 279 -# define NOT 280 -# define OF 281 -# define PROCEDURE 282 -# define RECORD 283 -# define REPEAT 284 -# define RETURN 285 -# define STATIC 286 -# define SUSPEND 287 -# define THEN 288 -# define TO 289 -# define UNTIL 290 -# define WHILE 291 -# define BANG 292 -# define MOD 293 -# define AUGMOD 294 -# define AND 295 -# define AUGAND 296 -# define STAR 297 -# define AUGSTAR 298 -# define INTER 299 -# define AUGINTER 300 -# define PLUS 301 -# define AUGPLUS 302 -# define UNION 303 -# define AUGUNION 304 -# define MINUS 305 -# define AUGMINUS 306 -# define DIFF 307 -# define AUGDIFF 308 -# define DOT 309 -# define SLASH 310 -# define AUGSLASH 311 -# define ASSIGN 312 -# define SWAP 313 -# define NMLT 314 -# define AUGNMLT 315 -# define REVASSIGN 316 -# define REVSWAP 317 -# define SLT 318 -# define AUGSLT 319 -# define SLE 320 -# define AUGSLE 321 -# define NMLE 322 -# define AUGNMLE 323 -# define NMEQ 324 -# define AUGNMEQ 325 -# define SEQ 326 -# define AUGSEQ 327 -# define EQUIV 328 -# define AUGEQUIV 329 -# define NMGT 330 -# define AUGNMGT 331 -# define NMGE 332 -# define AUGNMGE 333 -# define SGT 334 -# define AUGSGT 335 -# define SGE 336 -# define AUGSGE 337 -# define QMARK 338 -# define AUGQMARK 339 -# define AT 340 -# define AUGAT 341 -# define BACKSLASH 342 -# define CARET 343 -# define AUGCARET 344 -# define BAR 345 -# define CONCAT 346 -# define AUGCONCAT 347 -# define LCONCAT 348 -# define AUGLCONCAT 349 -# define TILDE 350 -# define NMNE 351 -# define AUGNMNE 352 -# define SNE 353 -# define AUGSNE 354 -# define NEQUIV 355 -# define AUGNEQUIV 356 -# define LPAREN 357 -# define RPAREN 358 -# define PCOLON 359 -# define COMMA 360 -# define MCOLON 361 -# define COLON 362 -# define SEMICOL 363 -# define LBRACK 364 -# define RBRACK 365 -# define LBRACE 366 -# define RBRACE 367 - -# line 145 "cgram.g" -/* - * These commented directives are passed through the first application - * of cpp, then turned into real directives in cgram.g by fixgram.icn. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#undef YYSTYPE -#define YYSTYPE nodeptr -#define YYMAXDEPTH 500 - -int idflag; - - - -#define yyclearin yychar = -1 -#define yyerrok yyerrflag = 0 -extern int yychar; -extern int yyerrflag; -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 150 -#endif -#ifndef YYSTYPE -#define YYSTYPE int -#endif -YYSTYPE yylval, yyval; -# define YYERRCODE 256 - -# line 441 "cgram.g" - - -/* - * xfree(p) -- used with free(p) macro to avoid compiler errors from - * miscast free calls generated by Yacc. - */ - -static void xfree(p) -char *p; -{ - free(p); -} - -#define free(p) xfree((char*)p) -int yyexca[] ={ --1, 0, - 262, 2, - 273, 2, - 276, 2, - 277, 2, - 282, 2, - 283, 2, - -2, 0, --1, 1, - 0, -1, - -2, 0, --1, 20, - 270, 40, - 363, 42, - -2, 0, --1, 86, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 87, - 358, 42, - 360, 42, - -2, 0, --1, 88, - 363, 42, - 367, 42, - -2, 0, --1, 89, - 360, 42, - 365, 42, - -2, 0, --1, 96, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 97, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 111, - 270, 40, - 363, 42, - -2, 0, --1, 117, - 270, 40, - 363, 42, - -2, 0, --1, 182, - 360, 42, - 365, 42, - -2, 0, --1, 183, - 360, 42, - -2, 0, --1, 184, - 358, 42, - 360, 42, - -2, 0, --1, 311, - 358, 42, - 360, 42, - 365, 42, - -2, 0, --1, 313, - 363, 42, - 367, 42, - -2, 0, --1, 335, - 360, 42, - 367, 42, - -2, 0, - }; -# define YYNPROD 203 -# define YYLAST 728 -int yyact[]={ - - 38, 84, 91, 92, 93, 94, 312, 86, 185, 99, - 83, 118, 335, 359, 341, 102, 95, 358, 98, 334, - 311, 311, 355, 85, 51, 329, 314, 20, 103, 96, - 118, 97, 313, 228, 101, 100, 56, 346, 118, 90, - 118, 59, 117, 62, 360, 58, 108, 70, 336, 64, - 311, 57, 228, 55, 60, 326, 184, 228, 310, 119, - 311, 107, 106, 182, 345, 183, 324, 232, 65, 110, - 67, 168, 69, 169, 352, 214, 118, 350, 328, 177, - 41, 356, 71, 174, 50, 175, 73, 61, 325, 52, - 53, 320, 54, 316, 63, 66, 176, 68, 327, 72, - 118, 87, 332, 118, 333, 331, 319, 361, 89, 116, - 88, 305, 38, 84, 91, 92, 93, 94, 118, 86, - 181, 99, 83, 353, 317, 231, 3, 102, 95, 218, - 98, 318, 105, 118, 19, 85, 51, 315, 118, 28, - 103, 96, 29, 97, 217, 321, 101, 100, 56, 309, - 170, 90, 172, 59, 173, 62, 171, 58, 118, 70, - 30, 64, 18, 57, 118, 55, 60, 44, 180, 37, - 179, 178, 113, 24, 104, 114, 25, 330, 351, 306, - 65, 212, 67, 115, 69, 82, 2, 81, 80, 27, - 17, 36, 23, 79, 71, 78, 50, 77, 73, 61, - 76, 52, 53, 75, 54, 74, 63, 66, 49, 68, - 47, 72, 42, 87, 38, 84, 91, 92, 93, 94, - 89, 86, 88, 99, 83, 40, 112, 322, 109, 102, - 95, 34, 98, 273, 274, 111, 33, 85, 51, 12, - 233, 32, 103, 96, 21, 97, 22, 26, 101, 100, - 56, 10, 9, 90, 8, 59, 7, 62, 31, 58, - 6, 70, 5, 64, 1, 57, 0, 55, 60, 13, - 0, 216, 15, 14, 0, 210, 0, 0, 16, 11, - 0, 0, 65, 0, 67, 234, 69, 236, 239, 221, - 222, 223, 224, 225, 226, 227, 71, 230, 50, 229, - 73, 61, 0, 52, 53, 237, 54, 0, 63, 66, - 0, 68, 0, 72, 0, 87, 46, 84, 91, 92, - 93, 94, 89, 86, 88, 99, 83, 45, 0, 0, - 0, 102, 95, 0, 98, 0, 289, 290, 0, 85, - 51, 0, 0, 235, 103, 96, 0, 97, 0, 238, - 101, 100, 56, 0, 0, 90, 0, 59, 0, 62, - 0, 58, 4, 70, 303, 64, 308, 57, 0, 55, - 60, 0, 0, 13, 304, 0, 15, 14, 0, 0, - 0, 0, 16, 11, 65, 0, 67, 0, 69, 338, - 0, 213, 0, 0, 0, 0, 0, 0, 71, 43, - 50, 0, 73, 61, 0, 52, 53, 323, 54, 347, - 63, 66, 35, 68, 152, 72, 0, 87, 0, 133, - 0, 150, 0, 130, 89, 131, 88, 128, 0, 127, - 0, 129, 0, 126, 362, 0, 132, 121, 120, 0, - 140, 123, 122, 0, 147, 164, 146, 0, 139, 158, - 135, 157, 143, 163, 136, 160, 138, 154, 137, 166, - 145, 162, 144, 161, 149, 156, 151, 155, 0, 134, - 0, 0, 124, 0, 125, 0, 153, 141, 211, 148, - 215, 142, 165, 39, 159, 0, 167, 0, 219, 220, - 0, 295, 296, 297, 298, 299, 0, 0, 291, 292, - 293, 294, 0, 35, 0, 0, 0, 339, 340, 35, - 342, 343, 344, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 348, 0, 0, 0, 48, 0, 0, 0, - 0, 0, 0, 354, 0, 0, 0, 0, 0, 0, - 0, 0, 357, 0, 0, 0, 0, 0, 0, 0, - 0, 354, 363, 364, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, 285, 286, 287, 288, 0, 0, - 0, 0, 0, 0, 0, 307, 0, 186, 187, 188, - 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, - 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, - 209, 0, 0, 240, 241, 242, 243, 244, 245, 246, - 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, - 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, - 267, 268, 269, 270, 271, 272, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 337, 0, 215, 300, 301, 302, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 349 }; -int yypact[]={ - - -130, -1000, 100, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -95, -229, -1000, -84, -118, -97, -4, -1000, -1000, - -42, -125, -298, -1000, -1000, -1000, -299, -1000, -1000, -316, - -1000, -1000, -288, -103, -161, -321, -219, -279, -1000, -1000, - 125, -1000, 131, -275, -151, -214, -1000, -172, -1000, -301, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -42, -1000, -1000, -42, -42, -42, -42, - -128, -1000, -1000, -1000, -1000, -1000, -42, -42, -42, -42, - -42, -42, -42, -42, -303, -1000, -84, -118, -133, -290, - -125, -42, -125, -42, -1000, -1000, -1000, -42, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, -42, -256, -42, -108, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -219, -1000, -300, -1000, -361, -331, -339, -1000, -1000, -1000, - -1000, -131, -195, -157, -137, -162, -177, -219, -112, -1000, - -1000, -1000, -125, -292, -303, -182, -308, -265, -1000, -279, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -186, -1000, -275, -275, -275, -275, -275, - -275, -275, -275, -275, -275, -275, -275, -275, -275, -151, - -151, -214, -214, -214, -214, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -340, -257, -1000, -348, -1000, -310, -1000, - -1000, -42, -1000, -42, -1000, -42, -42, -352, -42, -42, - -42, -1000, -294, -327, -1000, -1000, -1000, -1000, 60, -1000, - -42, -1000, -1000, -1000, -1000, -42, -1000, -1000, -1000, -219, - -192, -144, -219, -219, -219, -1000, -343, -1000, -284, -1000, - -42, -350, -1000, -318, -255, -1000, -1000, -219, -1000, -144, - -42, -42, -1000, -219, -219 }; -int yypgo[]={ - - 0, 264, 186, 262, 260, 256, 254, 252, 251, 247, - 189, 246, 192, 244, 174, 241, 240, 239, 236, 235, - 231, 228, 227, 226, 191, 391, 169, 483, 225, 80, - 212, 399, 167, 327, 316, 210, 526, 208, 205, 203, - 200, 197, 195, 193, 188, 187, 185, 181, 75, 179, - 178, 74, 177 }; -int yyr1[]={ - - 0, 1, 2, 2, 3, 3, 3, 3, 3, 8, - 9, 9, 10, 10, 10, 7, 11, 11, 12, 12, - 13, 6, 15, 4, 16, 16, 5, 21, 17, 22, - 22, 22, 14, 14, 18, 18, 23, 23, 19, 19, - 20, 20, 25, 25, 24, 24, 26, 26, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 28, 28, 28, 29, 29, 30, 30, 30, 30, - 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, - 30, 31, 31, 31, 32, 32, 32, 32, 32, 33, - 33, 33, 33, 33, 34, 34, 35, 35, 35, 35, - 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 37, 37, 37, 37, 37, - 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - 37, 37, 37, 37, 37, 37, 37, 37, 43, 43, - 44, 44, 45, 45, 46, 40, 40, 40, 40, 41, - 41, 42, 50, 50, 51, 51, 47, 47, 49, 49, - 38, 38, 38, 38, 39, 52, 52, 52, 48, 48, - 1, 5, 24 }; -int yyr2[]={ - - 0, 5, 0, 4, 3, 3, 3, 3, 3, 5, - 2, 7, 3, 3, 7, 5, 2, 7, 3, 3, - 1, 7, 1, 13, 1, 3, 13, 1, 13, 1, - 3, 7, 3, 7, 1, 9, 3, 3, 1, 7, - 1, 7, 1, 2, 2, 7, 2, 7, 2, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 2, 7, 11, 2, 7, 2, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 2, 7, 7, 2, 7, 7, 7, 7, 2, - 7, 7, 7, 7, 2, 7, 2, 7, 7, 7, - 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 5, 5, 5, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 5, 3, 3, 5, 7, 7, - 7, 9, 7, 9, 9, 7, 5, 5, 5, 9, - 5, 9, 5, 9, 5, 3, 5, 5, 9, 9, - 13, 13, 2, 7, 7, 7, 3, 7, 3, 7, - 3, 3, 3, 3, 13, 3, 3, 3, 2, 7, - 6, 8, 2 }; -int yychk[]={ - - -1000, -1, -2, 256, 262, -3, -4, -5, -6, -7, - -8, 283, -17, 273, 277, 276, 282, -2, 257, 363, - 256, -13, -11, -12, 257, 260, -9, -10, 257, 260, - 257, 262, -15, -18, -20, -25, -24, -26, 256, -27, - -28, -29, -30, -31, -32, -33, -34, -35, -36, -37, - 340, 280, 345, 346, 348, 309, 292, 307, 301, 297, - 310, 343, 299, 350, 305, 324, 351, 326, 353, 328, - 303, 338, 355, 342, -38, -39, -40, -41, -42, -43, - -44, -45, -46, 266, 257, 279, 263, 357, 366, 364, - 295, 258, 259, 260, 261, 272, 285, 287, 274, 265, - 291, 290, 271, 284, -14, 257, 360, 360, 362, -21, - 357, -19, -23, 275, 278, 286, 270, 363, 295, 338, - 313, 312, 317, 316, 347, 349, 308, 304, 302, 306, - 298, 300, 311, 294, 344, 325, 329, 333, 331, 323, - 315, 352, 356, 327, 337, 335, 321, 319, 354, 339, - 296, 341, 289, 345, 326, 336, 334, 320, 318, 353, - 324, 332, 330, 322, 314, 351, 328, 355, 346, 348, - 301, 307, 303, 305, 297, 299, 310, 293, 343, 342, - 340, 292, 364, 366, 357, 309, -36, -36, -36, -36, - -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, - -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, - -24, -25, -47, -25, -48, -25, -47, 272, 257, -25, - -25, -24, -24, -24, -24, -24, -24, -24, 360, -12, - -10, 258, 357, -16, -14, -20, -14, -24, -20, -26, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -29, -29, -31, -31, -31, -31, -31, - -31, -31, -31, -31, -31, -31, -31, -31, -31, -32, - -32, -33, -33, -33, -33, -34, -34, -34, -34, -34, - -36, -36, -36, -47, -24, 367, -49, -25, -47, 257, - 358, 360, 367, 363, 365, 268, 288, 281, 268, 268, - 268, 257, -22, -14, 358, 270, 363, 363, 264, 365, - -52, 362, 359, 361, 367, 360, 358, -25, -48, -24, - -24, 366, -24, -24, -24, 358, 364, -29, -24, -25, - 269, -50, -51, 267, -24, 365, 365, -24, 367, 363, - 362, 362, -51, -24, -24 }; -int yydef[]={ - - -2, -2, 0, 2, 1, 3, 4, 5, 6, 7, - 8, 0, 0, 20, 0, 0, 0, 0, 22, 34, - -2, 0, 15, 16, 18, 19, 9, 10, 12, 13, - 27, 200, 0, 38, 0, 0, 43, 44, 202, 46, - 48, 81, 84, 86, 101, 104, 109, 114, 116, 120, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 145, 146, 147, 148, 149, 150, - 151, 152, 153, 0, 155, 156, -2, -2, -2, -2, - 0, 190, 191, 192, 193, 175, -2, -2, 0, 0, - 0, 0, 0, 0, 21, 32, 0, 0, 0, 0, - 24, -2, 0, 0, 36, 37, 201, -2, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, -2, -2, -2, 0, 121, 122, 123, 124, - 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, - 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, - 154, 157, 0, 186, 0, 198, 0, 166, 167, 176, - 177, 43, 0, 0, 168, 170, 172, 174, 0, 17, - 11, 14, 29, 0, 25, 0, 0, 0, 41, 45, - 47, 49, 50, 51, 52, 53, 54, 55, 56, 57, - 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, - 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, - 78, 79, 80, 82, 85, 87, 88, 89, 90, 91, - 92, 93, 94, 95, 96, 97, 98, 99, 100, 102, - 103, 105, 106, 107, 108, 110, 111, 112, 113, 115, - 117, 118, 119, 0, 43, 162, 0, 188, 0, 165, - 158, -2, 159, -2, 160, 0, 0, 0, 0, 0, - 0, 33, 0, 30, 23, 26, 35, 39, 0, 161, - 0, 195, 196, 197, 163, -2, 164, 187, 199, 178, - 179, 0, 169, 171, 173, 28, 0, 83, 0, 189, - 0, 0, 182, 0, 0, 31, 194, 180, 181, 0, - 0, 0, 183, 184, 185 }; -typedef struct { char *t_name; int t_val; } yytoktype; -#ifndef YYDEBUG -# define YYDEBUG 0 /* don't allow debugging */ -#endif - -#if YYDEBUG - -yytoktype yytoks[] = -{ - "IDENT", 257, - "INTLIT", 258, - "REALLIT", 259, - "STRINGLIT", 260, - "CSETLIT", 261, - "EOFX", 262, - "BREAK", 263, - "BY", 264, - "CASE", 265, - "CREATE", 266, - "DEFAULT", 267, - "DO", 268, - "ELSE", 269, - "END", 270, - "EVERY", 271, - "FAIL", 272, - "GLOBAL", 273, - "IF", 274, - "INITIAL", 275, - "INVOCABLE", 276, - "LINK", 277, - "LOCAL", 278, - "NEXT", 279, - "NOT", 280, - "OF", 281, - "PROCEDURE", 282, - "RECORD", 283, - "REPEAT", 284, - "RETURN", 285, - "STATIC", 286, - "SUSPEND", 287, - "THEN", 288, - "TO", 289, - "UNTIL", 290, - "WHILE", 291, - "BANG", 292, - "MOD", 293, - "AUGMOD", 294, - "AND", 295, - "AUGAND", 296, - "STAR", 297, - "AUGSTAR", 298, - "INTER", 299, - "AUGINTER", 300, - "PLUS", 301, - "AUGPLUS", 302, - "UNION", 303, - "AUGUNION", 304, - "MINUS", 305, - "AUGMINUS", 306, - "DIFF", 307, - "AUGDIFF", 308, - "DOT", 309, - "SLASH", 310, - "AUGSLASH", 311, - "ASSIGN", 312, - "SWAP", 313, - "NMLT", 314, - "AUGNMLT", 315, - "REVASSIGN", 316, - "REVSWAP", 317, - "SLT", 318, - "AUGSLT", 319, - "SLE", 320, - "AUGSLE", 321, - "NMLE", 322, - "AUGNMLE", 323, - "NMEQ", 324, - "AUGNMEQ", 325, - "SEQ", 326, - "AUGSEQ", 327, - "EQUIV", 328, - "AUGEQUIV", 329, - "NMGT", 330, - "AUGNMGT", 331, - "NMGE", 332, - "AUGNMGE", 333, - "SGT", 334, - "AUGSGT", 335, - "SGE", 336, - "AUGSGE", 337, - "QMARK", 338, - "AUGQMARK", 339, - "AT", 340, - "AUGAT", 341, - "BACKSLASH", 342, - "CARET", 343, - "AUGCARET", 344, - "BAR", 345, - "CONCAT", 346, - "AUGCONCAT", 347, - "LCONCAT", 348, - "AUGLCONCAT", 349, - "TILDE", 350, - "NMNE", 351, - "AUGNMNE", 352, - "SNE", 353, - "AUGSNE", 354, - "NEQUIV", 355, - "AUGNEQUIV", 356, - "LPAREN", 357, - "RPAREN", 358, - "PCOLON", 359, - "COMMA", 360, - "MCOLON", 361, - "COLON", 362, - "SEMICOL", 363, - "LBRACK", 364, - "RBRACK", 365, - "LBRACE", 366, - "RBRACE", 367, - "-unknown-", -1 /* ends search */ -}; - -char * yyreds[] = -{ - "-no such reduction-", - "program : decls EOFX", - "decls : /* empty */", - "decls : decls decl", - "decl : record", - "decl : proc", - "decl : global", - "decl : link", - "decl : invocable", - "invocable : INVOCABLE invoclist", - "invoclist : invocop", - "invoclist : invoclist COMMA invocop", - "invocop : IDENT", - "invocop : STRINGLIT", - "invocop : STRINGLIT COLON INTLIT", - "link : LINK lnklist", - "lnklist : lnkfile", - "lnklist : lnklist COMMA lnkfile", - "lnkfile : IDENT", - "lnkfile : STRINGLIT", - "global : GLOBAL", - "global : GLOBAL idlist", - "record : RECORD IDENT", - "record : RECORD IDENT LPAREN fldlist RPAREN", - "fldlist : /* empty */", - "fldlist : idlist", - "proc : prochead SEMICOL locals initial procbody END", - "prochead : PROCEDURE IDENT", - "prochead : PROCEDURE IDENT LPAREN arglist RPAREN", - "arglist : /* empty */", - "arglist : idlist", - "arglist : idlist LBRACK RBRACK", - "idlist : IDENT", - "idlist : idlist COMMA IDENT", - "locals : /* empty */", - "locals : locals retention idlist SEMICOL", - "retention : LOCAL", - "retention : STATIC", - "initial : /* empty */", - "initial : INITIAL expr SEMICOL", - "procbody : /* empty */", - "procbody : nexpr SEMICOL procbody", - "nexpr : /* empty */", - "nexpr : expr", - "expr : expr1a", - "expr : expr AND expr1a", - "expr1a : expr1", - "expr1a : expr1a QMARK expr1", - "expr1 : expr2", - "expr1 : expr2 SWAP expr1", - "expr1 : expr2 ASSIGN expr1", - "expr1 : expr2 REVSWAP expr1", - "expr1 : expr2 REVASSIGN expr1", - "expr1 : expr2 AUGCONCAT expr1", - "expr1 : expr2 AUGLCONCAT expr1", - "expr1 : expr2 AUGDIFF expr1", - "expr1 : expr2 AUGUNION expr1", - "expr1 : expr2 AUGPLUS expr1", - "expr1 : expr2 AUGMINUS expr1", - "expr1 : expr2 AUGSTAR expr1", - "expr1 : expr2 AUGINTER expr1", - "expr1 : expr2 AUGSLASH expr1", - "expr1 : expr2 AUGMOD expr1", - "expr1 : expr2 AUGCARET expr1", - "expr1 : expr2 AUGNMEQ expr1", - "expr1 : expr2 AUGEQUIV expr1", - "expr1 : expr2 AUGNMGE expr1", - "expr1 : expr2 AUGNMGT expr1", - "expr1 : expr2 AUGNMLE expr1", - "expr1 : expr2 AUGNMLT expr1", - "expr1 : expr2 AUGNMNE expr1", - "expr1 : expr2 AUGNEQUIV expr1", - "expr1 : expr2 AUGSEQ expr1", - "expr1 : expr2 AUGSGE expr1", - "expr1 : expr2 AUGSGT expr1", - "expr1 : expr2 AUGSLE expr1", - "expr1 : expr2 AUGSLT expr1", - "expr1 : expr2 AUGSNE expr1", - "expr1 : expr2 AUGQMARK expr1", - "expr1 : expr2 AUGAND expr1", - "expr1 : expr2 AUGAT expr1", - "expr2 : expr3", - "expr2 : expr2 TO expr3", - "expr2 : expr2 TO expr3 BY expr3", - "expr3 : expr4", - "expr3 : expr4 BAR expr3", - "expr4 : expr5", - "expr4 : expr4 SEQ expr5", - "expr4 : expr4 SGE expr5", - "expr4 : expr4 SGT expr5", - "expr4 : expr4 SLE expr5", - "expr4 : expr4 SLT expr5", - "expr4 : expr4 SNE expr5", - "expr4 : expr4 NMEQ expr5", - "expr4 : expr4 NMGE expr5", - "expr4 : expr4 NMGT expr5", - "expr4 : expr4 NMLE expr5", - "expr4 : expr4 NMLT expr5", - "expr4 : expr4 NMNE expr5", - "expr4 : expr4 EQUIV expr5", - "expr4 : expr4 NEQUIV expr5", - "expr5 : expr6", - "expr5 : expr5 CONCAT expr6", - "expr5 : expr5 LCONCAT expr6", - "expr6 : expr7", - "expr6 : expr6 PLUS expr7", - "expr6 : expr6 DIFF expr7", - "expr6 : expr6 UNION expr7", - "expr6 : expr6 MINUS expr7", - "expr7 : expr8", - "expr7 : expr7 STAR expr8", - "expr7 : expr7 INTER expr8", - "expr7 : expr7 SLASH expr8", - "expr7 : expr7 MOD expr8", - "expr8 : expr9", - "expr8 : expr9 CARET expr8", - "expr9 : expr10", - "expr9 : expr9 BACKSLASH expr10", - "expr9 : expr9 AT expr10", - "expr9 : expr9 BANG expr10", - "expr10 : expr11", - "expr10 : AT expr10", - "expr10 : NOT expr10", - "expr10 : BAR expr10", - "expr10 : CONCAT expr10", - "expr10 : LCONCAT expr10", - "expr10 : DOT expr10", - "expr10 : BANG expr10", - "expr10 : DIFF expr10", - "expr10 : PLUS expr10", - "expr10 : STAR expr10", - "expr10 : SLASH expr10", - "expr10 : CARET expr10", - "expr10 : INTER expr10", - "expr10 : TILDE expr10", - "expr10 : MINUS expr10", - "expr10 : NMEQ expr10", - "expr10 : NMNE expr10", - "expr10 : SEQ expr10", - "expr10 : SNE expr10", - "expr10 : EQUIV expr10", - "expr10 : UNION expr10", - "expr10 : QMARK expr10", - "expr10 : NEQUIV expr10", - "expr10 : BACKSLASH expr10", - "expr11 : literal", - "expr11 : section", - "expr11 : return", - "expr11 : if", - "expr11 : case", - "expr11 : while", - "expr11 : until", - "expr11 : every", - "expr11 : repeat", - "expr11 : CREATE expr", - "expr11 : IDENT", - "expr11 : NEXT", - "expr11 : BREAK nexpr", - "expr11 : LPAREN exprlist RPAREN", - "expr11 : LBRACE compound RBRACE", - "expr11 : LBRACK exprlist RBRACK", - "expr11 : expr11 LBRACK exprlist RBRACK", - "expr11 : expr11 LBRACE RBRACE", - "expr11 : expr11 LBRACE pdcolist RBRACE", - "expr11 : expr11 LPAREN exprlist RPAREN", - "expr11 : expr11 DOT IDENT", - "expr11 : AND FAIL", - "expr11 : AND IDENT", - "while : WHILE expr", - "while : WHILE expr DO expr", - "until : UNTIL expr", - "until : UNTIL expr DO expr", - "every : EVERY expr", - "every : EVERY expr DO expr", - "repeat : REPEAT expr", - "return : FAIL", - "return : RETURN nexpr", - "return : SUSPEND nexpr", - "return : SUSPEND expr DO expr", - "if : IF expr THEN expr", - "if : IF expr THEN expr ELSE expr", - "case : CASE expr OF LBRACE caselist RBRACE", - "caselist : cclause", - "caselist : caselist SEMICOL cclause", - "cclause : DEFAULT COLON expr", - "cclause : expr COLON expr", - "exprlist : nexpr", - "exprlist : exprlist COMMA nexpr", - "pdcolist : nexpr", - "pdcolist : pdcolist COMMA nexpr", - "literal : INTLIT", - "literal : REALLIT", - "literal : STRINGLIT", - "literal : CSETLIT", - "section : expr11 LBRACK expr sectop expr RBRACK", - "sectop : COLON", - "sectop : PCOLON", - "sectop : MCOLON", - "compound : nexpr", - "compound : nexpr SEMICOL compound", - "program : error decls EOFX", - "proc : prochead error procbody END", - "expr : error", -}; -#endif -#line 1 "/usr/lib/yaccpar" -/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ - -/* -** Skeleton parser driver for yacc output -*/ - -/* -** yacc user known macros and defines -*/ -#define YYERROR goto yyerrlab -#define YYACCEPT { free(yys); free(yyv); return(0); } -#define YYABORT { free(yys); free(yyv); return(1); } -#define YYBACKUP( newtoken, newvalue )\ -{\ - if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ - {\ - tsyserr("parser: syntax error - cannot backup" );\ - goto yyerrlab;\ - }\ - yychar = newtoken;\ - yystate = *yyps;\ - yylval = newvalue;\ - goto yynewstate;\ -} -#define YYRECOVERING() (!!yyerrflag) -#ifndef YYDEBUG -# define YYDEBUG 1 /* make debugging available */ -#endif - -/* -** user known globals -*/ -int yydebug; /* set to 1 to get debugging */ - -/* -** driver internal defines -*/ -#define YYFLAG (-1000) - -/* -** static variables used by the parser -*/ -static YYSTYPE *yyv; /* value stack */ -static int *yys; /* state stack */ - -static YYSTYPE *yypv; /* top of value stack */ -static int *yyps; /* top of state stack */ - -static int yystate; /* current state */ -static int yytmp; /* extra var (lasts between blocks) */ - -int yynerrs; /* number of errors */ - -int yyerrflag; /* error recovery flag */ -int yychar; /* current input token number */ - - -/* -** yyparse - return 0 if worked, 1 if syntax error not recovered from -*/ -int -yyparse() -{ - register YYSTYPE *yypvt; /* top of value stack for $vars */ - unsigned yymaxdepth = YYMAXDEPTH; - - /* - ** Initialize externals - yyparse may be called more than once - */ - yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); - yys = (int*)malloc(yymaxdepth*sizeof(int)); - if (!yyv || !yys) - { - tsyserr("parser: out of memory" ); - return(1); - } - yypv = &yyv[-1]; - yyps = &yys[-1]; - yystate = 0; - yytmp = 0; - yynerrs = 0; - yyerrflag = 0; - yychar = -1; - - goto yystack; - { - register YYSTYPE *yy_pv; /* top of value stack */ - register int *yy_ps; /* top of state stack */ - register int yy_state; /* current state */ - register int yy_n; /* internal state number info */ - - /* - ** get globals into registers. - ** branch to here only if YYBACKUP was called. - */ - yynewstate: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - goto yy_newstate; - - /* - ** get globals into registers. - ** either we just started, or we just finished a reduction - */ - yystack: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - - /* - ** top of for (;;) loop while no reductions done - */ - yy_stack: - /* - ** put a state and value onto the stacks - */ -#if YYDEBUG - /* - ** if debugging, look up token value in list of value vs. - ** name pairs. 0 and negative (-1) are special values. - ** Note: linear search is used since time is not a real - ** consideration while debugging. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "State %d, token ", yy_state ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ - { - /* - ** reallocate and recover. Note that pointers - ** have to be reset, or bad things will happen - */ - int yyps_index = (yy_ps - yys); - int yypv_index = (yy_pv - yyv); - int yypvt_index = (yypvt - yyv); - yymaxdepth += YYMAXDEPTH; - yyv = (YYSTYPE*)realloc((char*)yyv, - yymaxdepth * sizeof(YYSTYPE)); - yys = (int*)realloc((char*)yys, - yymaxdepth * sizeof(int)); - if (!yyv || !yys) - { - tsyserr("parse stack overflow" ); - return(1); - } - yy_ps = yys + yyps_index; - yy_pv = yyv + yypv_index; - yypvt = yyv + yypvt_index; - } - *yy_ps = yy_state; - *++yy_pv = yyval; - - /* - ** we have a new state - find out what to do - */ - yy_newstate: - if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG ) - goto yydefault; /* simple state */ -#if YYDEBUG - /* - ** if debugging, need to mark whether new token grabbed - */ - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) ) - goto yydefault; - if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/ - { - yychar = -1; - yyval = yylval; - yy_state = yy_n; - if ( yyerrflag > 0 ) - yyerrflag--; - goto yy_stack; - } - - yydefault: - if ( ( yy_n = yydef[ yy_state ] ) == -2 ) - { -#if YYDEBUG - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - /* - ** look through exception table - */ - { - register int *yyxi = yyexca; - - while ( ( *yyxi != -1 ) || - ( yyxi[1] != yy_state ) ) - { - yyxi += 2; - } - while ( ( *(yyxi += 2) >= 0 ) && - ( *yyxi != yychar ) ) - ; - if ( ( yy_n = yyxi[1] ) < 0 ) - YYACCEPT; - } - } - - /* - ** check for syntax error - */ - if ( yy_n == 0 ) /* have an error */ - { - /* no worry about speed here! */ - switch ( yyerrflag ) - { - case 0: /* new error */ - yyerror(yychar, yylval, yy_state ); - goto skip_init; - yyerrlab: - /* - ** get globals into registers. - ** we have a user generated syntax type error - */ - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - yynerrs++; - skip_init: - case 1: - case 2: /* incompletely recovered error */ - /* try again... */ - yyerrflag = 3; - /* - ** find state where "error" is a legal - ** shift action - */ - while ( yy_ps >= yys ) - { - yy_n = yypact[ *yy_ps ] + YYERRCODE; - if ( yy_n >= 0 && yy_n < YYLAST && - yychk[yyact[yy_n]] == YYERRCODE) { - /* - ** simulate shift of "error" - */ - yy_state = yyact[ yy_n ]; - goto yy_stack; - } - /* - ** current state has no shift on - ** "error", pop stack - */ -#if YYDEBUG -# define _POP_ "Error recovery pops state %d, uncovers state %d\n" - if ( yydebug ) - (void)printf( _POP_, *yy_ps, - yy_ps[-1] ); -# undef _POP_ -#endif - yy_ps--; - yy_pv--; - } - /* - ** there is no state on stack with "error" as - ** a valid shift. give up. - */ - YYABORT; - case 3: /* no shift yet; eat a token */ -#if YYDEBUG - /* - ** if debugging, look up token in list of - ** pairs. 0 and negative shouldn't occur, - ** but since timing doesn't matter when - ** debugging, it doesn't hurt to leave the - ** tests here. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "Error recovery discards " ); - if ( yychar == 0 ) - (void)printf( "token end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "token -none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "token %s\n", - yytoks[yy_i].t_name ); - } - } -#endif - if ( yychar == 0 ) /* reached EOF. quit */ - YYABORT; - yychar = -1; - goto yy_newstate; - } - }/* end if ( yy_n == 0 ) */ - /* - ** reduction by production yy_n - ** put stack tops, etc. so things right after switch - */ -#if YYDEBUG - /* - ** if debugging, print the string that is the user's - ** specification of the reduction which is just about - ** to be done. - */ - if ( yydebug ) - (void)printf( "Reduce by (%d) \"%s\"\n", - yy_n, yyreds[ yy_n ] ); -#endif - yytmp = yy_n; /* value to switch over */ - yypvt = yy_pv; /* $vars top of value stack */ - /* - ** Look in goto table for next state - ** Sorry about using yy_state here as temporary - ** register variable, but why not, if it works... - ** If yyr2[ yy_n ] doesn't have the low order bit - ** set, then there is no action to be done for - ** this reduction. So, no saving & unsaving of - ** registers done. The only difference between the - ** code just after the if and the body of the if is - ** the goto yy_stack in the body. This way the test - ** can be made before the choice of what to do is needed. - */ - { - /* length of production doubled with extra bit */ - register int yy_len = yyr2[ yy_n ]; - - if ( !( yy_len & 01 ) ) - { - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = - yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - goto yy_stack; - } - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - } - /* save until reenter driver code */ - yystate = yy_state; - yyps = yy_ps; - yypv = yy_pv; - } - /* - ** code supplied by user is placed in this switch - */ - switch( yytmp ) - { - -case 1: -# line 177 "cgram.g" -{;} break; -case 4: -# line 182 "cgram.g" -{;} break; -case 5: -# line 183 "cgram.g" -{proc_lst->tree = yypvt[-0] ;} break; -case 6: -# line 184 "cgram.g" -{;} break; -case 7: -# line 185 "cgram.g" -{;} break; -case 8: -# line 186 "cgram.g" -{;} break; -case 9: -# line 188 "cgram.g" -{;} break; -case 11: -# line 191 "cgram.g" -{;} break; -case 12: -# line 193 "cgram.g" -{invoc_grp(Str0(yypvt[-0])); ;} break; -case 13: -# line 194 "cgram.g" -{invocbl(yypvt[-0], -1); ;} break; -case 14: -# line 195 "cgram.g" -{invocbl(yypvt[-2], atoi(Str0(yypvt[-0]))); ;} break; -case 15: -# line 197 "cgram.g" -{;} break; -case 17: -# line 200 "cgram.g" -{;} break; -case 18: -# line 202 "cgram.g" -{lnkdcl(Str0(yypvt[-0])); ;} break; -case 19: -# line 203 "cgram.g" -{lnkdcl(Str0(yypvt[-0])); ;} break; -case 20: -# line 205 "cgram.g" -{idflag = F_Global ;} break; -case 21: -# line 205 "cgram.g" -{;} break; -case 22: -# line 207 "cgram.g" -{init_rec(Str0(yypvt[-0])); idflag = F_Field ;} break; -case 23: -# line 207 "cgram.g" -{ - ; - } break; -case 24: -# line 211 "cgram.g" -{;} break; -case 25: -# line 212 "cgram.g" -{;} break; -case 26: -# line 214 "cgram.g" -{ - yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]) ; - } break; -case 27: -# line 218 "cgram.g" -{init_proc(Str0(yypvt[-0])); idflag = F_Argument ;} break; -case 28: -# line 218 "cgram.g" -{ - ; - } break; -case 29: -# line 222 "cgram.g" -{;} break; -case 30: -# line 223 "cgram.g" -{;} break; -case 31: -# line 224 "cgram.g" -{proc_lst->nargs = -proc_lst->nargs ;} break; -case 32: -# line 227 "cgram.g" -{ - install(Str0(yypvt[-0]),idflag) ; - } break; -case 33: -# line 230 "cgram.g" -{ - install(Str0(yypvt[-0]),idflag) ; - } break; -case 34: -# line 234 "cgram.g" -{;} break; -case 35: -# line 235 "cgram.g" -{;} break; -case 36: -# line 237 "cgram.g" -{idflag = F_Dynamic ;} break; -case 37: -# line 238 "cgram.g" -{idflag = F_Static ;} break; -case 38: -# line 240 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 39: -# line 241 "cgram.g" -{yyval = yypvt[-1] ;} break; -case 40: -# line 243 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 41: -# line 244 "cgram.g" -{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 42: -# line 246 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 45: -# line 250 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 47: -# line 253 "cgram.g" -{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 49: -# line 256 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 50: -# line 257 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 51: -# line 258 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 52: -# line 259 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 53: -# line 260 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 54: -# line 261 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 55: -# line 262 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 56: -# line 263 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 57: -# line 264 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 58: -# line 265 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 59: -# line 266 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 60: -# line 267 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 61: -# line 268 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 62: -# line 269 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 63: -# line 270 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 64: -# line 271 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 65: -# line 272 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 66: -# line 273 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 67: -# line 274 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 68: -# line 275 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 69: -# line 276 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 70: -# line 277 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 71: -# line 278 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 72: -# line 279 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 73: -# line 280 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 74: -# line 281 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 75: -# line 282 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 76: -# line 283 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 77: -# line 284 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 78: -# line 285 "cgram.g" -{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 79: -# line 286 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 80: -# line 287 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 82: -# line 290 "cgram.g" -{yyval = to_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 83: -# line 291 "cgram.g" -{yyval = toby_nd(yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; -case 85: -# line 294 "cgram.g" -{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 87: -# line 297 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 88: -# line 298 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 89: -# line 299 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 90: -# line 300 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 91: -# line 301 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 92: -# line 302 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 93: -# line 303 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 94: -# line 304 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 95: -# line 305 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 96: -# line 306 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 97: -# line 307 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 98: -# line 308 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 99: -# line 309 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 100: -# line 310 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 102: -# line 313 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 103: -# line 314 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 105: -# line 317 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 106: -# line 318 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 107: -# line 319 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 108: -# line 320 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 110: -# line 323 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 111: -# line 324 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 112: -# line 325 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 113: -# line 326 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 115: -# line 329 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 117: -# line 332 "cgram.g" -{yyval = tree4(N_Limit,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 118: -# line 333 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 119: -# line 334 "cgram.g" -{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 121: -# line 337 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],tree1(N_Empty) ,yypvt[-0]) ;} break; -case 122: -# line 338 "cgram.g" -{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]) ;} break; -case 123: -# line 339 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 124: -# line 340 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 125: -# line 341 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 126: -# line 342 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 127: -# line 343 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 128: -# line 344 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 129: -# line 345 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 130: -# line 346 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 131: -# line 347 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 132: -# line 348 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 133: -# line 349 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 134: -# line 350 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 135: -# line 351 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 136: -# line 352 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 137: -# line 353 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 138: -# line 354 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 139: -# line 355 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 140: -# line 356 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 141: -# line 357 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 142: -# line 358 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 143: -# line 359 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 144: -# line 360 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 154: -# line 371 "cgram.g" -{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]); proc_lst->has_coexpr = 1; ;} break; -case 155: -# line 372 "cgram.g" -{LSym0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0) ;} break; -case 156: -# line 373 "cgram.g" -{yyval = tree2(N_Next,yypvt[-0]) ;} break; -case 157: -# line 374 "cgram.g" -{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]) ;} break; -case 158: -# line 375 "cgram.g" -{if ((yypvt[-1])->n_type == N_Elist) yyval = invk_nd(yypvt[-2],tree1(N_Empty) ,yypvt[-1]); else yyval = yypvt[-1] ;} break; -case 159: -# line 376 "cgram.g" -{yyval = yypvt[-1] ;} break; -case 160: -# line 377 "cgram.g" -{yyval = list_nd(yypvt[-2],yypvt[-1]) ;} break; -case 161: -# line 378 "cgram.g" -{yyval = buildarray(yypvt[-3],yypvt[-2],yypvt[-1]) ;} break; -case 162: -# line 379 "cgram.g" -{yyval = invk_nd(yypvt[-1],yypvt[-2],list_nd(yypvt[-1],tree1(N_Empty) )) ;} break; -case 163: -# line 380 "cgram.g" -{yyval = invk_nd(yypvt[-2],yypvt[-3],list_nd(yypvt[-2],yypvt[-1])) ;} break; -case 164: -# line 381 "cgram.g" -{yyval = invk_nd(yypvt[-2],yypvt[-3],yypvt[-1]) ;} break; -case 165: -# line 382 "cgram.g" -{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 166: -# line 383 "cgram.g" -{yyval = key_leaf(yypvt[-1],spec_str("fail")) ;} break; -case 167: -# line 384 "cgram.g" -{yyval = key_leaf(yypvt[-1],Str0(yypvt[-0])) ;} break; -case 168: -# line 386 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 169: -# line 387 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 170: -# line 389 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 171: -# line 390 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 172: -# line 392 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 173: -# line 393 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 174: -# line 395 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 175: -# line 397 "cgram.g" -{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty) ) ;} break; -case 176: -# line 398 "cgram.g" -{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]) ;} break; -case 177: -# line 399 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 178: -# line 400 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 179: -# line 402 "cgram.g" -{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty) ) ;} break; -case 180: -# line 403 "cgram.g" -{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; -case 181: -# line 405 "cgram.g" -{yyval = case_nd(yypvt[-5],yypvt[-4],yypvt[-1]) ;} break; -case 183: -# line 408 "cgram.g" -{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 184: -# line 410 "cgram.g" -{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 185: -# line 411 "cgram.g" -{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 186: -# line 413 "cgram.g" -{yyval = yypvt[-0]; ;} break; -case 187: -# line 414 "cgram.g" -{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]); ;} break; -case 188: -# line 416 "cgram.g" -{ - yyval = tree3(N_Create,yypvt[-0],yypvt[-0]); proc_lst->has_coexpr = 1; ; - } break; -case 189: -# line 419 "cgram.g" -{ - yyval =tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0])); proc_lst->has_coexpr = 1; ; - } break; -case 190: -# line 423 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0) ;} break; -case 191: -# line 424 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0) ;} break; -case 192: -# line 425 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0])) ;} break; -case 193: -# line 426 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0])) ;} break; -case 194: -# line 428 "cgram.g" -{yyval = sect_nd(yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]) ;} break; -case 195: -# line 430 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 196: -# line 431 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 197: -# line 432 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 199: -# line 435 "cgram.g" -{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; - } - goto yystack; /* reset registers in driver code */ -} diff --git a/src/iconc/cproto.h b/src/iconc/cproto.h deleted file mode 100644 index a32b982..0000000 --- a/src/iconc/cproto.h +++ /dev/null @@ -1,165 +0,0 @@ -/* - * Prototypes for functions in iconc. - */ -struct sig_lst *add_sig (struct code *sig, struct c_fnc *fnc); -void addlib (char *libname); -struct code *alc_ary (int n); -int alc_cbufs (int num, nodeptr lifetime); -int alc_dtmp (nodeptr lifetime); -int alc_itmp (nodeptr lifetime); -struct code *alc_lbl (char *desc, int flag); -int alc_sbufs (int num, nodeptr lifetime); -#ifdef OptimizeType -unsigned int *alloc_mem_typ (unsigned int n_types); -#endif /* OptimizeType */ -void arth_anlz (struct il_code *var1, struct il_code *var2, - int *maybe_int, int *maybe_dbl, int *chk1, - struct code **conv1p, int *chk2, - struct code **conv2p); -struct node *aug_nd (nodeptr op, nodeptr arg1, nodeptr arg2); -struct node *binary_nd (nodeptr op, nodeptr arg1, nodeptr arg2); -void bitrange (int typcd, int *frst_bit, int *last_bit); -nodeptr buildarray (nodeptr a, nodeptr lb, nodeptr e); -void callc_add (struct c_fnc *cont); -void callo_add (char *oper_nm, int ret_flag, - struct c_fnc *cont, int need_cont, - struct code *arglist, struct code *on_ret); -struct node *case_nd (nodeptr loc_model, nodeptr expr, nodeptr cases); -int ccomp (char *srcname, char *exename); -void cd_add (struct code *cd); -struct val_loc *chk_alc (struct val_loc *rslt, nodeptr lifetime); -void chkinv (void); -void chkstrinv (void); -struct node *c_str_leaf (int type,struct node *loc_model, char *c); -void codegen (struct node *t); -int cond_anlz (struct il_code *il, struct code **cdp); -void const_blks (void); -struct val_loc *cvar_loc (char *name); -int do_inlin (struct implement *impl, nodeptr n, int *sep_cont, - struct op_symentry *symtab, int n_va); -void doiconx (char *s); -struct val_loc *dtmp_loc (int n); -void eval_arith (int indx1, int indx2, int *maybe_int, int *maybe_dbl); -int eval_cnv (int typcd, int indx, int def, int *cnv_flags); -int eval_is (int typcd,int indx); -void findcases (struct il_code *il, int has_dflt, - struct case_anlz *case_anlz); -void fix_fncs (struct c_fnc *fnc); -struct fentry *flookup (char *id); -void gen_inlin (struct il_code *il, struct val_loc *rslt, - struct code **scont_strt, - struct code **scont_fail, struct c_fnc *cont, - struct implement *impl, int nsyms, - struct op_symentry *symtab, nodeptr n, - int dcl_var, int n_va); -int getopr (int ac, int *cc); -#ifdef OptimizeType -unsigned int get_bit_vector (struct typinfo *src, int pos); -#endif /* OptimizeType */ -struct gentry *glookup (char *id); -void hsyserr (char **av, char *file); -struct node *i_str_leaf (int type,struct node *loc_model,char *c, int d); -long iconint (char *image); -struct code *il_copy (struct il_c *dest, struct val_loc *src); -struct code *il_cnv (int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest); -struct code *il_dflt (int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest); -void implproto (struct implement *ip); -void init (void); -void init_proc (char *name); -void init_rec (char *name); -void init_src (void); -void install (char *name,int flag); -struct gentry *instl_p (char *name, int flag); -struct node *int_leaf (int type,struct node *loc_model,int c); -struct val_loc *itmp_loc (int n); -struct node *invk_main (struct pentry *main_proc); -struct node *invk_nd (struct node *loc_model, struct node *proc, - struct node *args); -void invoc_grp (char *grp); -void invocbl (nodeptr op, int arity); -struct node *key_leaf (nodeptr loc_model, char *keyname); -void liveness (nodeptr n, nodeptr resumer, nodeptr *failer, int *gen); -struct node *list_nd (nodeptr loc_model, nodeptr args); -void lnkdcl (char *name); -void readdb (char *db_name); -struct val_loc *loc_cpy (struct val_loc *loc, int mod_access); -#ifdef OptimizeType -void mark_recs (struct fentry *fp, struct typinfo *typ, - int *num_offsets, int *offset, int *bad_recs); -#else /* OptimizeType */ -void mark_recs (struct fentry *fp, unsigned int *typ, - int *num_offsets, int *offset, int *bad_recs); -#endif /* OptimizeType */ -struct code *mk_goto (struct code *label); -struct node *multiunary (char *op, nodeptr loc_model, nodeptr oprnd); -struct sig_act *new_sgact (struct code *sig, struct code *cd, - struct sig_act *next); -int nextchar (void); -void nfatal (struct node *n, char *s1, char *s2); -int n_arg_sym (struct implement *ip); -void outerfnc (struct c_fnc *fnc); -int past_prms (struct node *n); -void proccode (struct pentry *proc); -void prt_fnc (struct c_fnc *fnc); -void prt_frame (char *prefix, int ntend, int n_itmp, - int i, int j, int k); -struct centry *putlit (char *image,int littype,int len); -struct lentry *putloc (char *id,int id_type); -void quit (char *msg); -void quitf (char *msg,char *arg); -void recconstr (struct rentry *r); -void resolve (struct pentry *proc); -unsigned int round2 (unsigned int n); -struct code *sig_cd (struct code *fail, struct c_fnc *fnc); -void src_file (char *name); -struct node *sect_nd (nodeptr op, nodeptr arg1, nodeptr arg2, - nodeptr arg3); -void tfatal (char *s1,char *s2); -struct node *to_nd (nodeptr loc_model, nodeptr arg1, - nodeptr arg2); -struct node *toby_nd (nodeptr loc_model, nodeptr arg1, - nodeptr arg2, nodeptr arg3); -int trans (void); -struct node *tree1 (int type); -struct node *tree2 (int type,struct node *loc_model); -struct node *tree3 (int type,struct node *loc_model, - struct node *c); -struct node *tree4 (int type, struct node *loc_model, - struct node *c, struct node *d); -struct node *tree5 (int type, struct node *loc_model, - struct node *c, struct node *d, - struct node *e); -struct node *tree6 (int type,struct node *loc_model, - struct node *c, struct node *d, - struct node *e, struct node *f); -void tsyserr (char *s); -void twarn (char *s1,char *s2); -struct code *typ_chk (struct il_code *var, int typcd); -int type_case (struct il_code *il, int (*fnc)(), - struct case_anlz *case_anlz); -void typeinfer (void); -struct node *unary_nd (nodeptr op, nodeptr arg); -void var_dcls (void); -#ifdef OptimizeType -int varsubtyp (struct typinfo *typ, struct lentry **single); -#else /* OptimizeType */ -int varsubtyp (unsigned int *typ, struct lentry **single); -#endif /* OptimizeType */ -void writecheck (int rc); -void yyerror (int tok,struct node *lval,int state); -int yylex (void); -int yyparse (void); -#ifdef OptimizeType -void xfer_packed_types (struct typinfo *type); -#endif /* OptimizeType */ - -#ifdef DeBug -void symdump (void); -void ldump (struct lentry **lhash); -void gdump (void); -void cdump (void); -void fdump (void); -void rdump (void); -#endif /* DeBug */ diff --git a/src/iconc/csym.c b/src/iconc/csym.c deleted file mode 100644 index 8e764e3..0000000 --- a/src/iconc/csym.c +++ /dev/null @@ -1,853 +0,0 @@ -/* - * csym.c -- functions for symbol table management. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "ctree.h" -#include "ctoken.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes. - */ - -static struct gentry *alcglob (struct gentry *blink, - char *name,int flag); -static struct fentry *alcfld (struct fentry *blink, char *name, - struct par_rec *rp); -static struct centry *alclit (struct centry *blink, - char *image, int len,int flag); -static struct lentry *alcloc (struct lentry *blink, - char *name,int flag); -static struct par_rec *alcprec (struct rentry *rec, int offset, - struct par_rec *next); -static struct centry *clookup (char *image,int flag); -static struct lentry *dcl_loc (char *id, int id_type, - struct lentry *next); -static struct lentry *llookup (char *id); -static void opstrinv (struct implement *ip); -static struct gentry *putglob (char *id,int id_type); -static struct gentry *try_gbl (char *id); - -int max_sym = 0; /* max number of parameter symbols in run-time routines */ -int max_prm = 0; /* max number of parameters for any invocable routine */ - -/* - * The operands of the invocable declaration are stored in a list for - * later processing. - */ -struct strinv { - nodeptr op; - int arity; - struct strinv *next; - }; -struct strinv *strinvlst = NULL; -int op_tbl_sz; - -struct pentry *proc_lst = NULL; /* procedure list */ -struct rentry *rec_lst = NULL; /* record list */ - - -/* - *instl_p - install procedure or record in global symbol table, returning - * the symbol table entry. - */ -struct gentry *instl_p(name, flag) -char *name; -int flag; - { - struct gentry *gp; - - flag |= F_Global; - if ((gp = glookup(name)) == NULL) - gp = putglob(name, flag); - else if ((gp->flag & (~F_Global)) == 0) { - /* - * superfluous global declaration for record or proc - */ - gp->flag |= flag; - } - else /* the user can't make up his mind */ - tfatal("inconsistent redeclaration", name); - return gp; - } - -/* - * install - put an identifier into the global or local symbol table. - * The basic idea here is to look in the right table and install - * the identifier if it isn't already there. Some semantic checks - * are performed. - */ -void install(name, flag) -char *name; -int flag; - { - struct fentry *fp; - struct gentry *gp; - struct lentry *lp; - struct par_rec **rpp; - struct fldname *fnp; - int foffset; - - switch (flag) { - case F_Global: /* a variable in a global declaration */ - if ((gp = glookup(name)) == NULL) - putglob(name, flag); - else - gp->flag |= flag; - break; - - case F_Static: /* static declaration */ - ++proc_lst->nstatic; - lp = dcl_loc(name, flag, proc_lst->statics); - proc_lst->statics = lp; - break; - - case F_Dynamic: /* local declaration */ - ++proc_lst->ndynam; - lp = dcl_loc(name, flag, proc_lst->dynams); - proc_lst->dynams = lp; - break; - - case F_Argument: /* formal parameter */ - ++proc_lst->nargs; - if (proc_lst->nargs > max_prm) - max_prm = proc_lst->nargs; - lp = dcl_loc(name, flag, proc_lst->args); - proc_lst->args = lp; - break; - - case F_Field: /* field declaration */ - fnp = NewStruct(fldname); - fnp->name = name; - fnp->next = rec_lst->fields; - rec_lst->fields = fnp; - foffset = rec_lst->nfields++; - if (foffset > max_prm) - max_prm = foffset; - if ((fp = flookup(name)) == NULL) { - /* - * first occurrence of this field name. - */ - fhash[FHasher(name)] = alcfld(fhash[FHasher(name)], name, - alcprec(rec_lst, foffset, NULL)); - } - else { - rpp = &(fp->rlist); - while (*rpp != NULL && (*rpp)->offset <= foffset && - (*rpp)->rec != rec_lst) - rpp = &((*rpp)->next); - if (*rpp == NULL || (*rpp)->offset > foffset) - *rpp = alcprec(rec_lst, foffset, *rpp); - else - tfatal("duplicate field name", name); - } - break; - - default: - tsyserr("install: unrecognized symbol table flag."); - } - } - -/* - * dcl_loc - handle declaration of a local identifier. - */ -static struct lentry *dcl_loc(name, flag, next) -char *name; -int flag; -struct lentry *next; - { - register struct lentry *lp; - - if ((lp = llookup(name)) == NULL) { - lp = putloc(name,flag); - lp->next = next; - } - else if (lp->flag == flag) /* previously declared as same type */ - twarn("redeclared identifier", name); - else /* previously declared as different type */ - tfatal("inconsistent redeclaration", name); - return lp; - } - -/* - * putloc - make a local symbol table entry and return pointer to it. - */ -struct lentry *putloc(id,id_type) -char *id; -int id_type; - { - register struct lentry *ptr; - register struct lentry **lhash; - unsigned hashval; - - if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */ - lhash = proc_lst->lhash; - hashval = LHasher(id); - ptr = alcloc(lhash[hashval], id, id_type); - lhash[hashval] = ptr; - ptr->next = NULL; - } - return ptr; - } - -/* - * putglob makes a global symbol table entry and returns a pointer to it. - */ -static struct gentry *putglob(id, id_type) -char *id; -int id_type; - { - register struct gentry *ptr; - register unsigned hashval; - - if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */ - hashval = GHasher(id); - ptr = alcglob(ghash[hashval], id, id_type); - ghash[hashval] = ptr; - } - return ptr; - } - -/* - * putlit makes a constant symbol table entry and returns a pointer to it. - */ -struct centry *putlit(image, littype, len) -char *image; -int len, littype; - { - register struct centry *ptr; - register unsigned hashval; - - if ((ptr = clookup(image,littype)) == NULL) { /* add to head of hash chain */ - hashval = CHasher(image); - ptr = alclit(chash[hashval], image, len, littype); - chash[hashval] = ptr; - } - return ptr; - } - -/* - * llookup looks up id in local symbol table and returns pointer to - * to it if found or NULL if not present. - */ - -static struct lentry *llookup(id) -char *id; - { - register struct lentry *ptr; - - ptr = proc_lst->lhash[LHasher(id)]; - while (ptr != NULL && ptr->name != id) - ptr = ptr->blink; - return ptr; - } - -/* - * flookup looks up id in flobal symbol table and returns pointer to - * to it if found or NULL if not present. - */ -struct fentry *flookup(id) -char *id; - { - register struct fentry *ptr; - - ptr = fhash[FHasher(id)]; - while (ptr != NULL && ptr->name != id) { - ptr = ptr->blink; - } - return ptr; - } - -/* - * glookup looks up id in global symbol table and returns pointer to - * to it if found or NULL if not present. - */ -struct gentry *glookup(id) -char *id; - { - register struct gentry *ptr; - - ptr = ghash[GHasher(id)]; - while (ptr != NULL && ptr->name != id) { - ptr = ptr->blink; - } - return ptr; - } - -/* - * clookup looks up id in constant symbol table and returns pointer to - * to it if found or NULL if not present. - */ -static struct centry *clookup(image,flag) -char *image; -int flag; - { - register struct centry *ptr; - - ptr = chash[CHasher(image)]; - while (ptr != NULL && (ptr->image != image || ptr->flag != flag)) - ptr = ptr->blink; - - return ptr; - } - -#ifdef DeBug -/* - * symdump - dump symbol tables. - */ -void symdump() - { - struct pentry *proc; - - gdump(); - cdump(); - rdump(); - fdump(); - for (proc = proc_lst; proc != NULL; proc = proc->next) { - fprintf(stderr,"\n"); - fprintf(stderr,"Procedure %s\n", proc->sym_entry->name); - ldump(proc->lhash); - } - } - -/* - * prt_flgs - print flags from a symbol table entry. - */ -static void prt_flgs(flags) -int flags; - { - if (flags & F_Global) - fprintf(stderr, " F_Global"); - if (flags & F_Proc) - fprintf(stderr, " F_Proc"); - if (flags & F_Record) - fprintf(stderr, " F_Record"); - if (flags & F_Dynamic) - fprintf(stderr, " F_Dynamic"); - if (flags & F_Static) - fprintf(stderr, " F_Static"); - if (flags & F_Builtin) - fprintf(stderr, " F_Builtin"); - if (flags & F_StrInv) - fprintf(stderr, " F_StrInv"); - if (flags & F_ImpError) - fprintf(stderr, " F_ImpError"); - if (flags & F_Argument) - fprintf(stderr, " F_Argument"); - if (flags & F_IntLit) - fprintf(stderr, " F_IntLit"); - if (flags & F_RealLit) - fprintf(stderr, " F_RealLit"); - if (flags & F_StrLit) - fprintf(stderr, " F_StrLit"); - if (flags & F_CsetLit) - fprintf(stderr, " F_CsetLit"); - if (flags & F_Field) - fprintf(stderr, " F_Field"); - fprintf(stderr, "\n"); - } -/* - * ldump displays local symbol table to stderr. - */ - -void ldump(lhash) -struct lentry **lhash; - { - register int i; - register struct lentry *lptr; - - fprintf(stderr," Dump of local symbol table\n"); - fprintf(stderr," address name globol-ref flags\n"); - for (i = 0; i < LHSize; i++) - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { - fprintf(stderr," %8x %20s ", lptr, lptr->name); - if (lptr->flag & F_Global) - fprintf(stderr, "%8x ", lptr->val.global); - else - fprintf(stderr, " - "); - prt_flgs(lptr->flag); - } - fflush(stderr); - } - -/* - * gdump displays global symbol table to stderr. - */ - -void gdump() - { - register int i; - register struct gentry *gptr; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of global symbol table\n"); - fprintf(stderr," address name nargs flags\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - fprintf(stderr," %8x %20s %4d ", gptr, - gptr->name, gptr->nargs); - prt_flgs(gptr->flag); - } - fflush(stderr); - } - -/* - * cdump displays constant symbol table to stderr. - */ - -void cdump() - { - register int i; - register struct centry *cptr; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of constant symbol table\n"); - fprintf(stderr, - " address value flags\n"); - for (i = 0; i < CHSize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { - fprintf(stderr," %8x %-40.40s ", cptr, cptr->image); - prt_flgs(cptr->flag); - } - fflush(stderr); - } - -/* - * fdump displays field symbol table to stderr. - */ -void fdump() - { - int i; - struct par_rec *prptr; - struct fentry *fp; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of field symbol table\n"); - fprintf(stderr, - " address field global-ref offset\n"); - for (i = 0; i < FHSize; i++) - for (fp = fhash[i]; fp != NULL; fp = fp->blink) { - fprintf(stderr," %8x %20s\n", fp, fp->name); - for (prptr = fp->rlist; prptr != NULL; prptr = prptr->next) - fprintf(stderr," %8x %4d\n", - prptr->sym_entry, prptr->offset); - } - fflush(stderr); - } - -/* - * prt_flds - print a list of fields stored in reverse order. - */ -static void prt_flds(f) -struct fldname *f; - { - if (f == NULL) - return; - prt_flds(f->next); - fprintf(stderr, " %s", f->name); - } - -/* - * rdump displays list of records and their fields. - */ -void rdump() - { - struct rentry *rp; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of record list\n"); - fprintf(stderr, " global-ref fields\n"); - for (rp = rec_lst; rp != NULL; rp = rp->next) { - fprintf(stderr, " %8x ", rp->sym_entry); - prt_flds(rp->fields); - fprintf(stderr, "\n"); - } - } -#endif /* DeBug */ - -/* - * alcloc allocates a local symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct lentry *alcloc(blink, name, flag) -struct lentry *blink; -char *name; -int flag; - { - register struct lentry *lp; - - lp = NewStruct(lentry); - lp->blink = blink; - lp->name = name; - lp->flag = flag; - return lp; - } - -/* - * alcfld allocates a field symbol table entry, fills in the entry with - * specified values and returns pointer to new entry. - */ -static struct fentry *alcfld(blink, name, rp) -struct fentry *blink; -char *name; -struct par_rec *rp; - { - register struct fentry *fp; - - fp = NewStruct(fentry); - fp->blink = blink; - fp->name = name; - fp->rlist = rp; - return fp; - } - -/* - * alcglob allocates a global symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct gentry *alcglob(blink, name, flag) -struct gentry *blink; -char *name; -int flag; - { - register struct gentry *gp; - - gp = NewStruct(gentry); - gp->blink = blink; - gp->name = name; - gp->flag = flag; - return gp; - } - -/* - * alclit allocates a constant symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct centry *alclit(blink, image, len, flag) -struct centry *blink; -char *image; -int len, flag; - { - register struct centry *cp; - - cp = NewStruct(centry); - cp->blink = blink; - cp->image = image; - cp->length = len; - cp->flag = flag; - switch (flag) { - case F_IntLit: - cp->u.intgr = iconint(image); - break; - case F_CsetLit: - cp->u.cset = bitvect(image, len); - break; - } - return cp; - } - -/* - * alcprec allocates an entry for the parent record list for a field. - */ -static struct par_rec *alcprec(rec, offset, next) -struct rentry *rec; -int offset; -struct par_rec *next; - { - register struct par_rec *rp; - - rp = NewStruct(par_rec); - rp->rec= rec; - rp->offset = offset; - rp->next = next; - return rp; - } - -/* - * resolve - resolve the scope of undeclared identifiers. - */ -void resolve(proc) -struct pentry *proc; - { - struct lentry **lhash; - register struct lentry *lp; - struct gentry *gp; - int i; - char *id; - - lhash = proc->lhash; - - for (i = 0; i < LHSize; ++i) { - lp = lhash[i]; - while (lp != NULL) { - id = lp->name; - if (lp->flag == 0) { /* undeclared */ - if ((gp = try_gbl(id)) != NULL) { /* check global */ - lp->flag = F_Global; - lp->val.global = gp; - } - else { /* implicit local */ - if (uwarn) { - fprintf(stderr, "%s undeclared identifier, procedure %s\n", - id, proc->name); - ++twarns; - } - lp->flag = F_Dynamic; - lp->next = proc->dynams; - proc->dynams = lp; - ++proc->ndynam; - } - } - lp = lp->blink; - } - } - } - -/* - * try_glb - see if the identifier is or should be a global variable. - */ -static struct gentry *try_gbl(id) -char *id; - { - struct gentry *gp; - register struct implement *iptr; - int nargs; - int n; - - gp = glookup(id); - if (gp == NULL) { - /* - * See if it is a built-in function. - */ - iptr = db_ilkup(id, bhash); - if (iptr == NULL) - return NULL; - else { - if (iptr->in_line == NULL) - nfatal(NULL, "built-in function not installed", id); - nargs = iptr->nargs; - if (nargs > 0 && iptr->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; - gp = putglob(id, F_Global | F_Builtin); - gp->val.builtin = iptr; - - n = n_arg_sym(iptr); - if (n > max_sym) - max_sym = n; - } - } - return gp; - } - -/* - * invoc_grp - called when "invocable all" is encountered. - */ -void invoc_grp(grp) -char *grp; - { - if (grp == spec_str("all")) - str_inv = 1; /* enable full string invocation */ - else - tfatal("invalid operand to invocable", grp); - } - -/* - * invocbl - indicate that the operator is needed for for string invocation. - */ -void invocbl(op, arity) -nodeptr op; -int arity; - { - struct strinv *si; - - si = NewStruct(strinv); - si->op = op; - si->arity = arity; - si->next = strinvlst; - strinvlst = si; - } - -/* - * chkstrinv - check to see what is needed for string invocation. - */ -void chkstrinv() - { - struct strinv *si; - struct gentry *gp; - struct implement *ip; - char *op_name; - int arity; - int i; - - /* - * A table of procedure blocks for operators is set up for use by - * string invocation. - */ - op_tbl_sz = 0; - fprintf(codefile, "\nstatic B_IProc(2) init_op_tbl[OpTblSz]"); - - if (str_inv) { - /* - * All operations must be available for string invocation. Make sure all - * built-in functions have either been hidden by global declarations - * or are in global variables, make sure no global variables are - * optimized away, and make sure all operations are in the table of - * operations. - */ - for (i = 0; i < IHSize; ++i) /* built-in function table */ - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - try_gbl(ip->name); - for (i = 0; i < GHSize; i++) /* global symbol table */ - for (gp = ghash[i]; gp != NULL; gp = gp->blink) - gp->flag |= F_StrInv; - for (i = 0; i < IHSize; ++i) /* operator table */ - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - opstrinv(ip); - } - else { - /* - * selected operations must be available for string invocation. - */ - for (si = strinvlst; si != NULL; si = si->next) { - op_name = Str0(si->op); - if (isalpha(*op_name) || (*op_name == '_')) { - /* - * This needs to be something in a global variable: function, - * procedure, or constructor. - */ - gp = try_gbl(op_name); - if (gp == NULL) - nfatal(si->op, "not available for string invocation", op_name); - else - gp->flag |= F_StrInv; - } - else { - /* - * must be an operator. - */ - arity = si->arity; - i = IHasher(op_name); - for (ip = ohash[i]; ip != NULL && ip->op != op_name; - ip = ip->blink) - ; - if (arity < 0) { - /* - * Operators of all arities with this symbol. - */ - while (ip != NULL && ip->op == op_name) { - opstrinv(ip); - ip = ip->blink; - } - } - else { - /* - * Operator of a specific arity. - */ - while (ip != NULL && ip->nargs != arity) - ip = ip->blink; - if (ip == NULL || ip->op != op_name) - nfatal(si->op, "not available for string invocation", - op_name); - else - opstrinv(ip); - } - } - } - } - - /* - * Add definitions to the header file indicating the size of the operator - * table and finish the declaration in the code file. - */ - if (op_tbl_sz == 0) { - fprintf(inclfile, "#define OpTblSz 1\n"); - fprintf(inclfile, "int op_tbl_sz = 0;\n"); - fprintf(codefile, ";\n"); - } - else { - fprintf(inclfile, "#define OpTblSz %d\n", op_tbl_sz); - fprintf(inclfile, "int op_tbl_sz = OpTblSz;\n"); - fprintf(codefile, "\n };\n"); - } - } - -/* - * opstrinv - set up string invocation for an operator. - */ -static void opstrinv(ip) -struct implement *ip; - { - char c1, c2; - char *name; - char *op; - register char *s; - int nargs; - int n; - - if (ip == NULL || ip->iconc_flgs & InStrTbl) - return; - - /* - * Keep track of the maximum number of argument symbols in any operation - * so type inference can allocate enough storage for the worst case of - * general invocation. - */ - n = n_arg_sym(ip); - if (n > max_sym) - max_sym = n; - - name = ip->name; - c1 = ip->prefix[0]; - c2 = ip->prefix[1]; - op = ip->op; - nargs = ip->nargs; - if (ip->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; /* indicate varargs with negative number of params */ - - if (op_tbl_sz++ == 0) { - fprintf(inclfile, "\n"); - fprintf(codefile, " = {\n"); - } - else - fprintf(codefile, ",\n"); - implproto(ip); /* output prototype */ - - /* - * Output procedure block for this operator into table used by string - * invocation. - */ - fprintf(codefile, " {T_Proc, 11, O%c%c_%s, %d, -1, 0, 0, {{%d, \"", c1, c2, - name, nargs, strlen(op)); - for (s = op; *s != '\0'; ++s) { - if (*s == '\\') - fprintf(codefile, "\\"); - fprintf(codefile, "%c", *s); - } - fprintf(codefile, "\"}}}"); - ip->iconc_flgs |= InStrTbl; - } - -/* - * n_arg_sym - determine the number of argument symbols (dereferenced - * and undereferenced arguments are separate symbols) for an operation - * in the data base. - */ -int n_arg_sym(ip) -struct implement *ip; - { - int i; - int num; - - num = 0; - for (i = 0; i < ip->nargs; ++i) { - if (ip->arg_flgs[i] & RtParm) - ++num; - if (ip->arg_flgs[i] & DrfPrm) - ++num; - } - return num; - } diff --git a/src/iconc/csym.h b/src/iconc/csym.h deleted file mode 100644 index cf104af..0000000 --- a/src/iconc/csym.h +++ /dev/null @@ -1,380 +0,0 @@ -/* - * Structures for symbol table entries. - */ - -#define MaybeTrue 1 /* condition might be true at run time */ -#define MaybeFalse 2 /* condition might be false at run time */ - -#define MayConvert 1 /* type conversion may convert the value */ -#define MayDefault 2 /* defaulting type conversion may use default */ -#define MayKeep 4 /* conversion may succeed without any actual conversion */ - -#ifdef OptimizeType -#define NULL_T 0x1000000 -#define REAL_T 0x2000000 -#define INT_T 0x4000000 -#define CSET_T 0x8000000 -#define STR_T 0x10000000 - -#define TYPINFO_BLOCK 400000 - -/* - * Optimized type structure for bit vectors - * All previous occurencess of unsigned int * (at least - * when refering to bit vectors) have been replaced by - * struct typinfo. - */ -struct typinfo { - unsigned int packed; /* packed representation of types */ - unsigned int *bits; /* full length bit vector */ -}; -#endif /* OptimizeType */ - -/* - * Data base type codes are mapped to type inferencing information using - * an array. - */ -struct typ_info { - int frst_bit; /* first bit in bit vector allocated to this type */ - int num_bits; /* number of bits in bit vector allocated to this type */ - int new_indx; /* index into arrays of allocated types for operation */ -#ifdef OptimizeType - struct typinfo *typ; /* for variables: initial type */ -#else /* OptimizeType */ - unsigned int *typ; /* for variabled: initial type */ -#endif /* OptimizeType */ - }; - -/* - * A type is a bit vector representing a union of basic types. There - * are 3 sizes of types: first class types (Icon language types), - * intermediate value types (first class types plus variable references), - * run-time routine types (intermediate value types plus internal - * references to descriptors such as set elements). When the size of - * the type is known from context, a simple bit vector can be used. - * In other contexts, the size must be included. - */ -struct type { - int size; -#ifdef OptimizeType - struct typinfo *bits; -#else /* OptimizeType */ - unsigned int *bits; -#endif /* OptimizeType */ - struct type *next; - }; - - -#define DecodeSize(x) (x & 0xFFFFFF) -#define DecodePacked(x) (x >> 24) -/* - * NumInts - convert from the number of bits in a bit vector to the - * number of integers implementing it. - */ -#define NumInts(n_bits) (n_bits - 1) / IntBits + 1 - -/* - * ClrTyp - zero out the bit vector for a type. - */ -#ifdef OptimizeType -#define ClrTyp(size,typ) {\ - int typ_indx;\ - if ((typ)->bits == NULL)\ - clr_packed((typ),(size));\ - else\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (typ)->bits[typ_indx] = 0;} -#else /* OptimizeType */ -#define ClrTyp(size,typ) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (typ)[typ_indx] = 0;} -#endif /* OptimizeType */ - -/* - * CpyTyp - copy a type of the given size from one bit vector to another. - */ -#ifdef OptimizeType -#define CpyTyp(nsize,src,dest) {\ - int typ_indx, num;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ - ClrTyp((nsize),(dest));\ - cpy_packed_to_packed((src),(dest),(nsize));\ - }\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ - ClrTyp((nsize),(dest));\ - xfer_packed_to_bits((src),(dest),(nsize));\ - }\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] = (src)->bits[typ_indx];\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] = (src)->bits[typ_indx];} -#else /* OptimizeType */ -#define CpyTyp(size,src,dest) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (dest)[typ_indx] = (src)[typ_indx];} -#endif /* OptimizeType */ - -/* - * MrgTyp - merge a type of the given size from one bit vector into another. - */ -#ifdef OptimizeType -#define MrgTyp(nsize,src,dest) {\ - int typ_indx;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL))\ - mrg_packed_to_packed((src),(dest),(nsize));\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL))\ - xfer_packed_to_bits((src),(dest),(nsize));\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];} -#else /* OptimizeType */ -#define MrgTyp(size,src,dest) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (dest)[typ_indx] |= (src)[typ_indx];} -#endif /* OptimizeType */ - -/* - * ChkMrgTyp - merge a type of the given size from one bit vector into another, - * updating the changed flag if the destination is changed by the merger. - */ -#ifdef OptimizeType -#define ChkMrgTyp(nsize,src,dest) {\ - int typ_indx, ret; unsigned int old;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ - ret = mrg_packed_to_packed((src),(dest),(nsize));\ - changed += ret;\ - }\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ - ret = xfer_packed_to_bits((src),(dest),(nsize));\ - changed += ret;\ - }\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ - old = (dest)->bits[typ_indx];\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - if (old != (dest)->bits[typ_indx]) ++changed;}\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ - old = (dest)->bits[typ_indx];\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - if (old != (dest)->bits[typ_indx]) ++changed;}} -#else /* OptimizeType */ -#define ChkMrgTyp(size,src,dest) {\ - int typ_indx; unsigned int old;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx) {\ - old = (dest)[typ_indx];\ - (dest)[typ_indx] |= (src)[typ_indx];\ - if (old != (dest)[typ_indx]) ++changed;}} -#endif /* OptimizeType */ - - -struct centry { /* constant table entry */ - struct centry *blink; /* link for bucket chain */ - char *image; /* pointer to string image of literal */ - int length; /* length of string */ - union { - unsigned short *cset; /* pointer to bit string for cset literal */ - long intgr; /* value of integer literal */ - } u; - uword flag; /* type of literal flag */ - char prefix[PrfxSz+1]; /* unique prefix used in data block name */ - }; - -struct fentry { /* field table entry */ - struct fentry *blink; /* link for bucket chain */ - char *name; /* name of field */ - struct par_rec *rlist; /* head of list of records */ - }; - -struct lentry { /* local table entry */ - struct lentry *blink; /* link for bucket chain */ - char *name; /* name of variable */ - uword flag; /* variable flags */ - union { - struct gentry *global; /* for globals: global symbol table entry */ - int index; /* type index; run-time descriptor index */ - } val; - struct lentry *next; /* used for linking a class of variables */ - }; - -struct gentry { /* global table entry */ - struct gentry *blink; /* link for bucket chain */ - char *name; /* name of variable */ - uword flag; /* variable flags */ - union { - struct implement *builtin; /* pointer to built-in function */ - struct pentry *proc; /* pointer to procedure entry */ - struct rentry *rec; /* pointer to record entry */ - } val; - int index; /* index into global array */ - int init_type; /* initial type if procedure */ - }; - -/* - * Structure for list of parent records for a field name. - */ -struct par_rec { - struct rentry *rec; /* parent record */ - int offset; /* field's offset within this record */ - int mark; /* used during code generation */ - struct par_rec *next; - }; - -/* - * Structure for a procedure. - */ -struct pentry { - char *name; /* name of procedure */ - char prefix[PrfxSz+1]; /* prefix to make name unique */ - struct lentry **lhash; /* hash area for procedure's local table */ - int nargs; /* number of args */ - struct lentry *args; /* list of arguments in reverse order */ - int ndynam; /* number of dynamic locals */ - struct lentry *dynams; /* list of dynamics in reverse order */ - int nstatic; /* number of statics */ - struct lentry *statics; /* list of statics in reverse order */ - struct node *tree; /* syntax tree for procedure */ - int has_coexpr; /* this procedure contains co-expressions */ - int tnd_loc; /* number of tended dynamic locals */ - int ret_flag; /* proc returns, suspends, and/or fails */ - int reachable; /* this procedure may be executed */ - int iteration; /* last iteration of type inference performed */ - int arg_lst; /* for varargs - the type number of the list */ -#ifdef OptimizeType - struct typinfo *ret_typ; /* type returned from procedure */ -#else /* OptimizeType */ - unsigned int *ret_typ; /* type returned from procedure */ -#endif /* OptimizeType */ - struct store *in_store; /* store at start of procedure */ - struct store *susp_store; /* store for resumption points of procedure */ - struct store *out_store; /* store on exiting procedure */ - struct lentry **vartypmap; /* mapping from var types to symtab entries */ -#ifdef OptimizeType - struct typinfo *coexprs; /* co-expressions in which proc may be called */ -#else /* OptimizeType */ - unsigned int *coexprs; /* co-expressions in which proc may be called */ -#endif /* OptimizeType */ - struct pentry *next; - }; - -/* - * Structure for a record. - */ -struct rentry { - char *name; /* name of record */ - char prefix[PrfxSz+1]; /* prefix to make name unique */ - int frst_fld; /* offset of variable type of 1st field */ - int nfields; /* number of fields */ - struct fldname *fields; /* list of field names in reverse order */ - int rec_num; /* id number for record */ - struct rentry *next; - }; - -struct fldname { /* record field */ - char *name; /* field name */ - struct fldname *next; - }; - -/* - * Structure used to analyze whether a type_case statement can be in-lined. - * Only one type check is supported: the type_case will be implemented - * as an "if" statement. - */ -struct case_anlz { - int n_cases; /* number of cases actually needed for this use */ - int typcd; /* for "if" optimization, the type code to check */ - struct il_code *il_then; /* for "if" optimization, the then clause */ - struct il_code *il_else; /* for "if" optimization, the else clause */ - }; - -/* - * spec_op contains the implementations for operations with do not have - * standard unary/binary syntax. - */ -#define ToOp 0 /* index into spec_op of i to j */ -#define ToByOp 1 /* index into spec_op of i to j by k */ -#define SectOp 2 /* index into spec_op of x[i:j] */ -#define SubscOp 3 /* index into spec_op of x[i] */ -#define ListOp 4 /* index into spec_op of [e1, e2, ... ] */ -#define NumSpecOp 5 -extern struct implement *spec_op[NumSpecOp]; - -/* - * Flag values. - */ - -#define F_Global 01 /* variable declared global externally */ -#define F_Proc 04 /* procedure */ -#define F_Record 010 /* record */ -#define F_Dynamic 020 /* variable declared local dynamic */ -#define F_Static 040 /* variable declared local static */ -#define F_Builtin 0100 /* identifier refers to built-in procedure */ -#define F_StrInv 0200 /* variable needed for string invocation */ -#define F_ImpError 0400 /* procedure has default error */ -#define F_Argument 01000 /* variable is a formal parameter */ -#define F_IntLit 02000 /* literal is an integer */ -#define F_RealLit 04000 /* literal is a real */ -#define F_StrLit 010000 /* literal is a string */ -#define F_CsetLit 020000 /* literal is a cset */ -#define F_Field 040000 /* identifier refers to a record field */ -#define F_SmplInv 0100000 /* identifier only used in simple invocation */ - -/* - * Symbol table region pointers. - */ - -extern struct implement *bhash[]; /* hash area for built-in func table */ -extern struct centry *chash[]; /* hash area for constant table */ -extern struct fentry *fhash[]; /* hash area for field table */ -extern struct gentry *ghash[]; /* hash area for global table */ -extern struct implement *khash[]; /* hash area for keyword table */ -extern struct implement *ohash[]; /* hash area for operator table */ - -extern struct pentry *proc_lst; /* procedure list */ -extern struct rentry *rec_lst; /* record list */ - -extern int max_sym; /* max number of parameter symbols in run-time routines */ -extern int max_prm; /* max number of parameters for any invocable routine */ - -extern struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ -extern struct pentry *cur_proc; /* procedure currently being translated */ - -/* - * Hash functions for symbol tables. Note, hash table sizes (xHSize) - * are all a power of 2. - */ - -#define CHasher(x) (((word)x)&(CHSize-1)) /* constant symbol table */ -#define FHasher(x) (((word)x)&(FHSize-1)) /* field symbol table */ -#define GHasher(x) (((word)x)&(GHSize-1)) /* global symbol table */ -#define LHasher(x) (((word)x)&(LHSize-1)) /* local symbol table */ - -/* - * flags for implementation entries. - */ -#define ProtoPrint 1 /* a prototype has already been printed */ -#define InStrTbl 2 /* operator is in string table */ - -/* - * Whether an operation can fail may depend on whether error conversion - * is allowed. The following macro checks this. - */ -#define MightFail(ret_flag) ((ret_flag & DoesFail) ||\ - (err_conv && (ret_flag & DoesEFail))) diff --git a/src/iconc/ctoken.h b/src/iconc/ctoken.h deleted file mode 100644 index 1e95e98..0000000 --- a/src/iconc/ctoken.h +++ /dev/null @@ -1,111 +0,0 @@ -# define IDENT 257 -# define INTLIT 258 -# define REALLIT 259 -# define STRINGLIT 260 -# define CSETLIT 261 -# define EOFX 262 -# define BREAK 263 -# define BY 264 -# define CASE 265 -# define CREATE 266 -# define DEFAULT 267 -# define DO 268 -# define ELSE 269 -# define END 270 -# define EVERY 271 -# define FAIL 272 -# define GLOBAL 273 -# define IF 274 -# define INITIAL 275 -# define INVOCABLE 276 -# define LINK 277 -# define LOCAL 278 -# define NEXT 279 -# define NOT 280 -# define OF 281 -# define PROCEDURE 282 -# define RECORD 283 -# define REPEAT 284 -# define RETURN 285 -# define STATIC 286 -# define SUSPEND 287 -# define THEN 288 -# define TO 289 -# define UNTIL 290 -# define WHILE 291 -# define BANG 292 -# define MOD 293 -# define AUGMOD 294 -# define AND 295 -# define AUGAND 296 -# define STAR 297 -# define AUGSTAR 298 -# define INTER 299 -# define AUGINTER 300 -# define PLUS 301 -# define AUGPLUS 302 -# define UNION 303 -# define AUGUNION 304 -# define MINUS 305 -# define AUGMINUS 306 -# define DIFF 307 -# define AUGDIFF 308 -# define DOT 309 -# define SLASH 310 -# define AUGSLASH 311 -# define ASSIGN 312 -# define SWAP 313 -# define NMLT 314 -# define AUGNMLT 315 -# define REVASSIGN 316 -# define REVSWAP 317 -# define SLT 318 -# define AUGSLT 319 -# define SLE 320 -# define AUGSLE 321 -# define NMLE 322 -# define AUGNMLE 323 -# define NMEQ 324 -# define AUGNMEQ 325 -# define SEQ 326 -# define AUGSEQ 327 -# define EQUIV 328 -# define AUGEQUIV 329 -# define NMGT 330 -# define AUGNMGT 331 -# define NMGE 332 -# define AUGNMGE 333 -# define SGT 334 -# define AUGSGT 335 -# define SGE 336 -# define AUGSGE 337 -# define QMARK 338 -# define AUGQMARK 339 -# define AT 340 -# define AUGAT 341 -# define BACKSLASH 342 -# define CARET 343 -# define AUGCARET 344 -# define BAR 345 -# define CONCAT 346 -# define AUGCONCAT 347 -# define LCONCAT 348 -# define AUGLCONCAT 349 -# define TILDE 350 -# define NMNE 351 -# define AUGNMNE 352 -# define SNE 353 -# define AUGSNE 354 -# define NEQUIV 355 -# define AUGNEQUIV 356 -# define LPAREN 357 -# define RPAREN 358 -# define PCOLON 359 -# define COMMA 360 -# define MCOLON 361 -# define COLON 362 -# define SEMICOL 363 -# define LBRACK 364 -# define RBRACK 365 -# define LBRACE 366 -# define RBRACE 367 diff --git a/src/iconc/ctrans.c b/src/iconc/ctrans.c deleted file mode 100644 index 7d33ac5..0000000 --- a/src/iconc/ctrans.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * ctrans.c - main control of the translation process. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes. - */ -static void trans1 (char *filename); - -/* - * Variables. - */ -int tfatals = 0; /* total number of fatal errors */ -int twarns = 0; /* total number of warnings */ -int nocode; /* set by lexer; unused in compiler */ -int in_line; /* current input line number */ -int incol; /* current input column number */ -int peekc; /* one-character look ahead */ -struct srcfile *srclst = NULL; /* list of source files to translate */ - -static char *lpath; /* LPATH value */ - -/* - * translate a number of files, returning an error count - */ -int trans() - { - register struct pentry *proc; - struct srcfile *sf; - - lpath = getenv("LPATH"); /* remains null if unspecified */ - - for (sf = srclst; sf != NULL; sf = sf->next) - trans1(sf->name); /* translate each file in turn */ - - if (!pponly) { - /* - * Resolve undeclared references. - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) - resolve(proc); - -#ifdef DeBug - symdump(); -#endif /* DeBug */ - - if (tfatals == 0) { - chkstrinv(); /* see what needs be available for string invocation */ - chkinv(); /* perform "naive" optimizations */ - } - - if (tfatals == 0) - typeinfer(); /* perform type inference */ - - if (just_type_trace) - return tfatals; /* stop without generating code */ - - if (tfatals == 0) { - var_dcls(); /* output declarations for globals and statics */ - const_blks(); /* output blocks for cset and real literals */ - for (proc = proc_lst; proc != NULL; proc = proc->next) - proccode(proc); /* output code for a procedure */ - recconstr(rec_lst); /* output code for record constructors */ -/* ANTHONY */ -/* - print_ghash(); -*/ - } - } - - /* - * Report information about errors and warnings and be correct about it. - */ - if (tfatals == 1) - fprintf(stderr, "1 error; "); - else if (tfatals > 1) - fprintf(stderr, "%d errors; ", tfatals); - else if (verbose > 0) - fprintf(stderr, "No errors; "); - - if (twarns == 1) - fprintf(stderr, "1 warning\n"); - else if (twarns > 1) - fprintf(stderr, "%d warnings\n", twarns); - else if (verbose > 0) - fprintf(stderr, "no warnings\n"); - else if (tfatals > 0) - fprintf(stderr, "\n"); - -#ifdef TranStats - tokdump(); -#endif /* TranStats */ - - return tfatals; - } - -/* - * translate one file. - */ -static void trans1(filename) -char *filename; - { - in_line = 1; /* start with line 1, column 0 */ - incol = 0; - peekc = 0; /* clear character lookahead */ - - if (!ppinit(filename,lpath?lpath:".",m4pre)) { - tfatal(filename, "cannot open source file"); - return; - } - if (!largeints) /* undefine predef symbol if no -l option */ - ppdef("_LARGE_INTEGERS", (char *)NULL); - ppdef("_MULTITASKING", (char *)NULL); /* never defined in compiler */ - ppdef("_EVENT_MONITOR", (char *)NULL); - ppdef("_MEMORY_MONITOR", (char *)NULL); - ppdef("_VISUALIZATION", (char *)NULL); - - if (strcmp(filename,"-") == 0) - filename = "stdin"; - if (verbose > 0) - fprintf(stderr, "%s:\n",filename); - - tok_loc.n_file = filename; - in_line = 1; - - if (pponly) - ppecho(); /* preprocess only */ - else - yyparse(); /* Parse the input */ - } - -/* - * writecheck - check the return code from a stdio output operation - */ -void writecheck(rc) - int rc; - - { - if (rc < 0) - quit("unable to write to icode file"); - } - -/* - * lnkdcl - find file locally or on LPATH and add to source list. - */ -void lnkdcl(name) -char *name; -{ - struct srcfile **pp; - struct srcfile *p; - char buf[MaxPath]; - - if (pathfind(buf, lpath, name, SourceSuffix)) - src_file(buf); - else - tfatal("cannot resolve reference to file name", name); - } - -/* - * src_file - add the file name to the list of source files to be translated, - * if it is not already on the list. - */ -void src_file(name) -char *name; - { - struct srcfile **pp; - struct srcfile *p; - - for (pp = &srclst; *pp != NULL; pp = &(*pp)->next) - if (strcmp((*pp)->name, name) == 0) - return; - p = NewStruct(srcfile); - p->name = salloc(name); - p->next = NULL; - *pp = p; -} diff --git a/src/iconc/ctrans.h b/src/iconc/ctrans.h deleted file mode 100644 index 3e03d06..0000000 --- a/src/iconc/ctrans.h +++ /dev/null @@ -1,47 +0,0 @@ -/* - * Miscellaneous compiler-specific definitions. - */ - -#define Iconc - -#ifndef CUsage - #define CUsage "[-C C-comp] [-E] [-T] [-c] [-f{adelns}] [-n{acest}]\n\ - [-o ofile] [-p C-opts] [-r runtime] [-s] [-t] [-u] [-v i]" -#endif /* CUsage */ - -#define Abs(n) ((n) >= 0 ? (n) : -(n)) -#define Max(x,y) ((x)>(y)?(x):(y)) - -#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) - -/* - * Hash tables must be a power of 2. - */ -#define CHSize 128 /* size of constant hash table */ -#define FHSize 32 /* size of field hash table */ -#define GHSize 128 /* size of global hash table */ -#define LHSize 128 /* size of local hash table */ - -#define PrfxSz 3 /* size of prefix */ - -/* - * srcfile is used construct the queue of source files to be translated. - */ -struct srcfile { - char *name; - struct srcfile *next; - }; - -extern struct srcfile *srclst; - -/* - * External definitions needed throughout translator. - */ -extern int twarns; - -#ifdef TranStats -#include "tstats.h" -#else /* TranStats */ -#define TokInc(x) -#define TokDec(x) -#endif /* TranStats */ diff --git a/src/iconc/ctree.c b/src/iconc/ctree.c deleted file mode 100644 index 170a631..0000000 --- a/src/iconc/ctree.c +++ /dev/null @@ -1,777 +0,0 @@ -/* - * ctree.c -- functions for constructing parse trees. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "ctree.h" -#include "csym.h" -#include "ctoken.h" -#include "ccode.h" -#include "cproto.h" - -/* - * prototypes for static functions. - */ -static nodeptr chk_empty (nodeptr n); -static void put_elms (nodeptr t, nodeptr args, int slot); -static nodeptr subsc_nd (nodeptr op, nodeptr arg1, nodeptr arg2); - -/* - * tree[1-6] construct parse tree nodes with specified values. - * loc_model is a node containing the same line and column information - * as is needed in this node, while parameters a through d are values to - * be assigned to n_field[0-3]. Note that this could be done with a - * single routine; a separate routine for each node size is used for - * speed and simplicity. - */ - -nodeptr tree1(type) -int type; - { - register nodeptr t; - - t = NewNode(0); - t->n_type = type; - t->n_file = NULL; - t->n_line = 0; - t->n_col = 0; - t->freetmp = NULL; - return t; - } - -nodeptr tree2(type, loc_model) -int type; -nodeptr loc_model; - { - register nodeptr t; - - t = NewNode(0); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - return t; - } - -nodeptr tree3(type, loc_model, a) -int type; -nodeptr loc_model; -nodeptr a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - return t; - } - -nodeptr tree4(type, loc_model, a, b) -int type; -nodeptr loc_model; -nodeptr a, b; - { - register nodeptr t; - - t = NewNode(2); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - return t; - } - -nodeptr tree5(type, loc_model, a, b, c) -int type; -nodeptr loc_model; -nodeptr a, b, c; - { - register nodeptr t; - - t = NewNode(3); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - t->n_field[2].n_ptr = c; - return t; - } - -nodeptr tree6(type, loc_model, a, b, c, d) -int type; -nodeptr loc_model; -nodeptr a, b, c, d; - { - register nodeptr t; - - t = NewNode(4); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - t->n_field[2].n_ptr = c; - t->n_field[3].n_ptr = d; - return t; - } - -nodeptr int_leaf(type, loc_model, a) -int type; -nodeptr loc_model; -int a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = a; - return t; - } - -nodeptr c_str_leaf(type, loc_model, a) -int type; -nodeptr loc_model; -char *a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_str = a; - return t; - } - -/* - * i_str_leaf - create a leaf node containing a string and length. - */ -nodeptr i_str_leaf(type, loc_model, a, b) -int type; -nodeptr loc_model; -char *a; -int b; - { - register nodeptr t; - - t = NewNode(2); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_str = a; - t->n_field[1].n_val = b; - return t; - } - -/* - * key_leaf - create a leaf node for a keyword. - */ -nodeptr key_leaf(loc_model, keyname) -nodeptr loc_model; -char *keyname; - { - register nodeptr t; - struct implement *ip; - struct il_code *il; - char *s; - int typcd; - - /* - * Find the data base entry for the keyword, if it exists. - */ - ip = db_ilkup(keyname, khash); - - if (ip == NULL) - tfatal("invalid keyword", keyname); - else if (ip->in_line == NULL) - tfatal("keyword not installed", keyname); - else { - il = ip->in_line; - s = il->u[1].s; - if (il->il_type == IL_Const) { - /* - * This is a constant keyword, treat it as a literal. - */ - t = NewNode(1); - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - typcd = il->u[0].n; - if (typcd == cset_typ) { - t->n_type = N_Cset; - CSym0(t) = putlit(&s[1], F_CsetLit, strlen(s) - 2); - } - else if (typcd == int_typ) { - t->n_type = N_Int; - CSym0(t) = putlit(s, F_IntLit, 0); - } - else if (typcd == real_typ) { - t->n_type = N_Real; - CSym0(t) = putlit(s, F_RealLit, 0); - } - else if (typcd == str_typ) { - t->n_type = N_Str; - CSym0(t) = putlit(&s[1], F_StrLit, strlen(s) - 2); - } - return t; - } - } - - t = NewNode(2); - t->n_type = N_InvOp; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 0; /* number of arguments */ - t->n_field[1].ip = ip; - return t; - } - -/* - * list_nd - create a list creation node. - */ -nodeptr list_nd(loc_model, args) -nodeptr loc_model; -nodeptr args; - { - register nodeptr t; - struct implement *impl; - int nargs; - - /* - * Determine the number of arguments. - */ - if (args->n_type == N_Empty) - nargs = 0; - else { - nargs = 1; - for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) - ++nargs; - if (nargs > max_prm) - max_prm = nargs; - } - - impl = spec_op[ListOp]; - if (impl == NULL) - nfatal(loc_model, "list creation not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(loc_model, "list creation not installed", NULL); - - t = NewNode(nargs + 2); - t->n_type = N_InvOp; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = nargs; - t->n_field[1].ip = impl; - if (nargs > 0) - put_elms(t, args, nargs + 1); - return t; - } - -/* - * invk_nd - create a node for invocation. - */ -nodeptr invk_nd(loc_model, proc, args) -nodeptr loc_model; -nodeptr proc; -nodeptr args; - { - register nodeptr t; - int nargs; - - /* - * Determine the number of arguments. - */ - if (args->n_type == N_Empty) - nargs = 0; - else { - nargs = 1; - for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) - ++nargs; - if (nargs > max_prm) - max_prm = nargs; - } - - t = NewNode(nargs + 2); - t->n_type = N_Invok; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = nargs; - t->n_field[1].n_ptr = proc; - if (nargs > 0) - put_elms(t, args, nargs + 1); - return t; - } - -/* - * put_elms - convert a linked list of arguments into an array of arguments - * in a node. - */ -static void put_elms(t, args, slot) -nodeptr t; -nodeptr args; -int slot; - { - if (args->n_type == N_Elist) { - /* - * The linked list is in reverse argument order. - */ - t->n_field[slot].n_ptr = chk_empty(args->n_field[1].n_ptr); - put_elms(t, args->n_field[0].n_ptr, slot - 1); - free(args); - } - else - t->n_field[slot].n_ptr = chk_empty(args); - } - -/* - * chk_empty - if an argument is empty, replace it with &null. - */ -static nodeptr chk_empty(n) -nodeptr n; - { - if (n->n_type == N_Empty) - n = key_leaf(n, spec_str("null")); - return n; - } - -/* - * case_nd - create a node for a case statement. - */ -nodeptr case_nd(loc_model, expr, cases) -nodeptr loc_model; -nodeptr expr; -nodeptr cases; - { - register nodeptr t; - nodeptr reverse; - nodeptr nxt_cases; - nodeptr ccls; - - t = NewNode(3); - t->n_type = N_Case; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = expr; - t->n_field[2].n_ptr = NULL; - - /* - * The list of cases is in reverse order. Walk the list reversing it, - * and extract the default clause if one exists. - */ - reverse = NULL; - while (cases->n_type != N_Ccls) { - nxt_cases = cases->n_field[0].n_ptr; - ccls = cases->n_field[1].n_ptr; - if (ccls->n_field[0].n_ptr->n_type == N_Res) { - /* - * default clause. - */ - if (t->n_field[2].n_ptr == NULL) - t->n_field[2].n_ptr = ccls->n_field[1].n_ptr; - else - nfatal(ccls, "duplicate default clause", NULL); - } - else { - if (reverse == NULL) { - reverse = cases; - reverse->n_field[0].n_ptr = ccls; - } - else { - reverse->n_field[1].n_ptr = ccls; - cases->n_field[0].n_ptr = reverse; - reverse = cases; - } - } - cases = nxt_cases; - } - - /* - * Last element in list. - */ - if (cases->n_field[0].n_ptr->n_type == N_Res) { - /* - * default clause. - */ - if (t->n_field[2].n_ptr == NULL) - t->n_field[2].n_ptr = cases->n_field[1].n_ptr; - else - nfatal(ccls, "duplicate default clause", NULL); - if (reverse != NULL) - reverse = reverse->n_field[0].n_ptr; - } - else { - if (reverse == NULL) - reverse = cases; - else - reverse->n_field[1].n_ptr = cases; - } - t->n_field[1].n_ptr = reverse; - return t; - } - -/* - * multiunary - construct nodes to implement a sequence of unary operators - * that have been lexically analyzed as one operator. - */ -nodeptr multiunary(op, loc_model, oprnd) -nodeptr loc_model; -char *op; -nodeptr oprnd; - { - int n; - nodeptr nd; - - if (*op == '\0') - return oprnd; - for (n = 0; optab[n].tok.t_word != NULL; ++n) - if ((optab[n].expected & Unary) & (*(optab[n].tok.t_word) == *op)) { - nd = OpNode(n); - nd->n_file = loc_model->n_file; - nd->n_line = loc_model->n_line; - nd->n_col = loc_model->n_col; - return unary_nd(nd,multiunary(++op,loc_model,oprnd)); - } - fprintf(stderr, "compiler error: inconsistent parsing of unary operators"); - exit(EXIT_FAILURE); - } - -/* - * binary_nd - construct a node for a binary operator. - */ -nodeptr binary_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for the operator. - */ - impl = optab[Val0(op)].binary; - if (impl == NULL) - nfatal(op, "binary operator not implemented", optab[Val0(op)].tok.t_word); - else if (impl->in_line == NULL) - nfatal(op, "binary operator not installed", optab[Val0(op)].tok.t_word); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * unary_nd - construct a node for a unary operator. - */ -nodeptr unary_nd(op, arg) -nodeptr op; -nodeptr arg; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for the operator. - */ - impl = optab[Val0(op)].unary; - if (impl == NULL) - nfatal(op, "unary operator not implemented", optab[Val0(op)].tok.t_word); - else if (impl->in_line == NULL) - nfatal(op, "unary operator not installed", optab[Val0(op)].tok.t_word); - - t = NewNode(3); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 1; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg; - return t; - } - -/* - * buildarray - convert "multi-dimensional" subscripting into a sequence - * of subsripting operations. - */ -nodeptr buildarray(a,lb,e) -nodeptr a, lb, e; - { - register nodeptr t, t2; - if (e->n_type == N_Elist) { - t2 = int_leaf(lb->n_type, lb, lb->n_field[0].n_val); - t = subsc_nd(t2, buildarray(a,lb,e->n_field[0].n_ptr), - e->n_field[1].n_ptr); - free(e); - } - else - t = subsc_nd(lb, a, e); - return t; - } - -/* - * subsc_nd - construct a node for subscripting. - */ -static nodeptr subsc_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for subscripting. - */ - impl = spec_op[SubscOp]; - if (impl == NULL) - nfatal(op, "subscripting not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "subscripting not installed", NULL); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * to_nd - construct a node for binary to. - */ -nodeptr to_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for to. - */ - impl = spec_op[ToOp]; - if (impl == NULL) - nfatal(op, "'i to j' not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "'i to j' not installed", NULL); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * toby_nd - construct a node for binary to-by. - */ -nodeptr toby_nd(op, arg1, arg2, arg3) -nodeptr op; -nodeptr arg1; -nodeptr arg2; -nodeptr arg3; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for to-by. - */ - impl = spec_op[ToByOp]; - if (impl == NULL) - nfatal(op, "'i to j by k' not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "'i to j by k' not installed", NULL); - - t = NewNode(5); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 3; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - t->n_field[4].n_ptr = arg3; - return t; - } - -/* - * aug_nd - create a node for an augmented assignment. - */ -nodeptr aug_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - t = NewNode(5); - t->n_type = N_Augop; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - - /* - * Find the data base entry for assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) - nfatal(op, "assignment not implemented", NULL); - t->n_field[0].ip = impl; - - /* - * The operator table entry for the augmented assignment is - * immediately after the entry for the operation. - */ - impl = optab[Val0(op) - 1].binary; - if (impl == NULL) - nfatal(op, "binary operator not implemented", - optab[Val0(op) - 1].tok.t_word); - t->n_field[1].ip = impl; - - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - /* t->n_field[4].typ - type of intermediate result */ - return t; - } - -/* - * sect_nd - create a node for sectioning. - */ -nodeptr sect_nd(op, arg1, arg2, arg3) -nodeptr op; -nodeptr arg1; -nodeptr arg2; -nodeptr arg3; - { - register nodeptr t; - int tok; - struct implement *impl; - struct implement *impl1; - - t = NewNode(5); - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - - /* - * Find the data base entry for sectioning. - */ - impl = spec_op[SectOp]; - if (impl == NULL) - nfatal(op, "sectioning not implemented", NULL); - - tok = optab[Val0(op)].tok.t_type; - if (tok == COLON) { - /* - * Simple sectioning, treat as a ternary operator. - */ - t->n_type = N_InvOp; - t->n_field[0].n_val = 3; /* number of arguments */ - t->n_field[1].ip = impl; - } - else { - /* - * Find the data base entry for addition or subtraction. - */ - if (tok == PCOLON) { - impl1 = optab[plus_loc].binary; - if (impl1 == NULL) - nfatal(op, "addition not implemented", NULL); - } - else { /* MCOLON */ - impl1 = optab[minus_loc].binary; - if (impl1 == NULL) - nfatal(op, "subtraction not implemented", NULL); - } - t->n_type = N_Sect; - t->n_field[0].ip = impl; - t->n_field[1].ip = impl1; - } - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - t->n_field[4].n_ptr = arg3; - return t; - } - -/* - * invk_main - produce an procedure invocation node with one argument for - * use in the initial invocation to main() during type inference. - */ -nodeptr invk_main(main_proc) -struct pentry *main_proc; - { - register nodeptr t; - - t = NewNode(3); - t->n_type = N_InvProc; - t->n_file = NULL; - t->n_line = 0; - t->n_col = 0; - t->freetmp = NULL; - t->n_field[0].n_val = 1; /* 1 argument */ - t->n_field[1].proc = main_proc; - t->n_field[2].n_ptr = tree1(N_Empty); - - if (max_prm < 1) - max_prm = 1; - return t; - } diff --git a/src/iconc/ctree.h b/src/iconc/ctree.h deleted file mode 100644 index d38d3c4..0000000 --- a/src/iconc/ctree.h +++ /dev/null @@ -1,200 +0,0 @@ -/* - * Structure of a tree node. - */ - -typedef struct node *nodeptr; - -/* - * Kinds of fields in syntax tree node. - */ -union field { - long n_val; /* integer-valued fields */ - char *n_str; /* string-valued fields */ - struct lentry *lsym; /* fields referencing local symbol table entries */ - struct centry *csym; /* fields referencing constant symbol table entries */ - struct implement *ip; /* fields referencing an operation */ - struct pentry *proc; /* pointer to procedure entry */ - struct rentry *rec; /* pointer to record entry */ -#ifdef OptimizeType - struct typinfo *typ; /* extra type field */ -#else /* OptimizeType */ - unsigned int *typ; /* extra type field */ -#endif /* OptimizeType */ - nodeptr n_ptr; /* subtree pointers */ - }; - -/* - * A store is an array that maps variables types (which are given indexes) - * to the types stored within the variables. - */ -struct store { - struct store *next; - int perm; /* flag: whether store stays across iterations */ -#ifdef OptimizeType - struct typinfo *types[1]; /* actual size is number of variables */ -#else /* OptimizeType */ - unsigned int *types[1]; /* actual size is number of variables */ -#endif /* OptimizeType */ - }; - -/* - * Array of parameter types for an operation call. - */ -struct symtyps { - int nsyms; /* number of parameter symbols */ - struct symtyps *next; -#ifdef OptimizeType - struct typinfo *types[1]; /* really one for every symbol */ -#else /* OptimizeType */ - unsigned int *types[1]; /* really one for every symbol */ -#endif /* OptimizeType */ - }; - -/* - * definitions for maintaining allocation status. - */ -#define NotAlloc 0 /* temp var neither in use nor reserved */ -#define InUnse 1 /* temp var currently contains live variable */ -/* n < 0 reserved: must be free by node with postn field = n */ - -#define DescTmp 1 /* allocation of descriptor temporary */ -#define CIntTmp 2 /* allocation of C integer temporary */ -#define CDblTmp 3 /* allocation of C double temporary */ -#define SBuf 4 /* allocation of string buffer */ -#define CBuf 5 /* allocation of cset buffer */ - -struct freetmp { /* list of things to free at a node */ - int kind; /* DescTmp, CIntTmp, CDblTmp, SBuf, or CBuf */ - int indx; /* index into status array */ - int old; /* old status */ - struct freetmp *next; - }; - -struct node { - int n_type; /* node type */ - char *n_file; /* name of file containing source program */ - int n_line; /* line number in source program */ - int n_col; /* column number in source program */ - int flag; - int *new_types; /* pntr to array of struct types created here */ -#ifdef OptimizeType - struct typinfo *type; /* type of this expression */ -#else /* OptimizeType */ - unsigned int *type; /* type of this expression */ -#endif /* OptimizeType */ - struct store *store; /* if needed, store saved between iterations */ - struct symtyps *symtyps; /* for operation in data base: types of arg syms */ - nodeptr lifetime; /* lifetime of intermediate result */ - int reuse; /* result may be reused without being recomputed */ - nodeptr intrnl_lftm; /* lifetime of variables internal to operation */ - int postn; /* relative position of node in execution order */ - struct freetmp *freetmp; /* temporary variables to free at this point */ - union field n_field[1]; /* node fields */ - }; - -/* - * NewNode - allocate a parse tree node with "size" fields. - */ -#define NewNode(size) (struct node *)alloc((unsigned int)\ - (sizeof(struct node) + (size-1) * sizeof(union field))) - -/* - * Macros to access fields of parse tree nodes. - */ - -#define Type(t) t->n_type -#define File(t) t->n_file -#define Line(t) t->n_line -#define Col(t) t->n_col -#define Tree0(t) t->n_field[0].n_ptr -#define Tree1(t) t->n_field[1].n_ptr -#define Tree2(t) t->n_field[2].n_ptr -#define Tree3(t) t->n_field[3].n_ptr -#define Tree4(t) t->n_field[4].n_ptr -#define Val0(t) t->n_field[0].n_val -#define Val1(t) t->n_field[1].n_val -#define Val2(t) t->n_field[2].n_val -#define Val3(t) t->n_field[3].n_val -#define Val4(t) t->n_field[4].n_val -#define Str0(t) t->n_field[0].n_str -#define Str1(t) t->n_field[1].n_str -#define Str2(t) t->n_field[2].n_str -#define Str3(t) t->n_field[3].n_str -#define LSym0(t) t->n_field[0].lsym -#define CSym0(t) t->n_field[0].csym -#define Impl0(t) t->n_field[0].ip -#define Impl1(t) t->n_field[1].ip -#define Rec1(t) t->n_field[1].rec -#define Proc1(t) t->n_field[1].proc -#define Typ4(t) t->n_field[4].typ - -/* - * External declarations. - */ - -extern nodeptr yylval; /* parser's current token value */ -extern struct node tok_loc; /* "model" token holding current location */ - -/* - * Node types. - */ - -#define N_Activat 1 /* activation control structure */ -#define N_Alt 2 /* alternation operator */ -#define N_Apply 3 /* procedure application */ -#define N_Augop 4 /* augmented operator */ -#define N_Bar 5 /* generator control structure */ -#define N_Break 6 /* break statement */ -#define N_Case 7 /* case statement */ -#define N_Ccls 8 /* case clause */ -#define N_Clist 9 /* list of case clauses */ -#define N_Create 10 /* create control structure */ -#define N_Cset 11 /* cset literal */ -#define N_Elist 12 /* list of expressions */ -#define N_Empty 13 /* empty expression or statement */ -#define N_Field 14 /* record field reference */ -#define N_Id 15 /* identifier token */ -#define N_If 16 /* if-then-else statement */ -#define N_Int 17 /* integer literal */ -#define N_Invok 18 /* invocation */ -#define N_InvOp 19 /* invoke operation */ -#define N_InvProc 20 /* invoke operation */ -#define N_InvRec 21 /* invoke operation */ -#define N_Limit 22 /* LIMIT control structure */ -#define N_Loop 23 /* while, until, every, or repeat */ -#define N_Next 24 /* next statement */ -#define N_Not 25 /* not prefix control structure */ -#define N_Op 26 /* operator token */ -#define N_Proc 27 /* procedure */ -#define N_Real 28 /* real literal */ -#define N_Res 29 /* reserved word token */ -#define N_Ret 30 /* fail, return, or succeed */ -#define N_Scan 31 /* scan-using statement */ -#define N_Sect 32 /* s[i:j] (section) */ -#define N_Slist 33 /* list of statements */ -#define N_Str 34 /* string literal */ -#define N_SmplAsgn 35 /* simple assignment to named var */ -#define N_SmplAug 36 /* simple assignment to named var */ - -#define AsgnDirect 0 /* rhs of special := can compute directly into var */ -#define AsgnCopy 1 /* special := must copy result into var */ -#define AsgnDeref 2 /* special := must dereference result into var */ - - -/* - * Macros for constructing basic nodes. - */ - -#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b) -#define IdNode(a) c_str_leaf(N_Id,&tok_loc,a) -#define IntNode(a) c_str_leaf(N_Int,&tok_loc,a) -#define OpNode(a) int_leaf(N_Op,&tok_loc,a) -#define RealNode(a) c_str_leaf(N_Real,&tok_loc,a) -#define ResNode(a) int_leaf(N_Res,&tok_loc,a) -#define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b) - -/* - * MultiUnary - create subtree from an operator symbol that represents - * multiple unary operators. - */ -#define MultiUnary(a,b) multiunary(optab[Val0(a)].tok.t_word, a, b) diff --git a/src/iconc/dbase.c b/src/iconc/dbase.c deleted file mode 100644 index fdd3e50..0000000 --- a/src/iconc/dbase.c +++ /dev/null @@ -1,196 +0,0 @@ -/* - * dbase.c - routines to access data base of implementation information - * produced by rtt. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#include "cglobals.h" - -/* - * Prototypes. - */ -static int chck_spec (struct implement *ip); -static int acpt_op (struct implement *ip); - - -static struct optab *optr; /* pointer into operator table */ - -/* - * readdb - read data base produced by rtt. - */ -void readdb(db_name) -char *db_name; - { - char *op, *s; - int i; - struct implement *ip; - char buf[MaxPath]; /* file name construction buffer */ - struct fileparts *fp; - unsigned hashval; - - fp = fparse(db_name); - if (*fp->ext == '\0') - db_name = salloc(makename(buf, NULL, db_name, DBSuffix)); - else if (!smatch(fp->ext, DBSuffix)) - quitf("bad data base name: %s", db_name); - - if (!db_open(db_name, &s)) - db_err1(1, "cannot open data base"); - - if (largeints && (*s == 'N')) { - twarn("Warning, run-time system does not support large integers", NULL); - largeints = 0; - } - - /* - * Read information about functions. - */ - db_tbl("functions", bhash); - - /* - * Read information about operators. - */ - optr = optab; - - /* - * read past operators header. - */ - db_chstr("operators", "operators"); - - while ((op = db_string()) != NULL) { - if ((ip = db_impl('O')) == NULL) - db_err2(1, "no implementation information for operator", op); - ip->op = op; - if (acpt_op(ip)) { - db_code(ip); - hashval = IHasher(op); - ip->blink = ohash[hashval]; - ohash[hashval] = ip; - db_chstr("end", "end"); - } - else - db_dscrd(ip); - } - db_chstr("endsect", "endsect"); - - /* - * Read information about keywords. - */ - db_tbl("keywords", khash); - - db_close(); - - /* - * If error conversion is supported, make sure it is reflected in - * the minimum result sequence of operations. - */ - if (err_conv) { - for (i = 0; i < IHSize; ++i) - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - for (i = 0; i < IHSize; ++i) - for (ip = khash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - } - } - -/* - * acpt_opt - given a data base entry for an operator determine if it - * is in iconc's operator table. - */ -static int acpt_op(ip) -struct implement *ip; - { - register char *op; - register int opcmp; - - /* - * Calls to this function are in lexical order by operator symbol continue - * searching operator table from where we left off. - */ - op = ip->op; - for (;;) { - /* - * optab has augmented assignments out of lexical order. Skip anything - * which does not expect an implementation. This gets augmented - * assignments out of the way. - */ - while (optr->expected == 0 && optr->tok.t_word != NULL) - ++optr; - if (optr->tok.t_word == NULL) - return chck_spec(ip); - opcmp = strcmp(op, optr->tok.t_word); - if (opcmp > 0) - ++optr; - else if (opcmp < 0) - return chck_spec(ip); - else { - if (ip->nargs == 1 && (optr->expected & Unary)) { - if (optr->unary == NULL) { - optr->unary = ip; - return 1; - } - else - return 0; - } - else if (ip->nargs == 2 && (optr->expected & Binary)) { - if (optr->binary == NULL) { - optr->binary = ip; - return 1; - } - else - return 0; - } - else - return chck_spec(ip); - } - } - } - -/* - * chck_spec - check whether the operator is one that does not use standard - * unary or binary syntax. - */ -static int chck_spec(ip) -struct implement *ip; - { - register char *op; - int indx; - - indx = -1; - op = ip->op; - if (strcmp(op, "...") == 0) { - if (ip->nargs == 2) - indx = ToOp; - else - indx = ToByOp; - } - else if (strcmp(op, "[:]") == 0) - indx = SectOp; - else if (strcmp(op, "[]") == 0) - indx = SubscOp; - else if (strcmp(op, "[...]") == 0) - indx = ListOp; - - if (indx == -1) { - db_err2(0, "unexpected operator (or arity),", op); - return 0; - } - if (spec_op[indx] == NULL) { - spec_op[indx] = ip; - return 1; - } - else - return 0; - } diff --git a/src/iconc/fixcode.c b/src/iconc/fixcode.c deleted file mode 100644 index b8c06e0..0000000 --- a/src/iconc/fixcode.c +++ /dev/null @@ -1,372 +0,0 @@ -/* - * fixcode.c - routines to "fix code" by determining what signals are returned - * by continuations and what must be done when they are. Also perform - * optional control flow optimizations. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "ccode.h" -#include "ctree.h" -#include "csym.h" -#include "cproto.h" - -/* - * Prototypes for static functions. - */ -static struct code *ck_unneed (struct code *cd, struct code *lbl); -static void clps_brch (struct code *branch); -static void dec_refs (struct code *cd); -static void rm_unrch (struct code *cd); - -/* - * fix_fncs - go through the generated C functions, determine how calls - * handle signals, in-line trivial functions where possible, remove - * goto's which immediately precede their labels, and remove unreachable - * code. - */ -void fix_fncs(fnc) -struct c_fnc *fnc; - { - struct code *cd, *cd1; - struct code *contbody; - struct sig_act *sa; - struct sig_lst *sl; - struct code *call; - struct code *create; - struct code *ret_sig; - struct code *sig; - struct c_fnc *calledcont; - int no_break; - int collapse; - - /* - * Fix any called functions and decide how the calls handle the - * returned signals. - */ - fnc->flag |= CF_Mark; - for (call = fnc->call_lst; call != NULL; call = call->NextCall) { - calledcont = call->Cont; - if (calledcont != NULL) { - if (!(calledcont->flag & CF_Mark)) - fix_fncs(calledcont); - if (calledcont->flag & CF_ForeignSig) { - call->Flags |= ForeignSig; - fnc->flag |= CF_ForeignSig; - } - } - - - /* - * Try to collapse call chains of continuations. - */ - if (opt_cntrl && calledcont != NULL) { - contbody = calledcont->cd.next; - if (call->OperName == NULL && contbody->cd_id == C_RetSig) { - /* - * A direct call of a continuation which consists of just a - * return. Replace call with code to handle the returned signal. - */ - ret_sig = contbody->SigRef->sig; - if (ret_sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(ret_sig, fnc); - cd1->prev = call->prev; - cd1->prev->next = cd1; - cd1->next = call->next; - if (cd1->next != NULL) - cd1->next->prev = cd1; - --calledcont->ref_cnt; - continue; /* move on to next call */ - } - else if (contbody->cd_id == C_CallSig && contbody->next == NULL) { - /* - * The called continuation contains only a call. - */ - if (call->OperName == NULL) { - /* - * We call the continuation directly, so we can in-line it. - * We must replace signal returns with appropriate actions. - */ - if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) - ++contbody->Cont->ref_cnt; - call->OperName = contbody->OperName; - call->ArgLst = contbody->ArgLst; - call->Cont = contbody->Cont; - call->Flags = contbody->Flags; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (ret_sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(ret_sig, fnc); - call->SigActs = new_sgact(sa->sig, cd1, call->SigActs); - } - continue; /* move on to next call */ - } - else if (contbody->OperName == NULL) { - /* - * The continuation simply calls another continuation. We can - * eliminate the intermediate continuation as long as we can - * move signal conversions to the other side of the operation. - * The operation only intercepts resume signals. - */ - collapse = 1; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (sa->sig != ret_sig && (sa->sig == &resume || - ret_sig == &resume)) - collapse = 0; - } - if (collapse) { - if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) - ++contbody->Cont->ref_cnt; - call->Cont = contbody->Cont; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (ret_sig != &resume) - call->SigActs = new_sgact(sa->sig, sig_cd(ret_sig, fnc), - call->SigActs); - } - continue; /* move on to next call */ - } - } - } - } - - /* - * We didn't do any optimizations. We must still figure out - * out how to handle signals returned by the continuation. - */ - if (calledcont != NULL) { - for (sl = calledcont->sig_lst; sl != NULL; sl = sl->next) { - if (sl->ref_cnt > 0) { - sig = sl->sig; - /* - * If an operation is being called, it handles failure from the - * continuation. - */ - if (sig != &resume || call->OperName == NULL) { - if (sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(sig, fnc); - call->SigActs = new_sgact(sig, cd1, call->SigActs); - } - } - } - } - } - - /* - * fix up the signal handling in the functions implementing co-expressions. - */ - for (create = fnc->creatlst; create != NULL; create = create->NextCreat) - fix_fncs(create->Cont); - - if (!opt_cntrl) - return; /* control flow optimizations disabled. */ - /* - * Collapse branch chains and remove unreachable code. - */ - for (cd = &(fnc->cd); cd != NULL; cd = cd->next) { - switch (cd->cd_id) { - case C_CallSig: - no_break = 1; - for (sa = cd->SigActs; sa != NULL; sa = sa->next) { - if (sa->cd->cd_id == C_Break) { - switch (cd->next->cd_id) { - case C_Goto: - sa->cd->cd_id = cd->next->cd_id; - sa->cd->Lbl = cd->next->Lbl; - ++sa->cd->Lbl->RefCnt; - break; - case C_RetSig: - sa->cd->cd_id = cd->next->cd_id; - sa->cd->SigRef= cd->next->SigRef; - ++sa->cd->SigRef->ref_cnt; - break; - default: - no_break = 0; - } - } - if (sa->cd->cd_id == C_Goto) - clps_brch(sa->cd); - } - if (no_break) - rm_unrch(cd); - /* - * Try converting gotos into breaks. - */ - for (sa = cd->SigActs; sa != NULL; sa = sa->next) - if (sa->cd->cd_id == C_Goto) { - cd1 = cd->next; - while (cd1 != NULL && (cd1->cd_id == C_Label || - cd1->cd_id == C_RBrack)) { - if (cd1 == sa->cd->Lbl) { - sa->cd->cd_id = C_Break; - --cd1->RefCnt; - break; - } - cd1 = cd1->next; - } - } - break; - - case C_Goto: - clps_brch(cd); - rm_unrch(cd); - if (cd->cd_id == C_Goto) - ck_unneed(cd, cd->Lbl); - break; - - case C_If: - if (cd->ThenStmt->cd_id == C_Goto) { - clps_brch(cd->ThenStmt); - if (cd->ThenStmt->cd_id == C_Goto) - ck_unneed(cd, cd->ThenStmt->Lbl); - } - break; - - case C_PFail: - case C_PRet: - case C_RetSig: - rm_unrch(cd); - break; - } - } - - /* - * If this function only contains a return, indicate that we can - * call a shared signal returning function instead of it. This is - * a special case of "common subROUTINE elimination". - */ - if (fnc->cd.next->cd_id == C_RetSig) - fnc->flag |= CF_SigOnly; - } - -/* - * clps_brch - collapse branch chains. - */ -static void clps_brch(branch) -struct code *branch; - { - struct code *cd; - int save_id; - - cd = branch->Lbl->next; - while (cd->cd_id == C_Label) - cd = cd->next; - - /* - * Avoid infinite recursion on empty infinite loops. - */ - save_id = branch->cd_id; - branch->cd_id = 0; - if (cd->cd_id == C_Goto) - clps_brch(cd); - branch->cd_id = save_id; - - switch (cd->cd_id) { - case C_Goto: - --branch->Lbl->RefCnt; - ++cd->Lbl->RefCnt; - branch->Lbl = cd->Lbl; - break; - case C_RetSig: - /* - * This optimization requires that C_Goto have as many fields - * as C_RetSig. - */ - --branch->Lbl->RefCnt; - ++cd->SigRef->ref_cnt; - branch->cd_id = C_RetSig; - branch->SigRef = cd->SigRef; - break; - } - } - -/* - * rm_unrch - any code after the given point up to the next label is - * unreachable. Remove it. - */ -static void rm_unrch(cd) -struct code *cd; - { - struct code *cd1; - - for (cd1 = cd->next; cd1 != NULL && cd1->cd_id != C_LBrack && - (cd1->cd_id != C_Label || cd1->RefCnt == 0); cd1 = cd1->next) { - if (cd1->cd_id == C_RBrack) { - /* - * Continue deleting past a '}', but don't delete the '}' itself. - */ - cd->next = cd1; - cd1->prev = cd; - cd = cd1; - } - else - dec_refs(cd1); - } - cd->next = cd1; - if (cd1 != NULL) - cd1->prev = cd; - } - -/* - * dec_refs - decrement reference counts for things this code references. - */ -static void dec_refs(cd) -struct code *cd; - { - struct sig_act *sa; - - if (cd == NULL) - return; - switch (cd->cd_id) { - case C_Goto: - --cd->Lbl->RefCnt; - return; - case C_RetSig: - --cd->SigRef->ref_cnt; - return; - case C_CallSig: - if (cd->Cont != NULL) - --cd->Cont->ref_cnt; - for (sa = cd->SigActs; sa != NULL; sa = sa->next) - dec_refs(sa->cd); - return; - case C_If: - dec_refs(cd->ThenStmt); - return; - case C_Create: - --cd->Cont->ref_cnt; - return; - } - } - -/* - * ck_unneed - if there is nothing between a goto and its label, except - * perhaps other labels or '}', it is useless, so remove it. - */ -static struct code *ck_unneed(cd, lbl) -struct code *cd; -struct code *lbl; - { - struct code *cd1; - - cd1 = cd->next; - while (cd1 != NULL && (cd1->cd_id == C_Label || cd1->cd_id == C_RBrack)) { - if (cd1 == lbl) { - cd = cd->prev; - cd->next = cd->next->next; - cd->next->prev = cd; - --lbl->RefCnt; - break; - } - cd1 = cd1->next; - } - return cd; - } - diff --git a/src/iconc/incheck.c b/src/iconc/incheck.c deleted file mode 100644 index d4110f9..0000000 --- a/src/iconc/incheck.c +++ /dev/null @@ -1,802 +0,0 @@ -/* - * incheck.c - analyze a run-time operation using type information. - * Determine wither the operation can be in-lined and what kinds - * of parameter passing optimizations can be done. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" - -struct op_symentry *cur_symtab; /* symbol table for current operation */ - -/* - * Prototypes for static functions. - */ -static struct code *and_cond (struct code *cd1, struct code *cd2); -static int cnv_anlz (unsigned int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest, - struct code **cdp); -static int defer_il (struct il_code *il); -static int if_anlz (struct il_code *il); -static void ilc_anlz (struct il_c *ilc); -static int il_anlz (struct il_code *il); -static void ret_anlz (struct il_c *ilc); -static int tc_anlz (struct il_code *il, int has_dflt); - -static int n_branches; /* number branches caused by run-time type checking */ -static int side_effect; /* abstract clause indicates side-effect */ -static int n_vararg; /* size of variable part of arg list to operation */ -static int n_susp; /* number of suspends */ -static int n_ret; /* number of returns */ - -/* - * do_inlin - determine if this operation can be in-lined at the current - * invocation. Also gather information about how arguments are used, - * and determine where the success continuation for the operation - * should be put. - */ -int do_inlin(impl, n, cont_loc, symtab, n_va) -struct implement *impl; -nodeptr n; -int *cont_loc; -struct op_symentry *symtab; -int n_va; - { - int nsyms; - int i; - - /* - * Copy arguments needed by other functions into globals and - * initialize flags and counters for information to be gathered - * during analysis. - */ - cur_symtyps = n->symtyps; /* mapping from arguments to types */ - cur_symtab = symtab; /* parameter info to be filled in */ - n_vararg = n_va; - n_branches = 0; - side_effect = 0; - n_susp = 0; - n_ret = 0; - - /* - * Analyze the code for this operation using type information for - * the arguments to the invocation. - */ - il_anlz(impl->in_line); - - - /* - * Don't in-line if there is more than one decision made based on - * run-time type checks (this is a heuristic). - */ - if (n_branches > 1) - return 0; - - /* - * If the operation (after eliminating code not used in this context) - * has one suspend and no returns, the "success continuation" can - * be placed in-line at the suspend site. Otherwise, any suspends - * require a separate function for the continuation. - */ - if (n_susp == 1 && n_ret == 0) - *cont_loc = SContIL; /* in-line continuation */ - else if (n_susp > 0) - *cont_loc = SepFnc; /* separate function for continuation */ - else - *cont_loc = EndOper; /* place "continuation" after the operation */ - - /* - * When an argument at the source level is an Icon variable, it is - * sometimes safe to use it directly in the generated code as the - * argument to the operation. However, it is NOT safe under the - * following conditions: - * - * - if the operation modifies the argument. - * - if the operation suspends and resumes so that intervening - * changes to the variable would be visible as changes to the - * argument. - * - if the operation has side effects that might involve the - * variable and be visible as changes to the argument. - */ - nsyms = (cur_symtyps == NULL ? 0 : cur_symtyps->nsyms); - for (i = 0; i < nsyms; ++i) - if (symtab[i].n_mods == 0 && n->intrnl_lftm == n && !side_effect) - symtab[i].var_safe = 1; - - return 1; - } - -/* - * il_anlz - analyze a piece of RTL code. Return an indication of - * whether execution can continue beyond it. - */ -static int il_anlz(il) -struct il_code *il; - { - int fall_thru; - int ncases; - int condition; - int indx; - int i, j; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 1; - - case IL_If1: - /* - * if-then statement. Determine whether the condition may - * succeed or fail. Analyze the then clause if needed. - */ - condition = if_anlz(il->u[0].fld); - fall_thru = 0; - if (condition & MaybeTrue) - fall_thru |= il_anlz(il->u[1].fld); - if (condition & MaybeFalse) - fall_thru = 1; - return fall_thru; - - case IL_If2: - /* - * if-then-else statement. Determine whether the condition may - * succeed or fail. Analyze the "then" clause and the "else" - * clause if needed. - */ - condition = if_anlz(il->u[0].fld); - fall_thru = 0; - if (condition & MaybeTrue) - fall_thru |= il_anlz(il->u[1].fld); - if (condition & MaybeFalse) - fall_thru |= il_anlz(il->u[2].fld); - return fall_thru; - - case IL_Tcase1: - /* - * type_case statement with no default clause. - */ - return tc_anlz(il, 0); - - case IL_Tcase2: - /* - * type_case statement with a default clause. - */ - return tc_anlz(il, 1); - - case IL_Lcase: - /* - * len_case statement. Determine which case matches the number - * of arguments. - */ - ncases = il->u[0].n; - indx = 1; - for (i = 0; i < ncases; ++i) { - if (il->u[indx++].n == n_vararg) /* selection number */ - return il_anlz(il->u[indx].fld); /* action */ - ++indx; - } - return il_anlz(il->u[indx].fld); /* default */ - - case IL_Acase: { - /* - * arith_case statement. - */ - struct il_code *var1; - struct il_code *var2; - int maybe_int; - int maybe_dbl; - int chk1; - int chk2; - - var1 = il->u[0].fld; - var2 = il->u[1].fld; - arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, NULL, - &chk2, NULL); - - /* - * Analyze the selected case (note, large integer code is not - * currently in-lined and can be ignored). - */ - fall_thru = 0; - if (maybe_int) - fall_thru |= il_anlz(il->u[2].fld); /* C_integer action */ - if (maybe_dbl) - fall_thru |= il_anlz(il->u[4].fld); /* C_double action */ - return fall_thru; - } - - case IL_Err1: - /* - * runerr() with no offending value. - */ - return 0; - - case IL_Err2: - /* - * runerr() with an offending value. Note the reference to - * the offending value descriptor. - */ - indx = il->u[1].fld->u[0].n; /* symbol table index of variable */ - if (indx < cur_symtyps->nsyms) - ++cur_symtab[indx].n_refs; - return 0; - - case IL_Block: - /* - * inline {...} statement. - */ - i = il->u[1].n + 2; /* skip declaration stuff */ - ilc_anlz(il->u[i].c_cd); /* body of block */ - return il->u[0].n; - - case IL_Call: - /* - * call to body function. - */ - if (il->u[3].n & DoesSusp) - n_susp = 2; /* force continuation into separate function */ - - /* - * Analyze the C code for prototype parameter declarations - * and actual arguments. There are twice as many pieces of - * C code to look at as there are parameters. - */ - j = 2 * il->u[7].n; - i = 8; /* index of first piece of C code */ - while (j--) - ilc_anlz(il->u[i++].c_cd); - return ((il->u[3].n & DoesFThru) != 0); - - case IL_Lst: - /* - * Two consecutive pieces of RTL code. - */ - fall_thru = il_anlz(il->u[0].fld); - if (fall_thru) - fall_thru = il_anlz(il->u[1].fld); - return fall_thru; - - case IL_Abstr: - /* - * abstract type computation. See if it indicates side effects. - */ - if (il->u[0].fld != NULL) - side_effect = 1; - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * if_anlz - analyze the condition of an if statement. - */ -static int if_anlz(il) -struct il_code *il; - { - int cond; - int cond1; - - if (il->il_type == IL_Bang) { - /* - * ! <condition>, negate the result of the condition - */ - cond1 = cond_anlz(il->u[0].fld, NULL); - cond = 0; - if (cond1 & MaybeTrue) - cond = MaybeFalse; - if (cond1 & MaybeFalse) - cond |= MaybeTrue; - } - else - cond = cond_anlz(il, NULL); - if (cond == (MaybeTrue | MaybeFalse)) - ++n_branches; /* must make a run-time decision */ - return cond; - } - -/* - * cond_anlz - analyze a simple condition or the conjunction of two - * conditions. If cdp is not NULL, use it to return a pointer code - * that implements the condition. - */ -int cond_anlz(il, cdp) -struct il_code *il; -struct code **cdp; - { - struct code *cd1; - struct code *cd2; - int cond1; - int cond2; - int indx; - - switch (il->il_type) { - case IL_And: - /* - * <cond> && <cond> - */ - cond1 = cond_anlz(il->u[0].fld, (cdp == NULL ? NULL : &cd1)); - if (cond1 & MaybeTrue) { - cond2 = cond_anlz(il->u[1].fld, (cdp == NULL ? NULL : &cd2)); - if (cdp != NULL) { - if (!(cond2 & MaybeTrue)) - *cdp = NULL; - else - *cdp = and_cond(cd1, cd2); - } - return (cond1 & MaybeFalse) | cond2; - } - else { - if (cdp != NULL) - *cdp = cd1; - return cond1; - } - - case IL_Cnv1: - /* - * cnv:<dest-type>(<source>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, NULL, cdp); - - case IL_Cnv2: - /* - * cnv:<dest-type>(<source>,<destination>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, il->u[2].c_cd, cdp); - - case IL_Def1: - /* - * def:<dest-type>(<source>,<default-value>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, NULL, cdp); - - case IL_Def2: - /* - * def:<dest-type>(<source>,<default-value>,<destination>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, il->u[3].c_cd, - cdp); - - case IL_Is: - /* - * is:<type-name>(<variable>) - */ - indx = il->u[1].fld->u[0].n; - cond1 = eval_is(il->u[0].n, indx); - if (cdp == NULL) { - if (indx < cur_symtyps->nsyms && cond1 == (MaybeTrue | MaybeFalse)) - ++cur_symtab[indx].n_refs; - } - else { - if (cond1 == (MaybeTrue | MaybeFalse)) - *cdp = typ_chk(il->u[1].fld, il->u[0].n); - else - *cdp = NULL; - } - return cond1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - - -/* - * and_cond - construct && of two conditions, either of which may have - * been optimized away. - */ -static struct code *and_cond(cd1, cd2) -struct code *cd1; -struct code *cd2; - { - struct code *cd; - - if (cd1 == NULL) - return cd2; - else if (cd2 == NULL) - return cd1; - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Ary; - cd->Array(0) = cd1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " && "; - cd->ElemTyp(2) = A_Ary; - cd->Array(2) = cd2; - return cd; - } - } - -/* - * cnv_anlz - analyze a type conversion. Determine whether it can succeed - * and, if requested, produce code to perform the conversion. Also - * gather information about the variables it uses. - */ -static int cnv_anlz(typcd, src, dflt, dest, cdp) -unsigned int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; -struct code **cdp; - { - struct val_loc *src_loc; - int cond; - int cnv_flags; - int indx; - - /* - * Find out what is going on in the default and destination subexpressions. - * (The information is used elsewhere.) - */ - ilc_anlz(dflt); - ilc_anlz(dest); - - if (cdp != NULL) - *cdp = NULL; /* clear code pointer in case it is not set below */ - - /* - * Determine whether the conversion may succeed, whether it may fail, - * and whether it may actually convert a value or use the default - * value when it succeeds. - */ - indx = src->u[0].n; /* symbol table index for source of conversion */ - cond = eval_cnv(typcd, indx, dflt != NULL, &cnv_flags); - - /* - * Many optimizations are possible depending on whether a conversion - * is actually needed, whether type checking is needed, whether defaulting - * is done, and whether there is an explicit destination. Several - * optimizations are performed here; more may be added in the future. - */ - if (!(cnv_flags & MayDefault)) - dflt = NULL; /* demote defaulting to simple conversion */ - - if (cond & MaybeTrue) { - if (cnv_flags == MayKeep && dest == NULL) { - /* - * No type conversion, defaulting, or copying is needed. - */ - if (cond & MaybeFalse) { - /* - * A type check is needed. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference to source. */ - if (cdp != NULL) { - switch (typcd) { - case TypECInt: - *cdp = typ_chk(src, TypCInt); - break; - case TypEInt: - *cdp = typ_chk(src, int_typ); - break; - case TypTStr: - *cdp = typ_chk(src, str_typ); - break; - case TypTCset: - *cdp = typ_chk(src, cset_typ); - break; - default: - *cdp = typ_chk(src, typcd); - } - } - } - - if (cdp != NULL) { - /* - * Conversion from an integer to a C_integer can be done without - * any executable code; this is not considered a real conversion. - * It is accomplished by changing the symbol table so only the - * dword of the descriptor is accessed. - */ - switch (typcd) { - case TypCInt: - case TypECInt: - cur_symtab[indx].loc = loc_cpy(cur_symtab[indx].loc, M_CInt); - break; - } - } - } - else if (dest != NULL && cnv_flags == MayKeep && cond == MaybeTrue) { - /* - * There is an explicit destination, but no conversion, defaulting, - * or type checking is needed. Just copy the value to the - * destination. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference to source */ - if (cdp != NULL) { - src_loc = cur_symtab[indx].loc; - switch (typcd) { - case TypCInt: - case TypECInt: - /* - * The value is in the dword of the descriptor. - */ - src_loc = loc_cpy(src_loc, M_CInt); - break; - } - *cdp = il_copy(dest, src_loc); - } - } - else if (cnv_flags == MayDefault) { - /* - * The default value is used. - */ - if (dest == NULL) - ++cur_symtab[indx].n_mods; /* modifying reference */ - if (cdp != NULL) - *cdp = il_dflt(typcd, src, dflt, dest); - } - else { - /* - * Produce code to do the actual conversion. - * Determine whether the source location is being modified - * or just referenced. - */ - if (dest == NULL) { - /* - * "In place" conversion. - */ - switch (typcd) { - case TypCDbl: - case TypCInt: - case TypECInt: - /* - * not really converted in-place. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference */ - break; - default: - ++cur_symtab[indx].n_mods; /* modifying reference */ - } - } - else - ++cur_symtab[indx].n_refs; /* non-modifying reference */ - - if (cdp != NULL) - *cdp = il_cnv(typcd, src, dflt, dest); - } - } - return cond; - } - -/* - * ilc_anlz - gather information about in-line C code. - */ -static void ilc_anlz(ilc) -struct il_c *ilc; - { - while (ilc != NULL) { - switch(ilc->il_c_type) { - case ILC_Ref: - /* - * Non-modifying reference to variable - */ - if (ilc->n != RsltIndx) { - ++cur_symtab[ilc->n].n_refs; - } - break; - - case ILC_Mod: - /* - * Modifying reference to variable - */ - if (ilc->n != RsltIndx) { - ++cur_symtab[ilc->n].n_mods; - } - break; - - case ILC_Ret: - /* - * Return statement. - */ - ++n_ret; - ret_anlz(ilc); - break; - - case ILC_Susp: - /* - * Suspend statement. - */ - ++n_susp; - ret_anlz(ilc); - break; - - case ILC_CGto: - /* - * Conditional goto. - */ - ilc_anlz(ilc->code[0]); - break; - } - ilc = ilc->next; - } - } - -/* - * ret_anlz - gather information about the in-line C code associated - * with a return or suspend. - */ -static void ret_anlz(ilc) -struct il_c *ilc; - { - int i; - int j; - - /* - * See if the code is simply returning a parameter. - */ - if (ilc->n == RetDesc && ilc->code[0]->il_c_type == ILC_Ref && - ilc->code[0]->next == NULL) { - j = ilc->code[0]->n; - ++cur_symtab[j].n_refs; - ++cur_symtab[j].n_rets; - } - else { - for (i = 0; i < 3 && ilc->code[i] != NULL; ++i) - ilc_anlz(ilc->code[i]); - } - } - -/* - * deref_il - dummy routine to pass to a code walk. - */ -/*ARGSUSED*/ -static int defer_il(il) -struct il_code *il; - { - /* - * Called for each case in a type_case statement that might be selected. - * However, the actual analysis of the case, if it is needed, - * is done elsewhere, so just return. - */ - return 0; - } - -/* - * findcases - determine how many cases of an type_case statement may - * be true. If there are two or less, determine the "if" statement - * that can be used (if there are more than two, the code is not - * in-lined). - */ -void findcases(il, has_dflt, case_anlz) -struct il_code *il; -int has_dflt; -struct case_anlz *case_anlz; - { - int i; - - case_anlz->n_cases = 0; - case_anlz->typcd = -1; - case_anlz->il_then = NULL; - case_anlz->il_else = NULL; - i = type_case(il, defer_il, case_anlz); - /* - * See if the explicit cases have accounted for all possible - * types that might be present. - */ - if (i == -1) { /* all types accounted for */ - if (case_anlz->il_else == NULL && case_anlz->il_then != NULL) { - /* - * We don't need to actually check the type. - */ - case_anlz->il_else = case_anlz->il_then; - case_anlz->il_then = NULL; - case_anlz->typcd = -1; - } - } - else { /* not all types accounted for */ - if (case_anlz->il_else != NULL) - case_anlz->n_cases = 3; /* force no inlining */ - else if (has_dflt) - case_anlz->il_else = il->u[i].fld; /* default */ - } - - if (case_anlz->n_cases > 2) - n_branches = 2; /* no in-lining */ - else if (case_anlz->il_then != NULL) - ++n_branches; - } - - -/* - * tc_anlz - analyze a type_case statement. It is only of interest for - * in-lining if it can be reduced to an "if" statement or an - * unconditional statement. - */ -static int tc_anlz(il, has_dflt) -struct il_code *il; -int has_dflt; - { - struct case_anlz case_anlz; - int fall_thru; - int indx; - - findcases(il, has_dflt, &case_anlz); - - if (case_anlz.il_else == NULL) - fall_thru = 1; /* either no code at all or condition with no "else" */ - else - fall_thru = 0; /* either unconditional or if-then-else: check code */ - - if (case_anlz.il_then != NULL) { - fall_thru |= il_anlz(case_anlz.il_then); - indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ - if (indx < cur_symtyps->nsyms) - ++cur_symtab[indx].n_refs; - } - if (case_anlz.il_else != NULL) - fall_thru |= il_anlz(case_anlz.il_else); - return fall_thru; - } - -/* - * arth_anlz - analyze the type checking of an arith_case statement. - */ -void arth_anlz(var1, var2, maybe_int, maybe_dbl, chk1, conv1p, chk2, conv2p) -struct il_code *var1; -struct il_code *var2; -int *maybe_int; -int *maybe_dbl; -int *chk1; -struct code **conv1p; -int *chk2; -struct code **conv2p; - { - int cond; - int cnv_typ; - - - /* - * First do an analysis to find out which cases are needed. This is - * more accurate than analysing the conversions separately, but does - * not get all the information we need. - */ - eval_arith(var1->u[0].n, var2->u[0].n, maybe_int, maybe_dbl); - - if (*maybe_int & (largeints | *maybe_dbl)) { - /* - * Too much type checking; don't bother with these cases. Force no - * in-lining. - */ - n_branches += 2; - } - else { - if (*maybe_int) - cnv_typ = TypCInt; - else - cnv_typ = TypCDbl; - - /* - * See exactly what kinds of conversions/type checks are needed and, - * if requested, generate code for them. - */ - *chk1 = 0; - *chk2 = 0; - - cond = cnv_anlz(cnv_typ, var1, NULL, NULL, conv1p); - if (cond & MaybeFalse) { - ++n_branches; /* run-time decision */ - *chk1 = 1; - if (var1->u[0].n < cur_symtyps->nsyms) - ++cur_symtab[var1->u[0].n].n_refs; /* used in runerr2() */ - } - cond = cnv_anlz(cnv_typ, var2, NULL, NULL, conv2p); - if (cond & MaybeFalse) { - ++n_branches; /* run-time decision */ - *chk2 = 1; - if (var2->u[0].n < cur_symtyps->nsyms) - ++cur_symtab[var2->u[0].n].n_refs; /* used in runerr2() */ - } - } - } diff --git a/src/iconc/inline.c b/src/iconc/inline.c deleted file mode 100644 index 234229c..0000000 --- a/src/iconc/inline.c +++ /dev/null @@ -1,2007 +0,0 @@ -/* - * inline.c - routines to put run-time routines in-line. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "ccode.h" -#include "csym.h" -#include "ctree.h" -#include "cproto.h" -#include "cglobals.h" - -/* - * Prototypes for static functions. - */ -static void arth_arg ( struct il_code *var, - struct val_loc *v_orig, int chk, - struct code *cnv); -static int body_fnc (struct il_code *il); -static void chkforblk (void); -static void cnv_dest (int loc, int is_cstr, - struct il_code *src, int sym_indx, - struct il_c *dest, struct code *cd, int i); -static void dwrd_asgn (struct val_loc *vloc, char *typ); -static struct il_c *line_ilc (struct il_c *ilc); -static int gen_if (struct code *cond_cd, - struct il_code *il_then, - struct il_code *il_else, - struct val_loc **locs); -static int gen_il (struct il_code *il); -static void gen_ilc (struct il_c *il); -static void gen_ilret (struct il_c *ilc); -static int gen_tcase (struct il_code *il, int has_dflt); -static void il_var (struct il_code *il, struct code *cd, - int indx); -static void mrg_locs (struct val_loc **locs); -static struct code *oper_lbl (char *s); -static void part_asgn (struct val_loc *vloc, char *asgn, - struct il_c *value); -static void rstr_locs (struct val_loc **locs); -static struct val_loc **sav_locs (void); -static void sub_ilc (struct il_c *ilc, struct code *cd, int indx); - -/* - * There are many parameters that are shared by multiple routines. There - * are copied into statics. - */ -static struct val_loc *rslt; /* result location */ -static struct code **scont_strt; /* label following operation code */ -static struct code **scont_fail; /* resumption label for in-line suspend */ -static struct c_fnc *cont; /* success continuation */ -static struct implement *impl; /* data base entry for operation */ -static int nsyms; /* number symbols in operation symbol table */ -static int n_vararg; /* size of variable part of arg list */ -static nodeptr intrnl_lftm; /* lifetime of internal variables */ -static struct val_loc **tended; /* array of tended locals */ - -/* - * gen_inlin - generate in-line code for an operation. - */ -void gen_inlin(il, r, strt, fail, c, ip, ns, st, n, dcl_var, n_va) -struct il_code *il; -struct val_loc *r; -struct code **strt; -struct code **fail; -struct c_fnc *c; -struct implement *ip; -int ns; -struct op_symentry *st; -nodeptr n; -int dcl_var; -int n_va; - { - struct code *cd; - struct val_loc *tnd; - int i; - - /* - * Copy arguments in to globals. - */ - rslt = r; - scont_strt = strt; - scont_fail = fail; - cont = c; - impl = ip; - nsyms = ns; - cur_symtab = st; - intrnl_lftm = n->intrnl_lftm; - cur_symtyps = n->symtyps; - n_vararg = n_va; - - /* - * Generate code to initialize local tended descriptors and determine - * how to access the descriptors. - */ - for (i = 0; i < impl->ntnds; ++i) { - if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { - tnd = chk_alc(NULL, n->intrnl_lftm); - switch (impl->tnds[i].var_type) { - case TndDesc: - cur_symtab[dcl_var].loc = tnd; - break; - case TndStr: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = emptystr;"; - cd_add(cd); - cur_symtab[dcl_var].loc = loc_cpy(tnd, M_CharPtr); - break; - case TndBlk: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nullptr;"; - cd_add(cd); - cur_symtab[dcl_var].loc = loc_cpy(tnd, M_BlkPtr); - cur_symtab[dcl_var].loc->blk_name = impl->tnds[i].blk_name; - break; - } - if (impl->tnds[i].init != NULL) { - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = cur_symtab[dcl_var].loc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - sub_ilc(impl->tnds[i].init, cd, 2); - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - } - ++dcl_var; - } - - /* - * If there are local non-tended variables, generate code for the - * declarations, placing everything in braces. - */ - if (impl->nvars > 0) { - cd = NewCode(0); - cd->cd_id = C_LBrack; /* { */ - cd_add(cd); - for (i = 0; i < impl->nvars; ++i) { - if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { - gen_ilc(impl->vars[i].dcl); - cur_symtab[dcl_var].loc = cvar_loc(impl->vars[i].name); - } - ++dcl_var; - } - } - - gen_il(il); /* generate executable code */ - - if (impl->nvars > 0) { - cd = NewCode(0); - cd->cd_id = C_RBrack; /* } */ - cd_add(cd); - } - } - -/* - * gen_il - generate code from a sub-tree of in-line code from the data - * base. Determine if execution can continue past this code. - * - */ -static int gen_il(il) -struct il_code *il; - { - struct code *cd; - struct code *cd1; - struct il_code *il_cond; - struct il_code *il_then; - struct il_code *il_else; - struct il_code *il_t; - struct val_loc **locs; - struct val_loc **locs1; - struct val_loc *tnd; - int fall_thru; - int cond; - int ncases; - int indx; - int ntended; - int i; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 1; - - case IL_If1: - case IL_If2: - /* - * if-then or if-then-else statement. - */ - il_then = il->u[1].fld; - if (il->il_type == IL_If2) - il_else = il->u[2].fld; - else - il_else = NULL; - il_cond = il->u[0].fld; - if (il->u[0].fld->il_type == IL_Bang) { - il_cond = il_cond->u[0].fld; - il_t = il_then; - il_then = il_else; - il_else = il_t; - } - locs = sav_locs(); - cond = cond_anlz(il_cond, &cd1); - if (cond == (MaybeTrue | MaybeFalse)) - fall_thru = gen_if(cd1, il_then, il_else, locs); - else { - if (cd1 != NULL) { - cd_add(cd1); /* condition contains needed conversions */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = ";"; - cd_add(cd); - } - if (cond == MaybeTrue) - fall_thru = gen_il(il_then); - else if (cond == MaybeFalse) { - locs1 = sav_locs(); - rstr_locs(locs); - locs = locs1; - fall_thru = gen_il(il_else); - } - mrg_locs(locs); - } - return fall_thru; - - case IL_Tcase1: - /* - * type_case statement with no default clause. - */ - return gen_tcase(il, 0); - - case IL_Tcase2: - /* - * type_case statement with a default clause. - */ - return gen_tcase(il, 1); - - case IL_Lcase: - /* - * len_case statement. Determine which case matches the number - * of arguments. - */ - ncases = il->u[0].n; - indx = 1; - for (i = 0; i < ncases; ++i) { - if (il->u[indx++].n == n_vararg) /* selection number */ - return gen_il(il->u[indx].fld); /* action */ - ++indx; - } - return gen_il(il->u[indx].fld); /* default */ - - case IL_Acase: { - /* - * arith_case statement. - */ - struct il_code *var1; - struct il_code *var2; - struct val_loc *v_orig1; - struct val_loc *v_orig2; - struct code *cnv1; - struct code *cnv2; - int maybe_int; - int maybe_dbl; - int chk1; - int chk2; - - var1 = il->u[0].fld; - var2 = il->u[1].fld; - v_orig1 = cur_symtab[var1->u[0].n].loc; /* remember for error msgs */ - v_orig2 = cur_symtab[var2->u[0].n].loc; /* remember for error msgs */ - arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, &cnv1, - &chk2, &cnv2); - - /* - * This statement is in-lined if there is only C integer - * arithmetic, only C double arithmetic, or only a run-time - * error. - */ - arth_arg(var1, v_orig1, chk1, cnv1); - arth_arg(var2, v_orig2, chk2, cnv2); - if (maybe_int) - return gen_il(il->u[2].fld); /* C_integer action */ - else if (maybe_dbl) - return gen_il(il->u[4].fld); /* C_double action */ - else - return 0; - } - - case IL_Err1: - /* - * runerr() with no offending value. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg("; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = il->u[0].n; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL);"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - - case IL_Err2: - /* - * runerr() with an offending value. Note the reference to - * the offending value descriptor. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg("; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = il->u[0].n; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &("; - il_var(il->u[1].fld, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - - case IL_Lst: - /* - * Two consecutive pieces of RTL code. - */ - fall_thru = gen_il(il->u[0].fld); - if (fall_thru) - fall_thru = gen_il(il->u[1].fld); - return fall_thru; - - case IL_Block: - /* - * inline {...} statement. - * - * Allocate and initialize any tended locals. - */ - ntended = il->u[1].n; - if (ntended > 0) - tended = (struct val_loc **)alloc((unsigned int) - sizeof(struct val_loc *) * ntended); - for (i = 2; i - 2 < ntended; ++i) { - tnd = chk_alc(NULL, intrnl_lftm); - tended[i - 2] = tnd; - switch (il->u[i].n) { - case TndDesc: - break; - case TndStr: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = emptystr;"; - cd_add(cd); - break; - case TndBlk: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nullptr;"; - cd_add(cd); - break; - } - } - gen_ilc(il->u[i].c_cd); /* body of block */ - /* - * See if execution can fall through this code. - */ - if (il->u[0].n) - return 1; - else { - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - } - - case IL_Call: - /* - * call to body function. - */ - return body_fnc(il); - - case IL_Abstr: - /* - * abstract type computation. Only used by type inference. - */ - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - -/* - * arth_arg - in-line code to check a conversion for an arith_case statement. - */ -static void arth_arg(var, v_orig, chk, cnv) -struct il_code *var; -struct val_loc *v_orig; -int chk; -struct code *cnv; - { - struct code *lbl; - struct code *cd; - - if (chk) { - /* - * Must check the conversion. - */ - lbl = oper_lbl("converted"); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - if (cnv != NULL) { - cd = NewCode(2); - cd->cd_id = C_If; - cd->Cond = cnv; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - } - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(102, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = v_orig; /* var location before conversion */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else if (cnv != NULL) { - cd_add(cnv); /* conversion cannot fail */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = ";"; - cd_add(cd); - } - } - -/* - * body_fnc - generate code to call a body function. - */ -static int body_fnc(il) -struct il_code *il; - { - struct code *arg_lst; - struct code *cd; - struct c_fnc *cont1; - char *oper_nm; - int ret_val; - int ret_flag; - int need_rslt; - int num_sbuf; - int num_cbuf; - int expl_args; - int arglst_sz; /* size of arg list in number of code pieces */ - int il_indx; - int cd_indx; - int proto_prt; - int i; - - /* - * Determine if a function prototype has been printed yet for this - * body function. - */ - proto_prt = il->u[0].n; - il->u[0].n = 1; - - /* - * Construct the name of the body function. - */ - oper_nm = (char *)alloc((unsigned int)(strlen(impl->name) + 6)); - sprintf(oper_nm, "%c%c%c%c_%s", impl->oper_typ, impl->prefix[0], - impl->prefix[1], (char)il->u[1].n, impl->name); - - /* - * Extract from the call the flags and other information describing - * the function, then use this information to deduce the arguments - * needed by the function. - */ - ret_val = il->u[2].n; - ret_flag = il->u[3].n; - need_rslt = il->u[4].n; - num_sbuf = il->u[5].n; - num_cbuf = il->u[6].n; - expl_args = il->u[7].n; - - /* - * determine how large the argument list is. - */ - arglst_sz = 2 * expl_args - 1; - if (num_sbuf > 0) - arglst_sz += 3; - if (num_cbuf > 0) - arglst_sz += 2; - if (need_rslt) - arglst_sz += 3; - if (arglst_sz > 0) - arg_lst = alc_ary(arglst_sz); - else - arg_lst = alc_ary(0); - - if (!proto_prt) { - /* - * Determine whether the body function returns a C integer, double, - * no value, or a signal. - */ - switch (ret_val) { - case RetInt: - fprintf(inclfile, "C_integer %s (", oper_nm); - break; - case RetDbl: - fprintf(inclfile, "double %s (", oper_nm); - break; - case RetNoVal: - fprintf(inclfile, "void %s (", oper_nm); - break; - case RetSig: - fprintf(inclfile, "int %s (", oper_nm); - break; - } - } - - /* - * Produce prototype and code for the explicit arguments in the - * function call. Note that the call entry contains C code for both. - */ - il_indx = 8; - cd_indx = 0; - while (expl_args--) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - if (!proto_prt) - fprintf(inclfile, "%s", il->u[il_indx].c_cd->s); /* parameter dcl */ - ++il_indx; - sub_ilc(il->u[il_indx++].c_cd, arg_lst, cd_indx++); - } - - /* - * If string buffers are needed, allocate them and pass pointer to - * function. - */ - if (num_sbuf > 0) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_Str; - arg_lst->Str(cd_indx) = "(char (*)[MaxCvtLen])"; - ++cd_indx; - arg_lst->ElemTyp(cd_indx) = A_SBuf; - arg_lst->Intgr(cd_indx) = alc_sbufs(num_sbuf, intrnl_lftm); - if (!proto_prt) - fprintf(inclfile, "char (*r_sbuf)[MaxCvtLen]"); - ++cd_indx; - } - - /* - * If cset buffers are needed, allocate them and pass pointer to - * function. - */ - if (num_cbuf > 0) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_CBuf; - arg_lst->Intgr(cd_indx) = alc_cbufs(num_cbuf, intrnl_lftm); - if (!proto_prt) - fprintf(inclfile, "struct b_cset *r_cbuf"); - ++cd_indx; - } - - /* - * See if the function needs a pointer to the result location - * of the operation. - */ - if (need_rslt) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_Str; /* location of result */ - arg_lst->Str(cd_indx) = "&"; - ++cd_indx; - arg_lst->ElemTyp(cd_indx) = A_ValLoc; - arg_lst->ValLoc(cd_indx) = rslt; - if (!proto_prt) - fprintf(inclfile, "dptr rslt"); - ++cd_indx; - } - - if (!proto_prt) { - /* - * The last possible argument is the success continuation. - * If there are no arguments, indicate this in the prototype. - */ - if (ret_flag & DoesSusp) { - if (cd_indx > 0) - fprintf(inclfile, ", "); - fprintf(inclfile, "continuation succ_cont"); - } - else if (cd_indx == 0) - fprintf(inclfile, "void"); - fprintf(inclfile, ");\n"); - } - - /* - * Does this call need the success continuation for the operation. - */ - if (ret_flag & DoesSusp) - cont1 = cont; - else - cont1 = NULL; - - switch (ret_val) { - case RetInt: - /* - * The body function returns a C integer. - */ - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.integr = "; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = oper_nm; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "("; - cd->ElemTyp(4) = A_Ary; - cd->Array(4) = arg_lst; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = ");"; - cd_add(cd); - dwrd_asgn(rslt, "Integer"); - cd_add(mk_goto(*scont_strt)); - break; - case RetDbl: - /* - * The body function returns a C double. - */ - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.bptr = (union block *)alcreal("; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = oper_nm; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "("; - cd->ElemTyp(4) = A_Ary; - cd->Array(4) = arg_lst; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = "));"; - cd_add(cd); - dwrd_asgn(rslt, "Real"); - chkforblk(); /* make sure the block allocation succeeded */ - cd_add(mk_goto(*scont_strt)); - break; - case RetNoVal: - /* - * The body function does not directly return a value. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = oper_nm; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = "("; - cd->ElemTyp(2) = A_Ary; - cd->Array(2) = arg_lst; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - if (ret_flag & DoesFail | (err_conv && (ret_flag & DoesEFail))) - cd_add(sig_cd(on_failure, cur_fnc)); - else if (ret_flag & DoesRet) - cd_add(mk_goto(*scont_strt)); - break; - case RetSig: - /* - * The body function returns a signal. - */ - callo_add(oper_nm, ret_flag, cont1, 0, arg_lst, mk_goto(*scont_strt)); - break; - } - /* - * See if execution can fall through this call. - */ - if (ret_flag & DoesFThru) - return 1; - else { - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - } - } - - -/* - * il_var - generate code for a possibly subscripted variable into - * an element of a code array. - */ -static void il_var(il, cd, indx) -struct il_code *il; -struct code *cd; -int indx; - { - struct code *cd1; - - if (il->il_type == IL_Subscr) { - /* - * Subscripted variable. - */ - cd1 = cd; - cd = alc_ary(4); - cd1->ElemTyp(indx) = A_Ary; - cd1->Array(indx) = cd; - indx = 0; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = "["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = il->u[1].n; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "]"; - } - - /* - * See if this is the result location of the operation or an ordinary - * variable. - */ - cd->ElemTyp(indx) = A_ValLoc; - if (il->u[0].n == RsltIndx) - cd->ValLoc(indx) = rslt; - else - cd->ValLoc(indx) = cur_symtab[il->u[0].n].loc; - } - -/* - * part_asgn - generate code for an assignment to (part of) a descriptor. - */ -static void part_asgn(vloc, asgn, value) -struct val_loc *vloc; -char *asgn; -struct il_c *value; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = vloc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = asgn; - sub_ilc(value, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - -/* - * dwrd_asgn - generate code to assign a type code to the dword of a descriptor. - */ -static void dwrd_asgn(vloc, typ) -struct val_loc *vloc; -char *typ; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = vloc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_"; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = typ; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - -/* - * sub_ilc - generate code from a sequence of C code and place it - * in a slot in a code array. - */ -static void sub_ilc(ilc, cd, indx) -struct il_c *ilc; -struct code *cd; -int indx; - { - struct il_c *ilc1; - struct code *cd1; - int n; - - /* - * Count the number of pieces of C code to process. - */ - n = 0; - for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) - ++n; - - /* - * If there is only one piece of code, place it directly in the - * slot of the array. Otherwise allocate a sub-array and place it - * in the slot. - */ - if (n > 1) { - cd1 = cd; - cd = alc_ary(n); - cd1->ElemTyp(indx) = A_Ary; - cd1->Array(indx) = cd; - indx = 0; - } - - while (ilc != NULL) { - switch (ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - /* - * Reference to variable in symbol table. - */ - cd->ElemTyp(indx) = A_ValLoc; - if (ilc->n == RsltIndx) - cd->ValLoc(indx) = rslt; - else { - if (ilc->s == NULL) - cd->ValLoc(indx) = cur_symtab[ilc->n].loc; - else { - /* - * Access the entire descriptor. - */ - cd->ValLoc(indx) = loc_cpy(cur_symtab[ilc->n].loc, M_None); - } - } - break; - - case ILC_Tend: - /* - * Reference to a tended variable. - */ - cd->ElemTyp(indx) = A_ValLoc; - cd->ValLoc(indx) = tended[ilc->n]; - break; - - case ILC_Str: - /* - * String representing C code. - */ - cd->ElemTyp(indx) = A_Str; - cd->Str(indx) = ilc->s; - break; - - case ILC_SBuf: - /* - * String buffer for a conversion. - */ - cd->ElemTyp(indx) = A_SBuf; - cd->Intgr(indx) = alc_sbufs(1, intrnl_lftm); - break; - - case ILC_CBuf: - /* - * Cset buffer for a conversion. - */ - cd->ElemTyp(indx) = A_CBuf; - cd->Intgr(indx) = alc_cbufs(1, intrnl_lftm); - break; - - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - } - ilc = ilc->next; - ++indx; - } - - } - -/* - * gen_ilret - generate code to set the result value from a suspend or - * return. - */ -static void gen_ilret(ilc) -struct il_c *ilc; - { - struct il_c *ilc0; - struct code *cd; - char *cap_id; - int typcd; - - if (rslt == &ignore) - return; /* Don't bother computing the result; it's never used */ - - ilc0 = ilc->code[0]; - typcd = ilc->n; - - if (typcd < 0) { - /* - * RTL returns that do not look like function calls to standard Icon - * type name. - */ - switch (typcd) { - case TypCInt: - /* - * return/suspend C_integer <expr>; - */ - part_asgn(rslt, ".vword.integr = ", ilc0); - dwrd_asgn(rslt, "Integer"); - break; - case TypCDbl: - /* - * return/suspend C_double <expr>; - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.bptr = (union block *)alcreal("; - sub_ilc(ilc0, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - dwrd_asgn(rslt, "Real"); - chkforblk(); /* make sure the block allocation succeeded */ - break; - case TypCStr: - /* - * return/suspend C_string <expr>; - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "AsgnCStr("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(ilc0, cd, 3); /* <expr> */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - break; - case RetDesc: - /* - * return/suspend <expr>; - */ - part_asgn(rslt, " = ", ilc0); - break; - case RetNVar: - /* - * return/suspend named_var(<desc-pntr>); - */ - part_asgn(rslt, ".vword.descptr = ", ilc0); - dwrd_asgn(rslt, "Var"); - break; - case RetSVar: - /* - * return/suspend struct_var(<desc-pntr>, <block_pntr>); - */ - part_asgn(rslt, ".vword.descptr = (dptr)", ilc->code[1]); - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)"; - sub_ilc(ilc0, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = " - (word *)"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = rslt; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = ".vword.descptr);"; - cd_add(cd); - break; - case RetNone: - /* - * return/suspend result; - * - * Result already set, do nothing. - */ - break; - default: - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - else { - /* - * RTL returns that look like function calls to standard Icon type - * names. - */ - cap_id = icontypes[typcd].cap_id; - switch (icontypes[typcd].rtl_ret) { - case TRetBlkP: - /* - * return/suspend <type>(<block-pntr>); - */ - part_asgn(rslt, ".vword.bptr = (union block *)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetDescP: - /* - * return/suspend <type>(<descriptor-pntr>); - */ - part_asgn(rslt, ".vword.descptr = (dptr)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetCharP: - /* - * return/suspend <type>(<char-pntr>); - */ - part_asgn(rslt, ".vword.sptr = (char *)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetCInt: - /* - * return/suspend <type>(<integer>); - */ - part_asgn(rslt, ".vword.integr = (word)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetSpcl: - /* - * RTL returns that look like function calls to standard type - * names but take more than one argument. - */ - if (typcd == str_typ) { - /* - * return/suspend string(<len>, <char-pntr>); - */ - part_asgn(rslt, ".vword.sptr = ", ilc->code[1]); - part_asgn(rslt, ".dword = ", ilc0); - } - else if (typcd == stv_typ) { - /* - * return/suspend substr(<desc-pntr>, <start>, <len>); - */ - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "SubStr(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(ilc0, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - sub_ilc(ilc->code[2], cd, 5); - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ", "; - sub_ilc(ilc->code[1], cd, 7); - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - chkforblk(); /* make sure the block allocation succeeded */ - } - else { - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - break; - default: - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - } - -/* - * chkforblk - generate code to make sure the allocation of a block - * for the result descriptor was successful. - */ -static void chkforblk() - { - struct code *cd; - struct code *cd1; - struct code *lbl; - - lbl = alc_lbl("got allocation", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rslt; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").vword.bptr != NULL"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(307, NULL);"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - -/* - * gen_ilc - generate code for an sequence of in-line C code. - */ -static void gen_ilc(ilc) -struct il_c *ilc; - { - struct il_c *ilc1; - struct code *cd; - struct code *cd1; - struct code *lbl1; - struct code *fail_sav; - struct code **lbls; - int max_lbl; - int i; - - /* - * Determine how many labels there are in the code and allocate an - * array to map from label numbers to labels in the code. - */ - max_lbl = -1; - for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) { - switch(ilc1->il_c_type) { - case ILC_CGto: - case ILC_Goto: - case ILC_Lbl: - if (ilc1->n > max_lbl) - max_lbl = ilc1->n; - } - } - ++max_lbl; /* adjust for 0 indexing */ - if (max_lbl > 0) { - lbls = (struct code **)alloc((unsigned int) sizeof(struct code *) * - max_lbl); - for (i = 0; i < max_lbl; ++i) - lbls[i] = NULL; - } - - while (ilc != NULL) { - switch(ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - case ILC_Tend: - case ILC_SBuf: - case ILC_CBuf: - case ILC_Str: - /* - * The beginning of a sequence of code fragments that can be - * place on one line. - */ - ilc = line_ilc(ilc); - break; - - case ILC_Fail: - /* - * fail - perform failure action. - */ - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case ILC_EFail: - /* - * errorfail - same as fail if error conversion is supported. - */ - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case ILC_Ret: - /* - * return - set result location and jump out of operation. - */ - gen_ilret(ilc); - cd_add(mk_goto(*scont_strt)); - break; - - case ILC_Susp: - /* - * suspend - set result location. If there is a success - * continuation, call it. Otherwise the "continuation" - * will be generated in-line, so set up a resumption label. - */ - gen_ilret(ilc); - if (cont == NULL) - *scont_strt = cur_fnc->cursor; - lbl1 = oper_lbl("end suspend"); - cd_add(lbl1); - if (cont == NULL) - *scont_fail = lbl1; - else { - cur_fnc->cursor = lbl1->prev; - fail_sav = on_failure; - on_failure = lbl1; - callc_add(cont); - on_failure = fail_sav; - cur_fnc->cursor = lbl1; - } - break; - - case ILC_LBrc: - /* - * non-deletable '{' - */ - cd = NewCode(0); - cd->cd_id = C_LBrack; - cd_add(cd); - break; - - case ILC_RBrc: - /* - * non-deletable '}' - */ - cd = NewCode(0); - cd->cd_id = C_RBrack; - cd_add(cd); - break; - - case ILC_CGto: - /* - * Conditional goto. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - sub_ilc(ilc->code[0], cd1, 0); - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbls[i]); - cd_add(cd); - break; - - case ILC_Goto: - /* - * Goto. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd_add(mk_goto(lbls[i])); - break; - - case ILC_Lbl: - /* - * Label. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd_add(lbls[i]); - break; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - } - ilc = ilc->next; - } - - if (max_lbl > 0) - free((char *)lbls); - } - -/* - * line_ilc - gather a line of in-line code. - */ -static struct il_c *line_ilc(ilc) -struct il_c *ilc; - { - struct il_c *ilc1; - struct il_c *last; - struct code *cd; - int n; - int i; - - /* - * Count the number of pieces in the line. Determine the last - * piece in the sequence; this is returned to the caller. - */ - n = 0; - ilc1 = ilc; - while (ilc1 != NULL) { - switch(ilc1->il_c_type) { - case ILC_Ref: - case ILC_Mod: - case ILC_Tend: - case ILC_SBuf: - case ILC_CBuf: - case ILC_Str: - ++n; - last = ilc1; - ilc1 = ilc1->next; - break; - default: - ilc1 = NULL; - } - } - - /* - * Construct the line. - */ - cd = alc_ary(n); - for (i = 0; i < n; ++i) { - switch(ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - /* - * Reference to variable in symbol table. - */ - cd->ElemTyp(i) = A_ValLoc; - if (ilc->n == RsltIndx) - cd->ValLoc(i) = rslt; - else - cd->ValLoc(i) = cur_symtab[ilc->n].loc; - break; - - case ILC_Tend: - /* - * Reference to a tended variable. - */ - cd->ElemTyp(i) = A_ValLoc; - cd->ValLoc(i) = tended[ilc->n]; - break; - - case ILC_SBuf: - /* - * String buffer for a conversion. - */ - cd->ElemTyp(i) = A_SBuf; - cd->Intgr(i) = alc_sbufs(1, intrnl_lftm); - break; - - case ILC_CBuf: - /* - * Cset buffer for a conversion. - */ - cd->ElemTyp(i) = A_CBuf; - cd->Intgr(i) = alc_cbufs(1, intrnl_lftm); - break; - - case ILC_Str: - /* - * String representing C code. - */ - cd->ElemTyp(i) = A_Str; - cd->Str(i) = ilc->s; - break; - - default: - ilc = NULL; - } - ilc = ilc->next; - } - - cd_add(cd); - return last; - } - -/* - * generate code to perform simple type checking. - */ -struct code *typ_chk(var, typcd) -struct il_code *var; -int typcd; - { - struct code *cd; - - if (typcd == int_typ && largeints) { - /* - * Handle large integer support specially. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_Integer || ("; - il_var(var, cd, 3); /* value */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ").dword == D_Lrgint)"; - return cd; - } - else if (typcd < 0) { - /* - * Not a standard Icon type name. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - switch (typcd) { - case TypVar: - cd->Str(0) = "((("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword & D_Var) == D_Var)"; - break; - case TypCInt: - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_Integer)"; - break; - } - } - else if (typcd == str_typ) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(!(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword & F_Nqual))"; - } - else { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_"; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = icontypes[typcd].cap_id; /* type name */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ")"; - } - - return cd; - } - -/* - * oper_lbl - generate a label with an associated comment that includes - * the operation name. - */ -static struct code *oper_lbl(s) -char *s; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(s) + strlen(impl->name) + 3)); - sprintf(sbuf, "%s: %s", s, impl->name); - return alc_lbl(sbuf, 0); - } - -/* - * sav_locs - save the current interpretation of symbols that may - * be affected by conversions. - */ -static struct val_loc **sav_locs() - { - struct val_loc **locs; - int i; - - if (nsyms == 0) - return NULL; - - locs = (struct val_loc **)alloc((unsigned int)(nsyms * - sizeof(struct val_loc *))); - for (i = 0; i < nsyms; ++i) - locs[i] = cur_symtab[i].loc; - return locs; - } - -/* - * rstr_locs - restore the interpretation of symbols that may - * have been affected by conversions. - */ -static void rstr_locs(locs) -struct val_loc **locs; - { - int i; - - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = locs[i]; - free((char *)locs); - } - -/* - * mrg_locs - merge the interpretations of symbols along two execution - * paths. Any ambiguity is caught by rtt, so differences only occur - * if one path involves program termination so that the symbols - * no longer have an interpretation along that path. - */ -static void mrg_locs(locs) -struct val_loc **locs; - { - int i; - - for (i = 0; i < nsyms; ++i) - if (cur_symtab[i].loc == NULL) - cur_symtab[i].loc = locs[i]; - free((char *)locs); - } - -/* - * il_cnv - generate code for an in-line conversion. - */ -struct code *il_cnv(typcd, src, dflt, dest) -int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; - { - struct code *cd; - struct code *cd1; - int dflt_to_ptr; - int loc; - int is_cstr; - int sym_indx; - int n; - int i; - - sym_indx = src->u[0].n; - - /* - * Determine whether the address must be taken of a default value and - * whether the interpretation of the symbol in an in-place conversion - * changes. - */ - dflt_to_ptr = 0; - loc = PrmTend; - is_cstr = 0; - switch (typcd) { - case TypCInt: - case TypECInt: - loc = PrmInt; - break; - case TypCDbl: - loc = PrmDbl; - break; - case TypCStr: - is_cstr = 1; - break; - case TypEInt: - break; - case TypTStr: - case TypTCset: - dflt_to_ptr = 1; - break; - default: - /* - * Cset, real, integer, or string - */ - if (typcd == cset_typ || typcd == str_typ) - dflt_to_ptr = 1; - break; - } - - if (typcd == TypCDbl && !(eval_is(real_typ, sym_indx) & MaybeFalse)) { - /* - * Conversion from Icon real to C double. Just copy the C value - * from the block. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(GetReal(&("; - il_var(src, cd, 1); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "), "; - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - } - else if (typcd == TypCDbl && !largeints && - !(eval_is(int_typ, sym_indx) & MaybeFalse)) { - /* - * Conversion from Icon integer (not large integer) to C double. - * Do as a C conversion by an assigment. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = IntVal( "; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - /* - * Note that cnv_dest() must be called after the source is output - * in case it changes the location of the parameter. - */ - il_var(src, cd, 3); - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 1); - } - else { - /* - * Compute the number of code fragments required to construct the - * call to the conversion routine. - */ - n = 7; - if (dflt != NULL) - n += 2; - - cd = alc_ary(n); - - /* - * The names of simple conversions are distinguished from defaulting - * conversions by a prefix of "cnv_" or "def_". - */ - cd->ElemTyp(0) = A_Str; - if (dflt == NULL) - cd->Str(0) = "cnv_"; - else - cd->Str(0) = "def_"; - - /* - * Determine the name of the conversion routine. - */ - cd->ElemTyp(1) = A_Str; /* may be overridden */ - switch (typcd) { - case TypCInt: - cd->Str(1) = "c_int(&("; - break; - case TypCDbl: - cd->Str(1) = "c_dbl(&("; - break; - case TypCStr: - cd->Str(1) = "c_str(&("; - break; - case TypEInt: - cd->Str(1) = "eint(&("; - break; - case TypECInt: - cd->Str(1) = "ec_int(&("; - break; - case TypTStr: - /* - * Allocate a string buffer. - */ - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "tstr("; - cd1->ElemTyp(1) = A_SBuf; - cd1->Intgr(1) = alc_sbufs(1, intrnl_lftm); - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (&"; - cd->ElemTyp(1) = A_Ary; - cd->Array(1) = cd1; - break; - case TypTCset: - /* - * Allocate a cset buffer. - */ - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "tcset("; - cd1->ElemTyp(1) = A_CBuf; - cd1->Intgr(1) = alc_cbufs(1, intrnl_lftm); - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &("; - cd->ElemTyp(1) = A_Ary; - cd->Array(1) = cd1; - break; - default: - /* - * Cset, real, integer, or string - */ - if (typcd == cset_typ) - cd->Str(1) = "cset(&("; - else if (typcd == real_typ) - cd->Str(1) = "real(&("; - else if (typcd == int_typ) - cd->Str(1) = "int(&("; - else if (typcd == str_typ) - cd->Str(1) = "str(&("; - break; - } - - il_var(src, cd, 2); - - cd->ElemTyp(3) = A_Str; - if (dflt != NULL && dflt_to_ptr) - cd->Str(3) = "), &("; - else - cd->Str(3) = "), "; - - - /* - * Determine if this conversion has a default value. - */ - i = 4; - if (dflt != NULL) { - sub_ilc(dflt, cd, i); - ++i; - cd->ElemTyp(i) = A_Str; - if (dflt_to_ptr) - cd->Str(i) = "), "; - else - cd->Str(i) = ", "; - ++i; - } - - cd->ElemTyp(i) = A_Str; - cd->Str(i) = "&("; - ++i; - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i); - ++i; - cd->ElemTyp(i) = A_Str; - cd->Str(i) = "))"; - } - return cd; - } - -/* - * il_dflt - generate code for a defaulting conversion that always defaults. - */ -struct code *il_dflt(typcd, src, dflt, dest) -int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; - { - struct code *cd; - int sym_indx; - - sym_indx = src->u[0].n; - - if (typcd == TypCDbl) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(PrmDbl, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypCInt || typcd == TypECInt) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(PrmInt, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypTStr || typcd == str_typ) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypCStr) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(AsgnCStr("; - cnv_dest(0, 1, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - } - else if (typcd == TypTCset || typcd == cset_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(BlkLoc("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (union block *)&"; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Cset, 1)"; - } - else if (typcd == TypEInt || typcd == int_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(IntVal("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Integer, 1)"; - } - else if (typcd == real_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "((BlkLoc("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (union block *)alcreal("; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ")) == NULL ? (fatalerr(0,NULL), 0) : ("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Real, 1))"; - } - - return cd; - } - -/* - * cnv_dest - output the destination of a conversion. - */ -static void cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i) -int loc; -int is_cstr; -struct il_code *src; -int sym_indx; -struct il_c *dest; -struct code *cd; -int i; - { - if (dest == NULL) { - /* - * Convert "in place", changing the location of a parameter if needed. - */ - switch (loc) { - case PrmInt: - if (cur_symtab[sym_indx].itmp_indx < 0) - cur_symtab[sym_indx].itmp_indx = alc_itmp(intrnl_lftm); - cur_symtab[sym_indx].loc = itmp_loc(cur_symtab[sym_indx].itmp_indx); - break; - case PrmDbl: - if (cur_symtab[sym_indx].dtmp_indx < 0) - cur_symtab[sym_indx].dtmp_indx = alc_dtmp(intrnl_lftm); - cur_symtab[sym_indx].loc = dtmp_loc(cur_symtab[sym_indx].dtmp_indx); - break; - } - il_var(src, cd, i); - if (is_cstr) - cur_symtab[sym_indx].loc = loc_cpy(cur_symtab[sym_indx].loc,M_CharPtr); - } - else { - if (is_cstr && dest->il_c_type == ILC_Mod && dest->next == NULL && - dest->n != RsltIndx && cur_symtab[dest->n].loc->mod_access != M_None) { - /* - * We are converting to a C string. The destination variable - * is not defined as a simple descriptor, but must be accessed - * as such for this conversion. - */ - cd->ElemTyp(i) = A_ValLoc; - cd->ValLoc(i) = loc_cpy(cur_symtab[dest->n].loc, M_None); - } - else - sub_ilc(dest, cd, i); - } - - } - -/* - * il_copy - produce code for an optimized "conversion" that always succeeds - * and just copies a value from one place to another. - */ -struct code *il_copy(dest, src) -struct il_c *dest; -struct val_loc *src; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - sub_ilc(dest, cd, 1); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = src; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - return cd; - } - -/* - * loc_cpy - make a copy of a reference to a value location, but change - * the way the location is accessed. - */ -struct val_loc *loc_cpy(loc, mod_access) -struct val_loc *loc; -int mod_access; - { - struct val_loc *new_loc; - - if (loc == NULL) - return NULL; - new_loc = NewStruct(val_loc); - *new_loc = *loc; - new_loc->mod_access = mod_access; - return new_loc; - } - -/* - * gen_tcase - generate in-line code for a type_case statement. - */ -static int gen_tcase(il, has_dflt) -struct il_code *il; -int has_dflt; - { - struct case_anlz case_anlz; - - /* - * We can only get here if the type_case statement can be implemented - * with a no more than one type check. Determine how simple the - * code can be. - */ - findcases(il, has_dflt, &case_anlz); - if (case_anlz.il_then == NULL) { - if (case_anlz.il_else == NULL) - return 1; - else - return gen_il(case_anlz.il_else); - } - else - return gen_if(typ_chk(il->u[0].fld, case_anlz.typcd), case_anlz.il_then, - case_anlz.il_else, sav_locs()); - } - -/* - * gen_if - generate code to test a condition that might be true - * of false. Determine if execution can continue past this if statement. - */ -static int gen_if(cond_cd, il_then, il_else, locs) -struct code *cond_cd; -struct il_code *il_then; -struct il_code *il_else; -struct val_loc **locs; - { - struct val_loc **locs1; - struct code *lbl_then; - struct code *lbl_end; - struct code *else_loc; - struct code *cd; - int fall_thru; - - lbl_then = oper_lbl("then"); - lbl_end = oper_lbl("end if"); - cd = NewCode(2); - cd->cd_id = C_If; - cd->Cond = cond_cd; - cd->ThenStmt = mk_goto(lbl_then); - cd_add(cd); - else_loc = cur_fnc->cursor; - cd_add(lbl_then); - fall_thru = gen_il(il_then); - cd_add(lbl_end); - locs1 = sav_locs(); - rstr_locs(locs); - cur_fnc->cursor = else_loc; /* go back for the else clause */ - fall_thru |= gen_il(il_else); - cd_add(mk_goto(lbl_end)); - cur_fnc->cursor = lbl_end; - mrg_locs(locs1); - return fall_thru; - } diff --git a/src/iconc/ivalues.c b/src/iconc/ivalues.c deleted file mode 100644 index 4fbb288..0000000 --- a/src/iconc/ivalues.c +++ /dev/null @@ -1,51 +0,0 @@ -/* - * ivalues.c - routines for manipulating Icon values. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#include "cglobals.h" - - -/* - * iconint - convert the string representation of an Icon integer to a C long. - * Return -1 if the number is too big and large integers are supported. - */ -long iconint(image) -char *image; - { - register int c; - register int r; - register char *s; - long n, n1; - int overflow; - - s = image; - overflow = 0; - n = 0L; - while ((c = *s++) >= '0' && c <= '9') { - n1 = n * 10 + (c - '0'); - if (n != n1 / 10) - overflow = 1; - n = n1; - } - if (c == 'r' || c == 'R') { - r = n; - n = 0L; - while ((c = *s++) != '\0') { - n1 = n * r + tonum(c); - if (n != n1 / r) - overflow = 1; - n = n1; - } - } - if (overflow) - if (largeints) - n = -1; - else - tfatal("large integer option required", image); - return n; - } diff --git a/src/iconc/lifetime.c b/src/iconc/lifetime.c deleted file mode 100644 index 9a4a7b5..0000000 --- a/src/iconc/lifetime.c +++ /dev/null @@ -1,496 +0,0 @@ -/* - * lifetime.c - perform liveness analysis to determine lifetime of intermediate - * results. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "ctree.h" -#include "ctoken.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes for static functions. - */ -static void arg_life (nodeptr n, long min_result, long max_result, - int resume, int frst_arg, int nargs, nodeptr resumer, - nodeptr *failer, int *gen); - -static int postn = -1; /* relative position in execution order (all neg) */ - -/* - * liveness - compute lifetimes of intermediate results. - */ -void liveness(n, resumer, failer, gen) -nodeptr n; -nodeptr resumer; -nodeptr *failer; -int *gen; - { - struct loop { - nodeptr resumer; - int gen; - nodeptr lifetime; - int every_cntrl; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop = NULL; - nodeptr failer1; - nodeptr failer2; - int gen1 = 0; - int gen2 = 0; - struct node *cases; - struct node *clause; - long min_result; /* minimum result sequence length */ - long max_result; /* maximum result sequence length */ - int resume; /* flag - resumption possible after last result */ - - n->postn = postn--; - - switch (n->n_type) { - case N_Activat: - /* - * Activation can fail or succeed. - */ - arg_life(n, 0L, 1L, 0, 1, 2, resumer, failer, gen); - break; - - case N_Alt: - Tree1(n)->lifetime = n->lifetime; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, &failer2, &gen2); - liveness(Tree0(n), resumer, &failer1, &gen1); - *failer = failer2; - *gen = 1; - break; - - case N_Apply: - /* - * Assume operation can suspend or fail. - */ - arg_life(n, 0L, UnbndSeq, 1, 0, 2, resumer, failer, gen); - break; - - case N_Augop: - /* - * Impl0(n) is assignment. Impl1(n) is the augmented operation. - */ - min_result = Impl0(n)->min_result * Impl1(n)->min_result; - max_result = Impl0(n)->max_result * Impl1(n)->max_result; - resume = Impl0(n)->resume | Impl1(n)->resume; - arg_life(n, min_result, max_result, resume, 2, 2, resumer, failer, - gen); - break; - - case N_Bar: - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree0(n), resumer, failer, &gen1); - *gen = 1; - break; - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return; - } - Tree0(n)->lifetime = cur_loop->lifetime; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - liveness(Tree0(n), loop_sav->resumer, &failer1, &gen1); - cur_loop = loop_sav; - cur_loop->gen |= gen1; - *failer = NULL; - *gen = 0; - break; - - case N_Case: - *failer = resumer; - *gen = 0; - - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * Body. - */ - Tree1(clause)->lifetime = n->lifetime; - liveness(Tree1(clause), resumer, &failer2, &gen2); - if (resumer == NULL && failer2 != NULL) - *failer = n; - *gen |= gen2; - - /* - * The expression being compared can be resumed. - */ - Tree0(clause)->lifetime = clause; - liveness(Tree0(clause), clause, &failer1, &gen1); - } - - if (Tree2(n) == NULL) { - if (resumer == NULL) - *failer = n; - } - else { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); /* default */ - if (resumer == NULL && failer2 != NULL) - *failer = n; - *gen |= gen2; - } - - /* - * control clause is bounded - */ - Tree0(n)->lifetime = n; - liveness(Tree0(n), NULL, &failer1, &gen1); - if (failer1 != NULL && *failer == NULL) - *failer = failer1; - break; - - case N_Create: - Tree0(n)->lifetime = n; - loop_sav = cur_loop; - cur_loop = NULL; /* check for invalid break and next */ - liveness(Tree0(n), n, &failer1, &gen1); - cur_loop = loop_sav; - *failer = NULL; - *gen = 0; - break; - - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Real: - case N_Str: - *failer = resumer; - *gen = 0; - break; - - case N_Field: - Tree0(n)->lifetime = n; - liveness(Tree0(n), resumer, failer, gen); - break; - - case N_If: - Tree1(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, failer, gen); - if (Tree2(n)->n_type != N_Empty) { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); - if (failer2 != NULL) { - if (*failer == NULL) - *failer = failer2; - else { - if ((*failer)->postn < failer2->postn) - *failer = failer2; - if ((*failer)->postn < n->postn) - *failer = n; - } - } - *gen |= gen2; - } - /* - * control clause is bounded - */ - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - if (Tree2(n)->n_type == N_Empty && failer1 != NULL && *failer == NULL) - *failer = failer1; - break; - - case N_Invok: - /* - * Assume operation can suspend and fail. - */ - arg_life(n, 0L, UnbndSeq, 1, 1, Val0(n) + 1, resumer, failer, gen); - break; - - case N_InvOp: - arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, - Impl1(n)->resume, 2, Val0(n), resumer, failer, gen); - break; - - case N_InvProc: - if (Proc1(n)->ret_flag & DoesFail) - min_result = 0L; - else - min_result = 1L; - if (Proc1(n)->ret_flag & DoesSusp) { - max_result = UnbndSeq; - resume = 1; - } - else { - max_result = 1L; - resume = 0; - } - arg_life(n, min_result, max_result, resume, 2, Val0(n), resumer, - failer, gen); - break; - - case N_InvRec: - arg_life(n, err_conv ? 0L : 1L, 1L, 1, 2, Val0(n), resumer, failer, - gen); - break; - - case N_Limit: - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree0(n), resumer, &failer1, &gen1); - Tree1(n)->lifetime = n; - liveness(Tree1(n), failer1 == NULL ? n : failer1, &failer2, &gen2); - *failer = failer2; - *gen = gen1 | gen2; - break; - - case N_Loop: { - loop_info.prev = cur_loop; - loop_info.resumer = resumer; - loop_info.gen = 0; - loop_info.every_cntrl = 0; - loop_info.lifetime = n->lifetime; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * The body is bounded. The control clause is resumed - * by the control structure. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer2, &gen2); - loop_info.every_cntrl = 1; - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), n, &failer1, &gen1); - break; - - case REPEAT: - /* - * The body is bounded. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer1, &gen1); - break; - - case SUSPEND: - /* - * The body is bounded. The control clause is resumed - * by the control structure. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer2, &gen2); - loop_info.every_cntrl = 1; - Tree1(n)->lifetime = n; - liveness(Tree1(n), n, &failer1, &gen1); - break; - - case WHILE: - case UNTIL: - /* - * The body and the control clause are each bounded. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer1, &gen1); - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer1, &gen1); - break; - } - *failer = (resumer == NULL ? n : resumer); /* assume a loop can fail */ - *gen = cur_loop->gen; - cur_loop = cur_loop->prev; - } - break; - - case N_Next: - if (cur_loop == NULL) { - nfatal(n, "invalid context for next", NULL); - return; - } - if (cur_loop->every_cntrl) - *failer = n; - else - *failer = NULL; - *gen = 0; - break; - - case N_Not: - /* - * The expression is bounded. - */ - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - *failer = (resumer == NULL ? n : resumer); - *gen = 0; - break; - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - /* - * The expression is bounded. - */ - Tree1(n)->lifetime = n; - liveness(Tree1(n), NULL, &failer1, &gen1); - } - *failer = NULL; - *gen = 0; - break; - - case N_Scan: { - struct implement *asgn_impl; - - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - asgn_impl = optab[asgn_loc].binary; - arg_life(n, asgn_impl->min_result, asgn_impl->max_result, - asgn_impl->resume, 1, 2, resumer, failer, gen); - } - else { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); /* body */ - Tree1(n)->lifetime = n; - liveness(Tree1(n), failer2, &failer1, &gen1); /* subject */ - *failer = failer1; - *gen = gen1 | gen2; - } - } - break; - - case N_Sect: - /* - * Impl0(n) is sectioning. - */ - min_result = Impl0(n)->min_result; - max_result = Impl0(n)->max_result; - resume = Impl0(n)->resume; - if (Impl1(n) != NULL) { - /* - * Impl1(n) is plus or minus. - */ - min_result *= Impl1(n)->min_result; - max_result *= Impl1(n)->max_result; - resume |= Impl1(n)->resume; - } - arg_life(n, min_result, max_result, resume, 2, 3, resumer, failer, - gen); - break; - - case N_Slist: - /* - * expr1 is not bounded, expr0 is bounded. - */ - Tree1(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, failer, gen); - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - break; - - case N_SmplAsgn: - Tree3(n)->lifetime = n; - liveness(Tree3(n), resumer, failer, gen); /* 2nd operand */ - Tree2(n)->lifetime = n->lifetime; /* may be result of := */ - liveness(Tree2(n), *failer, &failer1, &gen1); /* 1st operand */ - break; - - case N_SmplAug: - /* - * Impl1(n) is the augmented operation. - */ - arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, - Impl1(n)->resume, 2, 2, resumer, failer, gen); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * arg_life - compute the lifetimes of an argument list. - */ -static void arg_life(n, min_result, max_result, resume, frst_arg, nargs, - resumer, failer, gen) -nodeptr n; -long min_result; /* minimum result sequence length */ -long max_result; /* maximum result sequence length */ -int resume; /* flag - resumption possible after last result */ -int frst_arg; -int nargs; -nodeptr resumer; -nodeptr *failer; -int *gen; - { - nodeptr failer1; - nodeptr failer2; - nodeptr lifetime; - int inv_fail; /* failure after operation in invoked */ - int reuse; - int gen2; - int i; - - /* - * Determine what, if anything, can resume the rightmost argument. - */ - if (resumer == NULL && min_result == 0) - failer1 = n; - else - failer1 = resumer; - if (failer1 == NULL) - inv_fail = 0; - else - inv_fail = 1; - - /* - * If the operation can be resumed, variables internal to the operation - * have and extended lifetime. - */ - if (resumer != NULL && (max_result > 1 || max_result == UnbndSeq || resume)) - n->intrnl_lftm = resumer; - else - n->intrnl_lftm = n; - - /* - * Go through the parameter list right to left, propagating resumption - * information, computing lifetimes, and determining whether anything - * can generate. - */ - lifetime = n; - reuse = 0; - *gen = 0; - for (i = frst_arg + nargs - 1; i >= frst_arg; --i) { - n->n_field[i].n_ptr->lifetime = lifetime; - n->n_field[i].n_ptr->reuse = reuse; - liveness(n->n_field[i].n_ptr, failer1, &failer2, &gen2); - if (resumer != NULL && gen2) - lifetime = resumer; - if (inv_fail && gen2) - reuse = 1; - failer1 = failer2; - *gen |= gen2; - } - *failer = failer1; - if (max_result > 1 || max_result == UnbndSeq) - *gen = 1; - } diff --git a/src/iconc/types.c b/src/iconc/types.c deleted file mode 100644 index cd3a3ef..0000000 --- a/src/iconc/types.c +++ /dev/null @@ -1,893 +0,0 @@ -/* - * 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 */ - -extern unsigned int null_bit; /* bit for null type */ -extern unsigned int str_bit; /* bit for string type */ -extern unsigned int cset_bit; /* bit for cset type */ -extern unsigned int int_bit; /* bit for integer type */ -extern unsigned int real_bit; /* bit for real type */ -extern unsigned int n_icntyp; /* number of non-variable types */ -extern unsigned int n_intrtyp; /* number of types in intermediate values */ -extern unsigned int val_mask; /* mask for non-var types in last int of type*/ -extern struct typ_info *type_array; - -/* - * free_struct_typinfo - frees a struct typinfo structure by placing - * it one a list of free structures - */ -#ifdef OptimizeType -extern struct typinfo *start_typinfo; -extern struct typinfo *high_typinfo; -extern struct typinfo *low_typinfo; -extern struct typinfo *free_typinfo; - -void free_struct_typinfo(struct typinfo *typ) { - - typ->bits = (unsigned int *)free_typinfo; - free_typinfo = typ; -} -#endif /* OptimizeType */ - -/* - * alloc_typ - allocate a compressed type structure and initializes - * the members to zero or NULL. - */ -#ifdef OptimizeType -struct typinfo *alloc_typ(n_types) -#else /* OptimizeType */ -unsigned int *alloc_typ(n_types) -#endif /* OptimizeType */ -int n_types; -{ -#ifdef OptimizeType - struct typinfo *typ; - int i; - unsigned int init = 0; - - if ((free_typinfo == NULL) && (high_typinfo == low_typinfo)) { - /* - * allocate a large block of memory used to parcel out struct typinfo - * structures from - */ - start_typinfo = (struct typinfo *)alloc(sizeof(struct typinfo) * TYPINFO_BLOCK); - high_typinfo = start_typinfo; - low_typinfo = start_typinfo + TYPINFO_BLOCK; - free_typinfo = NULL; - typ = start_typinfo; - high_typinfo++; - } - else if (free_typinfo != NULL) { - /* - * get a typinfo stucture from the list of free structures - */ - typ = free_typinfo; - free_typinfo = (struct typinfo *)free_typinfo->bits; - } - else { - /* - * get a typinfo structure from the chunk of memory allocated - * previously - */ - typ = high_typinfo; - high_typinfo++; - } - typ->packed = n_types; - if (!do_typinfer) - typ->bits = alloc_mem_typ(n_types); - else - typ->bits= NULL; - return typ; -#else /* OptimizeType */ - int n_ints; - unsigned int *typ; - int i; - unsigned int init = 0; - - n_ints = NumInts(n_types); - typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); - - /* - * Initialization: if we are doing inference, start out assuming no types. - * If we are not doing inference, assume any type. - */ - if (!do_typinfer) - init = ~init; - for (i = 0; i < n_ints; ++i) - typ[i] = init; - return typ; -#endif /* OptimizeType */ -} - -/* - * alloc_mem_typ - actually allocates a full sized bit vector. - */ -#ifdef OptimizeType -unsigned int *alloc_mem_typ(n_types) -unsigned int n_types; -{ - int n_ints; - unsigned int *typ; - int i; - unsigned int init = 0; - - n_ints = NumInts(n_types); - typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); - if (!do_typinfer) - init = ~init; - for(i=0; i < n_ints ;++i) - typ[i] = init; - return typ; -} -#endif /* OptimizeType */ - -/* - * set_typ - set a particular type bit in a type bit vector. - */ -void set_typ(type, bit) -#ifdef OptimizeType -struct typinfo *type; -#else /* OptimizeType */ -unsigned int *type; -#endif /* OptimizeType */ -unsigned int bit; -{ - unsigned int indx; - unsigned int mask; - -#ifdef OptimizeType - if (type->bits == NULL) { - if (bit == null_bit) - type->packed |= NULL_T; - else if (bit == real_bit) - type->packed |= REAL_T; - else if (bit == int_bit) - type->packed |= INT_T; - else if (bit == cset_bit) - type->packed |= CSET_T; - else if (bit == str_bit) - type->packed |= STR_T; - else { - /* - * if the bit to set is not one of the five builtin types - * then allocate a whole bit vector, copy the packed - * bits over, and set the requested bit - */ - type->bits = alloc_mem_typ(DecodeSize(type->packed)); - xfer_packed_types(type); - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] |= mask; - } - } - else { - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] |= mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type[indx] |= mask; -#endif /* OptimizeType */ -} - -/* - * clr_type - clear a particular type bit in a type bit vector. - */ -void clr_typ(type, bit) -#ifdef OptimizeType -struct typinfo *type; -#else /* OptimizeType */ -unsigned int *type; -#endif /* OptimizeType */ -unsigned int bit; -{ - unsigned int indx; - unsigned int mask; - -#ifdef OptimizeType - if (type->bits == NULL) { - /* - * can only clear one of five builtin types - */ - if (bit == null_bit) - type->packed &= ~NULL_T; - else if (bit == real_bit) - type->packed &= ~REAL_T; - else if (bit == int_bit) - type->packed &= ~INT_T; - else if (bit == cset_bit) - type->packed &= ~CSET_T; - else if (bit == str_bit) - type->packed &= ~STR_T; - } - else { - /* - * build bit mask to clear requested type in full bit vector - */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] &= ~mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type[indx] &= ~mask; -#endif /* OptimizeType */ -} - -/* - * has_type - determine if a bit vector representing types has any bits - * set that correspond to a specific type code from the data base. Also, - * if requested, clear any such bits. - */ -int has_type(typ, typcd, clear) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int typcd; -int clear; -{ - int frst_bit, last_bit; - int i; - int found; - - found = 0; - bitrange(typcd, &frst_bit, &last_bit); - for (i = frst_bit; i < last_bit; ++i) { - if (bitset(typ, i)) { - found = 1; - if (clear) - clr_typ(typ, i); - } - } - return found; -} - -/* - * other_type - determine if a bit vector representing types has any bits - * set that correspond to a type *other* than specific type code from the - * data base. - */ -int other_type(typ, typcd) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int typcd; - { - int frst_bit, last_bit; - int i; - - bitrange(typcd, &frst_bit, &last_bit); - for (i = 0; i < frst_bit; ++i) - if (bitset(typ, i)) - return 1; - for (i = last_bit; i < n_intrtyp; ++i) - if (bitset(typ, i)) - return 1; - return 0; - } - -/* - * bitrange - determine the range of bit positions in a type bit vector - * that correspond to a type code from the data base. - */ -void bitrange(typcd, frst_bit, last_bit) -int typcd; -int *frst_bit; -int *last_bit; - { - if (typcd == TypVar) { - /* - * All variable types. - */ - *frst_bit = n_icntyp; - *last_bit = n_intrtyp; - } - else { - *frst_bit = type_array[typcd].frst_bit; - *last_bit = *frst_bit + type_array[typcd].num_bits; - } - } - -/* - * typcd_bits - set the bits of a bit vector corresponding to a type - * code from the data base. - */ -void typcd_bits(typcd, typ) -int typcd; -struct type *typ; - { - int frst_bit; - int last_bit; - int i; - - if (typcd == TypEmpty) - return; /* Do nothing. */ - - if (typcd == TypAny) { - /* - * Set bits corresponding to first-class types. - */ -#ifdef OptimizeType - /* - * allocate a full bit vector and copy over packed types first - */ - if (typ->bits->bits == NULL) { - typ->bits->bits = alloc_mem_typ(DecodeSize(typ->bits->packed)); - xfer_packed_types(typ->bits); - } - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) - typ->bits->bits[i] |= ~(unsigned int)0; - typ->bits->bits[i] |= val_mask; -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) - typ->bits[i] |= ~(unsigned int)0; - typ->bits[i] |= val_mask; -#endif /* OptimizeType */ - return; - } - - bitrange(typcd, &frst_bit, &last_bit); -#ifdef OptimizeType - if (last_bit > DecodeSize(typ->bits->packed)) /* bad abstract type computation */ - return; -#endif /* OptimizeType */ - for (i = frst_bit; i < last_bit; ++i) - set_typ(typ->bits, i); - } - -/* - * bitset - determine if a specific bit in a bit vector is set. - */ -int bitset(typ, bit) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int bit; -{ - int mask; - int indx; - -#ifdef OptimizeType - if (typ->bits == NULL) { - /* - * check to see if the requested bit is set in the packed representation - * if the requested bit is not one of the five builtins then the - * lookup fails no matter what - */ - if (bit == null_bit) - return (typ->packed & NULL_T); - else if (bit == real_bit) - return (typ->packed & REAL_T); - else if (bit == int_bit) - return (typ->packed & INT_T); - else if (bit == cset_bit) - return (typ->packed & CSET_T); - else if (bit == str_bit) - return (typ->packed & STR_T); - else - return 0; - } - else { - /* - * create a mask to check to see if the requested type bit is - * set on - */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - return typ->bits[indx] & mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - return typ[indx] & mask; -#endif /* OptimizeType */ -} - -/* - * is_empty - determine if a type bit vector is empty. - */ -int is_empty(typ) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -{ - int i; - -#ifdef OptimizeType - if (typ->bits == NULL) { - /* - * if any bits are set on then the vector is not empty - */ - if (DecodePacked(typ->packed)) - return 0; - else - return 1; - } - else { - for (i = 0; i < NumInts(n_intrtyp); ++i) { - if (typ->bits[i] != 0) - return 0; - } - return 1; - } -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_intrtyp); ++i) { - if (typ[i] != 0) - return 0; - } - return 1; -#endif /* OptimizeType */ -} - -/* - * xfer_packed_types - transfers the packed type representation - * to a full length bit vector representation in the same - * struct typinfo structure. - */ -#ifdef OptimizeType -void xfer_packed_types(type) -struct typinfo *type; -{ - unsigned int indx, mask; - - /* - * for each IF statement built a mask to set each of the five builtins - * if they are present in the packed representation - */ - if (type->packed & NULL_T) { - indx = null_bit / IntBits; - mask = 1; - mask <<= null_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & REAL_T) { - indx = real_bit / IntBits; - mask = 1; - mask <<= real_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & INT_T) { - indx = int_bit / IntBits; - mask = 1; - mask <<= int_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & CSET_T) { - indx = cset_bit / IntBits; - mask = 1; - mask <<= cset_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & STR_T) { - indx = str_bit / IntBits; - mask = 1; - mask <<= str_bit % IntBits; - type->bits[indx] |= mask; - } -} - -/* - * xfer_packed_to_bits - sets those type bits from the src typinfo structure - * to the dest typinfo structure AND the src is a packed representation - * while the dest is a bit vector. Returns the number of new bits that - * were set in the destination. - */ -int xfer_packed_to_bits(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, mask, old, rnsize; - int changes[5] = {-1,-1,-1,-1,-1}; - int ix, membr = 0, i; - - ix = 0; - rnsize = NumInts(nsize); - /* - * for each possible type set in the packed vector, create a mask - * and apply it to the dest. check to see if there was actually - * a change in the dest vector. - */ - if (src->packed & NULL_T) { - indx = null_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= null_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - /* - * checks to see if the bit just set happens to be in the - * same word as any other of the five builtins. if they - * are then we only want to count this as one change - */ - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & REAL_T) { - indx = real_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= real_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & INT_T) { - indx = int_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= int_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & CSET_T) { - indx = cset_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= cset_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & STR_T) { - indx = str_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= str_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - return ix; -} - -/* - * and_bits_to_packed - performs a bitwise AND of two typinfo structures - * taking into account of packed or full bit representation. - */ -void and_bits_to_packed(src, dest, size) -struct typinfo *src; -struct typinfo *dest; -int size; -{ - unsigned int indx, mask, val, destsz; - int i; - - if ((src->bits == NULL) && (dest->bits == NULL)) - /* Both are packed */ - dest->packed &= (0xFF000000 | src->packed); - else if ((src->bits == NULL) && (dest->bits != NULL)) { - /* - * built a bit mask for each type in the src and AND it too - * the bit vector in dest - */ - for (i=0; i < NumInts(size) ;i++) { - val = get_bit_vector(src,i); - dest->bits[i] &= val; - } - } - else if ((src->bits != NULL) && (dest->bits == NULL)) { - /* - * because an AND is being performed only those bits in the dest - * have the possibility of remaining set (i.e. five builtins) - * therefore if the bit is set in the packed check to see if - * it is also set in the full vector, if so then set it in the - * resulting vector, otherwise don't - */ - destsz = DecodeSize(dest->packed); - mask = 1; val = 0; - if (dest->packed & NULL_T) { - mask <<= (null_bit % IntBits); - if (src->bits[(null_bit/IntBits)] & mask) - val |= NULL_T; - } - mask = 1; - if (dest->packed & REAL_T) { - mask <<= (real_bit % IntBits); - if (src->bits[(real_bit/IntBits)] & mask) - val |= REAL_T; - } - mask = 1; - if (dest->packed & INT_T) { - mask <<= (int_bit % IntBits); - if (src->bits[(int_bit/IntBits)] & mask) - val |= INT_T; - } - mask = 1; - if (dest->packed & CSET_T) { - mask <<= (cset_bit % IntBits); - if (src->bits[(cset_bit/IntBits)] & mask) - val |= CSET_T; - } - mask = 1; - if (dest->packed & STR_T) { - mask <<= (str_bit % IntBits); - if (src->bits[(str_bit/IntBits)] & mask) - val |= STR_T; - } - dest->packed = val | destsz; - } - else - for (i=0; i < NumInts(size) ;i++) - dest->bits[i] &= src->bits[i]; -} - - -/* - * get_bit_vector - returns a bit mask from the selected word of a bit - * vector. e.g. if pos == 2, then check to see if any of the five - * builtins fall in the second word of a normal bit vector, if so - * create a bit mask with those types that fall in that word. - */ - -unsigned int get_bit_vector(src, pos) -struct typinfo *src; -int pos; -{ - unsigned int val = 0, mask; - - val = 0; - if ((src->packed & NULL_T) && ((null_bit / IntBits) == pos)) { - mask = 1; - mask <<= null_bit % IntBits; - val |= mask; - } - if ((src->packed & REAL_T) && ((real_bit / IntBits) == pos)) { - mask = 1; - mask <<= real_bit % IntBits; - val |= mask; - } - if ((src->packed & INT_T) && ((int_bit / IntBits) == pos)) { - mask = 1; - mask <<= int_bit % IntBits; - val |= mask; - } - if ((src->packed & CSET_T) && ((cset_bit / IntBits) == pos)) { - mask = 1; - mask <<= cset_bit % IntBits; - val |= mask; - } - if ((src->packed & STR_T) && ((str_bit / IntBits) == pos)) { - mask = 1; - mask <<= str_bit % IntBits; - val |= mask; - } - return val; -} - - -/* - * clr_packed - clears all bits within the nsize-th word for a packed - * representation. - */ - -void clr_packed(src, nsize) -struct typinfo *src; -int nsize; -{ - unsigned int rnsize; - - rnsize = NumInts(nsize); - if ((null_bit / IntBits) < rnsize) - src->packed &= ~NULL_T; - if ((real_bit / IntBits) < rnsize) - src->packed &= ~REAL_T; - if ((int_bit / IntBits) < rnsize) - src->packed &= ~INT_T; - if ((cset_bit / IntBits) < rnsize) - src->packed &= ~CSET_T; - if ((str_bit / IntBits) < rnsize) - src->packed &= ~STR_T; -} - -/* - * cpy_packed_to_packed - copies the packed bits from one bit vector - * to another. - */ - -void cpy_packed_to_packed(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, rnsize; - - rnsize = NumInts(nsize); - /* - * for each of the possible builtin types, check to see if the bit is - * set in the src and if present set it in the dest. - */ - dest->packed = DecodeSize(dest->packed); - if (src->packed & NULL_T) { - indx = null_bit / IntBits; - if (indx < rnsize) - dest->packed |= NULL_T; - } - if (src->packed & REAL_T) { - indx = real_bit / IntBits; - if (indx < rnsize) - dest->packed |= REAL_T; - } - if (src->packed & INT_T) { - indx = int_bit / IntBits; - if (indx < rnsize) - dest->packed |= INT_T; - } - if (src->packed & CSET_T) { - indx = cset_bit / IntBits; - if (indx < rnsize) - dest->packed |= CSET_T; - } - if (src->packed & STR_T) { - indx = str_bit / IntBits; - if (indx < rnsize) - dest->packed |= STR_T; - } -} - - -/* - * mrg_packed_to_packed - merges the packed type bits of a src and dest - * bit vector. - */ -int mrg_packed_to_packed(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, rnsize; - int changes[5] = {-1,-1,-1,-1,-1}; - int ix = 0, membr = 0, i; - - rnsize = NumInts(nsize); - /* - * for each of the five possible types in the src, check to see if it - * is set in the src and not set in the dest. if so then set it in - * the dest vector. - */ - if ((src->packed & NULL_T) && !(dest->packed & NULL_T)) { - indx = null_bit / IntBits; - if (indx < rnsize) { - dest->packed |= NULL_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & REAL_T) && !(dest->packed & REAL_T)) { - indx = real_bit / IntBits; - if (indx < rnsize) { - dest->packed |= REAL_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & INT_T) && !(dest->packed & INT_T)){ - indx = int_bit / IntBits; - if (indx < rnsize) { - dest->packed |= INT_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & CSET_T) && !(dest->packed & CSET_T)) { - indx = cset_bit / IntBits; - if (indx < rnsize) { - dest->packed |= CSET_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & STR_T) && !(dest->packed & STR_T)) { - indx = str_bit / IntBits; - if (indx < rnsize) { - dest->packed |= STR_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - return ix; -} -#endif /* OptimizeType */ diff --git a/src/iconc/typinfer.c b/src/iconc/typinfer.c deleted file mode 100644 index 8a96e23..0000000 --- a/src/iconc/typinfer.c +++ /dev/null @@ -1,5189 +0,0 @@ -/* - * 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; - } |