void gen_case(Tuple case_table, Tuple bodies_arg, Node others_body,int mem_unit) /*;gen_case*/ { /* Generates the code to select the right alternative and the bodies */ int index, lower_bound, i, n; Node body_node; Symbol end_case, jumpsym; Tuple jump_table, tup; Fortup ft1; Tuple bodies; bodies = tup_copy(bodies_arg); /* copy needed since used in tup_fromb */ end_case = new_unique_name("end_case"); gen_k(I_CASE, mem_unit); /* The SETL jump_table map is represented as a 'tuple map' in C, with * procedures jump_table_get() and jump_table_put() (defined below) used * to retrieve and insert values in this map. */ jump_table = tup_new(0); jump_table = jump_table_put(jump_table, 0, new_unique_name("case")); gen_ks(I_CASE_TABLE, tup_size(case_table), jump_table_get(jump_table, 0) ); FORTUP(tup = (Tuple), case_table, ft1); lower_bound = (int) tup[1]; index = (int) tup[2]; jumpsym = jump_table_get(jump_table, index); if (jumpsym == (Symbol)0) { /* if no entry yet, make new one */ jumpsym = new_unique_name("case"); jump_table = jump_table_put(jump_table, index, jumpsym); } gen_ks(I_CASE_TABLE, lower_bound, jumpsym); ENDFORTUP(ft1); index = 0; bodies = tup_exp(bodies, tup_size(bodies) + 1); n = tup_size(bodies); for (i = n; i > 1; i--) { bodies[i] = bodies[i-1]; } bodies[1] = (char *) others_body; while (tup_size(bodies) != 0) { body_node = (Node) tup_fromb(bodies); gen_s(I_LABEL, jump_table_get(jump_table, index)); compile(body_node); if (tup_size(bodies) != 0) { /* to avoid useless "jump $+1" */ gen_s(I_JUMP, end_case ); } index += 1; } gen_s(I_LABEL, end_case); tup_free(bodies); }
Symbol getsymptr(int seq, int unit) /*;getsymptr*/ { /* here to convert seq and unit to pointer to symbol. * we require that the symbol has already been allocated */ Tuple symptr; Symbol sym; int items; /* here to convert seq and unit to pointer to symbol. * we require that the symbol has already been allocated */ /* TBSL: need to get SEQPTR table for unit, and return address */ if (unit == 0 ) { if (seq == 0) return (Symbol)0; if (seq>0 && seq <= tup_size(init_symbols)) { sym = (Symbol) init_symbols[seq]; return sym; } else chaos("unit 0 error getsymptr"); } if (unit <= unit_numbers) { struct unit *pUnit = pUnits[unit]; symptr = (Tuple) pUnit->aisInfo.symbols; if (symptr == (Tuple)0) { items = pUnit->aisInfo.numberSymbols; symptr = tup_new(items); pUnit->aisInfo.symbols = (char *) symptr; } if (seq <= tup_size(symptr)) { sym = (Symbol) symptr[seq]; if (sym == (Symbol)0) { sym = sym_new_noseq(na_void); symptr[seq] = (char *) sym; S_SEQ(sym) = seq; S_UNIT(sym) = unit; } #ifdef DEBUG if (trapss>0 && seq == trapss && unit == trapsu) traps(sym); #endif return sym; /* return newly allocated symbol */ } else chaos("getsymptr error"); return (Symbol) 0; } chaos("getsymptr unable to find node"); return (Symbol) 0; }
void predef_exceptions(Tuple tup) /*;predef_exceptions*/ { /* This procedure writes out the SLOTS information. * This variant of put_slot writes out definitions of predefined exceptions * when compiling predef, in a form suitable for inclusion as the body * of init_predef_exceptions (cf. init.c). */ int i, n; Slot slot; n = tup_size(tup); printf("exception slots\n"); /* first five exceptions defined in standard */ for (i = 6; i <= n; i++) { slot = (Slot) tup[i]; if (slot == (Slot)0) { if (compiling_predef) chaos("undefined slot compiling predef"); } else { printf(" init_predef_exception(%d, %d, %d, \"%s\");\n", slot->slot_seq, slot->slot_unit, slot->slot_number, slot->slot_name); } } }
static void put_slot(IFILE *file, Tuple tup) /*;put_slot*/ { /* This procedure writes out the SLOTS information. These are maps from * symbols to unit names. The interpreter needs only to know the names * of the symbols so we write their names if available, else * an empty string. */ int i, n; Slot slot; n = tup_size(tup); putnum(file, "slot-entries", n); for (i = 1; i <= n; i++) { slot = (Slot) tup[i]; if (slot == (Slot)0) { if (compiling_predef) chaos("undefined slot compiling predef"); putnum(file, "slot-exists", 0); } else { putnum(file, "slot-exists", 1); putnum(file, "slot-seq", slot->slot_seq); putnum(file, "slot-unit", slot->slot_unit); putnum(file, "slot-number", slot->slot_number); putstr(file, "slot-name", slot->slot_name); } } }
term_t bif_spawn0_1(term_t F, process_t *ctx) { process_t *proc; term_t mod, fun, args = nil; term_t cons = nil; term_t fridge; int i, nfree; if (!is_fun(F)) return A_BADARG; fridge = fun_fridge(F); nfree = int_value2(tup_size(fridge)); if (int_value2(fun_arity(F)) != nfree) return A_BADARG; for (i = 0; i < nfree; i++) lst_add(args, cons, tup_elts(fridge)[i], proc_gc_pool(ctx)); mod = fun_amod(F); fun = fun_afun(F); proc = proc_spawn(proc_code_base(ctx), proc_atoms(ctx), mod, fun, args); if (proc == 0) return A_BADARG; result(proc_pid(proc, proc_gc_pool(ctx))); return AI_OK; }
Tuple sym_save(Tuple m, Symbol sym, char unit_typ) /*;sym_save*/ { /* we maintain the SETL symbtab_map map from symbol table pointers to * symbol table entries as a tuple of symbol table pointers. From * each symbol table pointer we can obtain the symbol table entries * contained in the SETL map. */ int i, n, seq, unit, exists; seq = S_SEQ(sym); unit = S_UNIT(sym); /* save only if in current unit */ if (unit != unit_number_now && unit_typ == 'u') return m; n = tup_size(m); exists = FALSE; for (i = 1; i <= n; i++) { if (S_SEQ((Symbol) m[i]) == seq && S_UNIT((Symbol) m[i]) == unit) { exists = TRUE; break; } } if (!exists) { /* expand and allocate new symbol entry */ m = (Tuple) tup_exp(m, (unsigned) n+1); i = n + 1; m[i] = (char *) sym_new_noseq(na_void); } sym_copy((Symbol) m[i], sym); return m; }
static Node remove_discr_ref(Node expr_node, Node object) /*;remove_discr_ref*/ { /* Within the record definition, a discriminant reference can be replaced * by a selected component for the instance of the record being built. */ Node e; int i, nk; Tuple tup; if (N_KIND(expr_node) == as_discr_ref) return new_selector_node(object, N_UNQ(expr_node)); else if (N_KIND(expr_node) == as_opt) return OPT_NODE; else { e = copy_node(expr_node); nk = N_KIND(e); if (N_AST1_DEFINED(nk) && N_AST1(e)!=(Node)0) N_AST1(e) = remove_discr_ref(N_AST1(e), object); if (N_AST2_DEFINED(nk) && N_AST2(e)!=(Node)0) N_AST2(e) = remove_discr_ref(N_AST2(e), object); if (N_AST3_DEFINED(nk) && N_AST3(e)!=(Node)0) N_AST3(e) = remove_discr_ref(N_AST3(e), object); if (N_AST4_DEFINED(nk) && N_AST4(e)!=(Node)0) N_AST4(e) = remove_discr_ref(N_AST4(e), object); } /*N_LIST(e) = [remove_discr_ref(n, object): n in N_LIST(e)];*/ if (N_LIST_DEFINED(nk) && N_LIST(e)!=(Tuple)0) { tup = N_LIST(e); for (i = 1; i <= tup_size(tup); i++) tup[i] = (char *) remove_discr_ref((Node) tup[i], object); } return e; }
static Node initialization_proc(Symbol proc_name, Symbol type_name, Tuple formals, Tuple stmts) /*;initialization_proc*/ { /* Build procedure with given formals and statement list. */ Node proc_node; int i, n; Tuple tup; NATURE (proc_name) = na_procedure; n = tup_size(formals); tup = tup_new(n); for (i = 1; i <= n; i++) tup[i] = (char *) N_UNQ((Node)formals[i]); SIGNATURE(proc_name) = tup; generate_object(proc_name); /* * Create as_subprogram_tr node with statements node as N_AST1 * instead of N_AST3 as it is with as_subprogram. */ proc_node = new_node(as_subprogram_tr); N_UNQ(proc_node) = proc_name; N_AST1(proc_node) = new_statements_node(stmts); N_AST2(proc_node) = OPT_NODE; N_AST4(proc_node) = OPT_NODE; return proc_node; }
int stub_retrieve(char *name) /*;stub_retrieve*/ { char *fname; Tuple stubtup, tup; int si, n, i; /* * Reads, if necessary, information from the file in which the stub * 'name' was declared. */ #ifdef TBSN if (putdebug) TO_ERRFILE(strjoin("STUB_RETRIEVE ", name)); #endif fname = lib_stub_get(name); if (fname == NULL) return FALSE; if (!streq(fname, AISFILENAME)) { si = stub_numbered(name); stubtup = (Tuple) stub_info[si]; tup = (Tuple) stubtup[4]; n = tup_size(tup); for (i = 1;i <= n; i++) { retrieve(pUnits[(int)tup[i]]->name); } if (!read_stub(fname, name, "st1")) return FALSE; } return TRUE; }
int is_discr_ref(Node expr_node) /*;is_discr_ref*/ { int n, i, nk; Node node; Tuple tup; if (N_KIND(expr_node) == as_discr_ref) return TRUE; nk = N_KIND(expr_node); node = N_AST1(expr_node); if (node != (Node)0 && is_discr_ref(node)) return TRUE; node = N_AST2_DEFINED(nk) ? N_AST2(expr_node) : (Node) 0; if (node != (Node)0 && is_discr_ref(node)) return TRUE; node = N_AST3_DEFINED(nk) ? N_AST3(expr_node) : (Node) 0; if (node != (Node)0 && is_discr_ref(node)) return TRUE; node = N_AST4_DEFINED(nk) ? N_AST4(expr_node) : (Node) 0; if (node != (Node)0 && is_discr_ref(node)) return TRUE; tup = N_LIST_DEFINED(nk) ? N_LIST(expr_node) : (Tuple) 0; if (tup==(Tuple)0) return FALSE; n = tup_size(tup); for (i = 1; i <= n; i++) if (is_discr_ref((Node) tup[i])) return TRUE; return FALSE; }
void symtab_restore(Tuple s_info) /*;symtab_restore*/ { int i, n; n = tup_size(s_info); for (i = 1; i <= n; i++) sym_restore((Symbol)s_info[i]); }
void put_cde_slots(IFILE *file, int ifaxq) /*;put_cde_slots*/ { long dpos; dpos = iftell(file); /* get current position */ putnum(file, "n-code_slots", tup_size(CODE_SLOTS)); putnum(file, "n-data-slots", tup_size(DATA_SLOTS)); putnum(file, "n-exception-slots", tup_size(EXCEPTION_SLOTS)); put_slot(file, CODE_SLOTS); put_slot(file, DATA_SLOTS); put_slot(file, EXCEPTION_SLOTS); /* now replace word at start of file with long giving offset to *start of information just written. */ file->fh_slots = dpos; ifclose(file); }
int in_aisunits_read(char *f) /*;in_aisunits_read*/ { int i, n; n = tup_size(aisunits_read); for (i = 1; i <= n; i++) if (streq(aisunits_read[i], f)) return TRUE; return FALSE; }
int stub_numbered(char *name) /*;stub_numbered*/ { int i, n; n = tup_size(lib_stub); for (i = 1; i <= n; i++) if (streq(lib_stub[i], name)) return i; return 0; }
static Symbol jump_table_get(Tuple jtab, int ndx) /*;jump_table_get()*/ { int i, n; n = tup_size(jtab); for (i = 1; i <= n; i += 2) { if ((int) jtab[i] == ndx) return (Symbol) jtab[i+1]; } return (Symbol)0; }
int compute_index(Tuple subscript_list_arg, Tuple index_list_arg) /*;compute_index*/ { /* Evaluate mono-dimensional offset from the given subscripts */ Node subscript, low_node, high_node; Symbol indx_type; int ndex, delta; /* use ndex for index, index is builtin */ int sb_val, lw_val, hg_val; Tuple tup; Const lw, hg, sb; Tuple subscript_list, index_list; /* copy arguments - needed since they are used desctructively in * tup_frome calls below */ subscript_list = tup_copy(subscript_list_arg); index_list = tup_copy(index_list_arg); ndex = 0; delta = 1; while (tup_size(index_list)) { indx_type = (Symbol) tup_frome(index_list); subscript = (Node) tup_frome(subscript_list); tup = SIGNATURE(indx_type); low_node = (Node) tup[2]; high_node = (Node) tup[3]; lw = get_ivalue(low_node); hg = get_ivalue(high_node); sb = get_ivalue(subscript); if (!( lw->const_kind != CONST_OM && hg->const_kind != CONST_OM && sb->const_kind != CONST_OM)) { tup_free(subscript_list); tup_free(index_list); return -1; } sb_val = INTV(sb); lw_val = INTV(lw); hg_val = INTV(hg); if (sb_val<lw_val || sb_val>hg_val) { /* here, raise constraint_error */ gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error); gen(I_RAISE); tup_free(subscript_list); tup_free(index_list); return -1; } ndex += delta*(sb_val-lw_val); delta *= (hg_val-lw_val+1); } tup_free(subscript_list); tup_free(index_list); return ndex; }
static Tuple sort_case(Tuple tuple_to_sort) /*;sort_case*/ { /* * Takes a set of case triples, and returns a tuple of those triple, * sorted by ascending lower bounds. Quick sort algorithm. * (sorry, this is not efficient, but was very easy to write) */ qsort((char *) &tuple_to_sort[1], tup_size(tuple_to_sort), sizeof (char *), (int (*)(const void *, const void *))tcompar); return tuple_to_sort; }
void check_choices(Node alt_node, char *source) /*;check_choices*/ { Tuple choice_list, others_indices = tup_new(0); Node tmp_node, tmp_node2, last_alt = (Node) 0; Fortup ft1, ft2; int choice_flag = 0; FORTUP(tmp_node = (Node), N_LIST(alt_node), ft1); if (N_KIND(tmp_node) != as_pragma) { choice_list = N_LIST(N_AST1(tmp_node)); if (tup_size(choice_list) > 1) { FORTUP(tmp_node2 = (Node), choice_list, ft2); if (N_KIND(tmp_node2) == as_others || N_KIND(tmp_node2) == as_others_choice) { char msg[90]; sprintf(msg,"The choice OTHERS must appear alone in %s", source); syntax_err(SPAN(tmp_node2),msg); choice_flag = 1; break; } ENDFORTUP(ft2); } if (!choice_flag) { if (N_KIND((Node)choice_list[1]) == as_others || N_KIND((Node)choice_list[1]) == as_others_choice) others_indices = tup_with(others_indices, (char *)tmp_node); } else choice_flag = 0; last_alt = tmp_node; } ENDFORTUP(ft1); FORTUP(tmp_node = (Node), others_indices, ft1); { Node choice; char msg[90]; if (tmp_node == last_alt) continue; choice = (Node)N_LIST(N_AST1(tmp_node))[1]; sprintf(msg,"The choice OTHERS must appear last in %s",source); syntax_err(SPAN(choice),msg); } ENDFORTUP(ft1); /* if (others_indices != (struct two_pool *)0 ) TFREE(others_indices->link,others_indices); */ }
static Const eval_lit_map(Symbol obj) /*;eval_lit_map*/ { Symbol typ; Tuple tup; int i; typ = TYPE_OF(obj); tup = (Tuple) literal_map(typ); for (i = 1; i <= tup_size(tup); i += 2) { if (ORIG_NAME(obj) == (char *)0) continue; if (streq(tup[i], ORIG_NAME(obj))) return int_const((int)tup[i+1]); } return const_new(CONST_OM); /*(return literal_map(TYPE_OF(obj))(original_name(obj));*/ }
static Span retrieve_l_span(Node node) /*;retrieve_l_span */ { int i,listsize; unsigned int nkind; Span lspan = (Span)0 ; if (node == (Node)0 || node == OPT_NODE) return (Span)0; nkind = N_KIND(node); if (is_terminal_node(nkind)) return make_span(N_SPAN0(node),N_SPAN1(node)); if (nkind == as_exit) return retrieve_l_span(N_AST4(node)); if (nkind == as_return) return retrieve_l_span(N_AST4(node)); if (nkind == as_raise) return retrieve_l_span(N_AST2(node)); if (nkind == as_others_choice) return retrieve_l_span(N_AST3(node)); if (nkind == as_op) /* N_AST1 is the operator. Really want first argument! */ if ((lspan=retrieve_l_span(N_AST2(node))) != (Span)0) return lspan; if (nkind == as_attribute) /* N_AST1 is the attribute. Really want first argument! */ if ((lspan=retrieve_l_span(N_AST2(node))) != (Span)0) return lspan; if (N_LIST_DEFINED(nkind)) { listsize = tup_size(N_LIST(node)); if (listsize == 0) return (Span)0; for (i=1; i <= listsize; i++) { lspan = retrieve_l_span((Node)N_LIST(node)[i]); if (lspan != (Span)0) return lspan; } return (Span)0; } if (N_AST1_DEFINED(nkind)) lspan = retrieve_l_span(N_AST1(node)); if (N_AST2_DEFINED(nkind) && lspan == (Span)0 ) lspan = retrieve_l_span(N_AST2(node)); if (N_AST3_DEFINED(nkind) && lspan == (Span)0 ) lspan = retrieve_l_span(N_AST3(node)); if (N_AST4_DEFINED(nkind) && lspan == (Span)0 ) lspan = retrieve_l_span(N_AST4(node)); return lspan; }
static Tuple jump_table_put(Tuple jtab, int ndx, Symbol sym) /*;jump_table_put*/ { /* set value of jump_table jtab for int ndx to be sym. jtab is a map * kept as tuple. */ int i, n; n = tup_size(jtab); for (i = 1; i <= n; i += 2) { if ((int) jtab[i] == ndx) { jtab[i+1] = (char *) sym; return jtab; } } /* here to add new entry */ jtab = tup_exp(jtab, n+2); jtab[n+1] = (char *) ndx; jtab[n+2] = (char *) sym; return jtab; }
int stub_number(char *name) /*;stub_number*/ { int i, n; Tuple stubtup; n = tup_size(lib_stub); for (i = 1; i <= n; i++) if (streq(lib_stub[i], name)) return i; lib_stub = tup_exp(lib_stub, (unsigned) n+1); lib_stub[n+1] = strjoin(name, ""); stub_info = tup_exp(stub_info, (unsigned) n+1); stubtup = tup_new(5); /* * [1] == stub filename * [2] == Stubenv * [3] == current level * [4] == tuple of stub node units * [5] == stub parent */ stubtup[4] = (char *) tup_new(0); stub_info[n+1] = (char *) stubtup; return n+1; }
static Const const_fold(Node node) /*;const_fold*/ { /* This recursive procedure evaluates expressions, when static. * If node is static, its actual value is returned, and the node is * modified to be an ivalue. Otherwise const_fold returns om, and node * is untouched. If the static evaluation shows that the expression * would raise an exception, a ['raise' exception] value is produced * and placed on the tree. */ Fortup ft1; Node expn, index_list, index, discr_range; Const result; Node opn; Node n2, op_range; Symbol sym, op_type; /* */ #define is_simple_value(t) ((t)->const_kind == CONST_INT \ || (t)->const_kind == CONST_UINT || (t)->const_kind == CONST_REAL) if (cdebug2 > 3) { } switch (N_KIND(node)) { case(as_simple_name): result = const_val(N_UNQ(node)); break; case(as_ivalue): result = (Const) N_VAL(node); break; case(as_int_literal): /* TBSL: assuming int literal already converted check this Const*/ result = (Const) N_VAL(node); break; case(as_real_literal): /*TBSL: assuming real literal already converted */ result = (Const) N_VAL(node); break; case(as_string_ivalue): /* Will be static if required type has static low bound.*/ /* indx := index_type(N_TYPE(node)); * [-, lo_exp, -] := signature(indx); * * Move this test to the expander, once format of aggregates is known. * if is_static_expr(lo_exp) then * lob := N_VAL(lo_exp); * av := [v : [-, v] in comp_list]; * result := check_null_aggregate(av, lob, indices, node); * result := ['array_ivalue', [v: [-, v] in comp_list], * lob, lob + #comp_list - 1]; * else */ result = const_new(CONST_OM); /* end if; */ break; case(as_character_literal): result = const_new(CONST_STR); break; case(as_un_op): result = fold_unop(node); break; case(as_in): opn = N_AST1(node); op_range = N_AST2(node); result = eval_qual_range(opn, N_TYPE(op_range)); if (is_const_constraint_error(result)) result = test_expr(FALSE); else if (!is_const_om(result)) result = test_expr(TRUE); break; case(as_notin): opn = N_AST1(node); n2 = N_AST2(node); result = eval_qual_range(opn, N_TYPE(n2)); if (is_const_constraint_error(result)) result = test_expr(TRUE); else if (!is_const_constraint_error(result)) result = test_expr(FALSE); break; case(as_op): result = fold_op(node); break; case(as_call): { int i; Tuple arg_list; Const arg; opn = N_AST1(node); result = const_new(CONST_OM); /* in general not static */ arg_list = N_LIST(N_AST2(node)); /* but can fold actuals. */ for (i = 1; i <= tup_size(arg_list); i++) arg = const_fold((Node)arg_list[i]); if (N_KIND(opn) == as_simple_name) { sym = ALIAS(N_UNQ(opn)); if (sym != (Symbol)0 && is_literal(sym)) /* replace call by actual value of literal */ result = eval_lit_map(sym); } } break; case(as_parenthesis): /* If the parenthesised expression is evaluable, return * its value. Otherwise leave it parenthesised. */ opn = N_AST1(node); result = const_fold(opn); break; case(as_qual_range): opn = N_AST1(node); op_type = N_TYPE(node); result = eval_qual_range(opn, op_type); if (is_const_constraint_error(result)) { create_raise(node, symbol_constraint_error); result = const_new(CONST_OM); } break; case(as_qual_index): eval_static(N_AST1(node)); result = const_new(CONST_OM); break; case(as_attribute): case(as_range_attribute): /* use separate procedure for C */ result = fold_attr(node); break; case(as_qualify): if (fold_context) result = const_fold(N_AST2(node)); else /* in the context of a conformance check, keep qualification.*/ result = const_new(CONST_OM); break; /* Type conversion: * /TBSL/ These conversions are not properly checked! */ case(as_convert): /* use separate procedure for C */ result = fold_convert(node); break; case(as_array_aggregate): /* This is treated in the expander.*/ result = const_new(CONST_OM); break; case(as_record_aggregate): result = const_new(CONST_OM); break; case(as_selector): /*TBSL Case for discriminants needed */ expn = N_AST1(node); eval_static(expn); return const_new(CONST_OM); case(as_slice): expn = N_AST1(node); discr_range = N_AST2(node); eval_static(expn); eval_static(discr_range); return const_new(CONST_OM); case(as_row): /* Not folded for now.*/ /* p1 := check_const_val(op1); * if is_value(op1) then * result := ['array_ivalue', [op1(2)], 1, 1]; * else */ return const_new(CONST_OM); case(as_index): expn = N_AST1(node); index_list = N_AST2(node); eval_static(expn); FORTUP(index = (Node), N_LIST(index_list), ft1) eval_static(index); ENDFORTUP(ft1); return const_new(CONST_OM); default: result = const_new(CONST_OM); } if (result->const_kind != CONST_OM) insert_and_prune(node, result); return result; }
void process_pragma(Node node) /*;process_pragma*/ { /* This arbitrarily extensible procedure processes pragma declarations. * The name of the pragma determines the way in which the args are * processed. If no meaning has been attached to a pragma name, the user * is notified, and the pragma is ignored. */ Node id_node, arg_list_node, arg_node, i_node, e_node, arg1, arg2; Node priority, marker_node, type_node; char *id; Tuple args, arg_list; Symbol proc_name, p_type, id_sym; int nat, exists, newnat; Fortup ft1; Forset fs1; if (cdebug2 > 3) TO_ERRFILE("AT PROC : process_pragma(node) "); id_node = N_AST1(node); arg_list_node = N_AST2(node); id = N_VAL(id_node); arg_list = N_LIST(arg_list_node); /*aix := []; */ /* Most pragmas generate no code.*/ if (is_empty(arg_list)) { /* pragma with no parameters */ errmsg_str("Format error in pragma", id, "Appendices B, F", node); } else { /* Process list of arguments. */ args = tup_new(0); FORTUP(arg_node = (Node), arg_list, ft1); i_node = N_AST1(arg_node); e_node = N_AST2(arg_node); adasem(e_node); /* For now, disregard named associations.*/ args = tup_with(args, (char *) e_node); ENDFORTUP(ft1); if (streq(id, "IO_INTERFACE") ) { /* Current interface to predefined procedures (e.g. text_io). * The pragma makes up the body of a predefined procedure. * This body is formatted into a single tuple : * * [ io_subprogram, marker , name1, name2...] * * where the marker is the second argument of the pragma. This * marker is used as an internal switch by the tio interpreter. * The remaining components of the tuple are the unique names of * the formal parameters of the procedure.The pragma must follow * immediately the procedure spec to which it applies. The pragma * then supplies the body for it. */ arg1 = (Node) args[1]; /* The first argument in the pragma list is a string in the case * of overloadable operators used in the CALENDAR package. */ if (N_KIND(arg1) == as_string_literal) id = N_VAL(arg1); else id = N_VAL(N_AST1(arg1)); /* assert exists proc_name in overloads(declared(scope_name)(id)) * | rmatch(nature(proc_name), '_spec') /= om; */ exists = FALSE; FORSET(proc_name = (Symbol), OVERLOADS(dcl_get(DECLARED(scope_name), id)), fs1); nat = NATURE(proc_name); if (nat == na_procedure_spec || nat == na_function_spec || nat == na_task_obj_spec || nat == na_generic_procedure_spec || nat == na_generic_function_spec || nat == na_generic_package_spec) { exists = TRUE; break; } ENDFORSET(fs1); if (exists == FALSE) warning("subprogram given in pragma not found", node); if (nat == na_procedure_spec ) newnat = na_procedure; else if (nat == na_function_spec) newnat = na_function; else warning("argument to pragma is not a subprogram", node); NATURE(proc_name) = newnat; marker_node = N_AST1((Node)args[2]); if (tup_size(args) == 3 ) { type_node = (Node)args[3]; find_old(type_node); } else type_node = OPT_NODE; N_KIND(node) = as_predef; N_UNQ(node) = proc_name; /* marker_node is an as_line_no node which carries the numerical * predef code corresponding to the entry in the pragma * IO_INTERFACE. as_line_no was used to simpify having the predef * code converted into a number by the parser and relayed here * as an integer. */ N_VAL(node) = N_VAL(marker_node); N_TYPE(node) = (type_node == OPT_NODE)? OPT_NAME : N_UNQ(type_node); } else if (streq(id, "INTERFACE") ) { /* Current interface to C and FORTRAN * The pragma makes up the body of a procedure. * This body is formatted into a single tuple : * * [language, name] * * where language is C or FORTRAN and name is the identifier * of the subprogram to be interfaced. * This pragma is allowed at the place of a declarative item of * the same declarative part or package specification. The pragma * is also allowed for a library unit; in this case, the pragma must * appear after the subprogram decl, and before any subsequent * compilation unit. */ arg1 = (Node) args[1]; /* The 1st arg in the pragma list is an identifier (C or FORTRAN) */ if (N_KIND(arg1) != as_name) { warning("invalid format for pragma", node); return; } id = N_VAL(N_AST1(arg1)); if (!streq(id, "C") && !streq(id, "FORTRAN")) { warning("invalid first argument for pragma", node); return; } arg2 = (Node) args[2]; /* The 2nd argument in the pragma list is a subprogram identifier */ if (N_KIND(arg2) != as_name) { warning("invalid format for pragma", node); return; } id = N_VAL(N_AST1(arg2)); /* assert exists proc_name in overloads(declared(scope_name)(id)) * | rmatch(nature(proc_name), '_spec') /= om; */ exists = FALSE; id_sym = dcl_get(DECLARED(scope_name), id); if (id_sym == (Symbol)0) { if (NATURE(scope_name)== na_private_part) /* check parent scope, which is scope of visible part */ id_sym = dcl_get(DECLARED((Symbol)open_scopes[2]), id); if (id_sym == (Symbol)0) { warning("subprogram given in pragma not found", node); return; } } FORSET(proc_name = (Symbol), OVERLOADS(id_sym), fs1); nat = NATURE(proc_name); if (nat == na_procedure_spec) { newnat = na_procedure; exists = TRUE; } else if (nat == na_function_spec) { newnat = na_function; exists = TRUE; } ENDFORSET(fs1); if (!exists) { warning("invalid second argument to pragma", node); return; } NATURE(proc_name) = newnat; N_KIND(node) = as_interfaced; N_UNQ(node) = proc_name; N_AST1(node) = N_AST1(arg1); } else if (streq(id, "PRIORITY")) { Unitdecl ud; if (tup_size(args) == 1) { ud = unit_decl_get("spSYSTEM"); if (ud == (Unitdecl)0 || !in_vis_mods(ud->ud_unam) ) { warning( "use of PRIORITY without presence of package SYSTEM is ignored", (Node)args[1]); N_KIND(node) = as_opt; N_AST1(node) = N_AST2(node) = N_AST3(node) = N_AST4(node) = (Node)0; return; } else { p_type = dcl_get_vis(DECLARED(ud->ud_unam), "PRIORITY"); } priority = (Node) args[1]; check_type(p_type, priority); if (!is_static_expr(priority)) warning("Priority must be static", priority); } else warning("Invalid format for pragma priority", node); } else if (streq(id, "CONTROLLED") || streq(id, "INCLUDE") || streq(id, "INLINE") || streq(id, "LIST") || streq(id, "MEMORY_SIZE") || streq(id, "OPTIMIZE") || streq(id, "PACK") || streq(id, "STORAGE_UNIT") || streq(id, "SUPRESS") || streq(id, "SYSTEM") ) { warning("unsupported pragma", id_node); } else warning("unrecognized pragma", node); } }
static Span retrieve_r_span(Node node) /*;retrieve_r_span */ { int i,listsize,length=1; unsigned int nkind; Span rspan = (Span)0 ; Node attr_node; if (node == (Node)0 || node == OPT_NODE) return (Span)0; nkind = N_KIND(node); if (is_terminal_node(nkind)) { if (N_VAL_DEFINED(nkind)) /* as_null, as_null_s, as_others, * have no N_VAL field defined */ if (nkind != as_number && nkind != as_ivalue && nkind != as_line_no && N_VAL(node) != (char *)0) length = strlen(N_VAL(node)); return (make_span(N_SPAN0(node), N_SPAN1(node)+length-1)); } if (nkind == as_exit) { if (N_AST2(node) != OPT_NODE) return retrieve_r_span(N_AST2(node)); if (N_AST1(node) != OPT_NODE) return retrieve_r_span(N_AST1(node)); return retrieve_r_span(N_AST4(node)); } if (nkind == as_return) { if (N_AST1(node) != OPT_NODE) return retrieve_r_span(N_AST1(node)); return retrieve_r_span(N_AST4(node)); } if (nkind == as_raise) { if (N_AST1(node) != OPT_NODE) return retrieve_r_span(N_AST1(node)); return retrieve_r_span(N_AST2(node)); } if (nkind == as_others_choice) { if (N_AST2(node) != OPT_NODE) return retrieve_r_span(N_AST2(node)); if (N_AST1(node) != OPT_NODE) return retrieve_r_span(N_AST1(node)); return retrieve_r_span(N_AST3(node)); } if (nkind == as_attribute) { /* N_AST1 is number node representing attribute */ attr_node = N_AST1(node); if (N_KIND(attr_node) == as_number) /* due to errors, this is not necessarily the case */ length = strlen(attribute_str((int) N_VAL(attr_node))); rspan = make_span(N_SPAN0(attr_node), N_SPAN1(attr_node) + length - 1 ); return rspan; } if (nkind == as_entry_name || nkind == as_entry_family_name) { /* N_AST3 gets temporarily overwritten with N_NAMES, * so ignore it */ return retrieve_r_span(N_AST1(node)); } if (N_LIST_DEFINED(nkind)) { listsize = tup_size(N_LIST(node)); if (listsize == 0) return (Span)0; for (i=listsize; i > 0; i--) { rspan = retrieve_r_span((Node)N_LIST(node)[i]); if (rspan != (Span)0) return rspan; } return (Span)0; } if (N_AST4_DEFINED(nkind)) rspan = retrieve_r_span(N_AST4(node)); if (N_AST3_DEFINED(nkind) && rspan == (Span)0 ) rspan = retrieve_r_span(N_AST3(node)); if (N_AST2_DEFINED(nkind) && rspan == (Span)0 ) rspan = retrieve_r_span(N_AST2(node)); if (N_AST1_DEFINED(nkind) && rspan == (Span)0 ) rspan = retrieve_r_span(N_AST1(node)); return rspan; }
/* 5.4: Case statement */ Tuple make_case_table(Node cases_node) /*;make_case_table*/ { /* Function : takes a set of alternatives, and produces a linear table * suitable for jump table, of case ranges sorted in ascending * order. Some optimisation is done, to merge contiguous * ranges and to fill missing ranges with "others" case * Input : case_node ::= {case_statements} * case_statements ::= [choice_list, body] * choice_list ::= { choice } * choice ::= simple_choice | range_choice * | others_choice * simple_choice ::= [ value ] * range_choice ::= [ subtype ] * Output : [table, bodies, others_body] * table ::= [ [ lower_bound, index ] ] * - an extra pair is added with a "lower_bound" one step * higher than necessary * - "index" is an index in the tuple "bodies", and * index = 0 means "others" */ Node case_statements_node, choice_list_node, body_node, choice_node, lbd_node, ubd_node, others_body; Tuple result, tup, bodies, triplets; int index, a1, a2, a3, b1, b2, b3, lbd_int, ubd_int; int empty; Fortup ft1, ft2; #ifdef TRACE if (debug_flag) gen_trace_node("MAKE_CASE_TABLE", cases_node); #endif /* 1. build a set of triples [lowerbound, upperbound, index] */ index = 0; bodies = tup_new(0); triplets = tup_new(0); others_body = OPT_NODE; FORTUP(case_statements_node = (Node), N_LIST(cases_node), ft1); choice_list_node = N_AST1(case_statements_node); body_node = N_AST2(case_statements_node); index += 1; empty = TRUE; /* may be we have an empty branch */ FORTUP(choice_node = (Node), N_LIST(choice_list_node), ft2); switch (N_KIND(choice_node)) { case (as_range): lbd_node = N_AST1(choice_node); ubd_node = N_AST2(choice_node); lbd_int = get_ivalue_int(lbd_node); ubd_int = get_ivalue_int(ubd_node); if (lbd_int <= ubd_int) { tup = tup_new(3); tup[1] = (char *) lbd_int; tup[2] = (char *) ubd_int; tup[3] = (char *) index; triplets = tup_with(triplets, (char *) tup); empty = FALSE; } break; case (as_others_choice): others_body = body_node; break; default: compiler_error( "Unknown kind of choice: "); } ENDFORTUP(ft2); if (empty) index -= 1; else bodies = tup_with(bodies, (char *) body_node); ENDFORTUP(ft1); result = tup_new(0); if (tup_size(triplets) != 0) { /* We may have a completely empty case */ /* 2. sort the set of triples, giving a tuple */ triplets = sort_case(triplets); /* 3. build the case table, filling gaps and merging adjacent cases */ tup = (Tuple) tup_fromb(triplets); a1 = (int) tup[1]; a2 = (int) tup[2]; a3 = (int) tup[3]; while(tup_size(triplets) != 0) { tup = (Tuple) tup_fromb(triplets); b1 = (int) tup[1]; b2 = (int) tup[2]; b3 = (int) tup[3]; if (a2 != b1-1) { /* gap */ tup = tup_new(2); tup[1] = (char *) a1; tup[2] = (char *) a3; result = tup_with(result, (char *) tup); tup = tup_new(2); tup[1] = (char *) (a2+1); tup[2] = (char *) 0; result = tup_with(result, (char *) tup); a1 = b1; a2 = b2; a3 = b3; } else if (a3 == b3) { /* merge */ a2 = b2; a3 = b3; } else { tup = tup_new(2); tup[1] = (char *) a1; tup[2] = (char *) a3; result = tup_with(result, (char *) tup); a1 = b1; a2 = b2; a3 = b3; } } tup = tup_new(2); tup[1] = (char *) a1; tup[2] = (char *) a3; result = tup_with(result, (char *) tup); tup = tup_new(2); if (a2 != MAX_INTEGER) { tup[1] = (char *) a2+1; tup[2] = (char *) 0; } else { tup[1] = (char *) 0; /* does not really matter */ tup[2] = (char *) a3;/* merge with the preceeding */ } result = tup_with(result, (char *) tup); } tup = tup_new(3); tup[1] = (char *) result; tup[2] = (char *) bodies; tup[3] = (char *) others_body; return tup; }
Node build_init_call(Node one_component, Symbol proc_name, Symbol c_type, Node object) /*;build_init_call*/ { /* * Construct statement to initialize an object component for which * an initialization procedure exists. The statement is a call to that * procedure. * c_type is the (composite) type of the component. * If this is a record type whose discriminants have default values, * use these defaults as parameters of the initialization procedure. * * If it is a subtype, use the discriminant values elaborated for * the subtype template. * * In the case of record component that is a record subtype, the const- * raint may be given by a discriminant of the outer record. Such const- * raints can only be evaluated when the outer object itself is being * elaborated. In that case the value of discriminant is rewritten as * a selected component of the enclosing object. * * The constrained bit is treated like other discriminants. Its value is * FALSE for a record type, TRUE for a record subtype. * * If this is an array type, the procedure has one_component as its * single actual. */ Tuple disc_vals, tup, discr_map, arg_list; Fortup ft1; Symbol d; Node node, p_node, args_node, d_val, d_val_new; int i, n; #ifdef TRACE if (debug_flag) gen_trace_symbol("BUILD_INIT_CALL", proc_name); #endif if (is_record_type(c_type)) { if (is_record_subtype(c_type)) { /* examine constraint of subtype. */ disc_vals = tup_new(0); tup = SIGNATURE(c_type); discr_map = (Tuple) tup[2]; FORTUP(d=(Symbol), discriminant_list_get(c_type), ft1); d_val = discr_map_get(discr_map, d); if (is_discr_ref(d_val) ) { /* depends on determinant of outer object */ d_val_new = remove_discr_ref(d_val, object); } else if (is_ivalue(d_val) ) { /* useless to retrieve from subtype here */ d_val_new = d_val; } else { /* elaborated: retrieve from subtype. */ d_val_new = new_discr_ref_node(d, c_type); } disc_vals = tup_with(disc_vals, (char *) d_val_new); ENDFORTUP(ft1); } else { /* Use default values to initialize discriminants. */ tup = discriminant_list_get(c_type); n = tup_size(tup); disc_vals = tup_new(n); for (i = 1; i <= n; i++) disc_vals[i] = (char *) default_expr((Symbol) tup[i]); } arg_list = disc_vals;/* last use of disc_vals so no need to copy*/ arg_list = tup_with(arg_list, (char *) one_component); } else { arg_list = tup_new1((char *) one_component); } /* Build call to initialization procedure. */ node = new_node(as_init_call); p_node = new_name_node(proc_name); args_node = new_node(as_list); N_LIST(args_node) = arg_list; N_AST1(node) = p_node; N_AST2(node) = args_node; N_SIDE(node) = FALSE; return node; }
Node build_proc_init_rec(Symbol type_name) /*;build_proc_init_rec*/ { /* * This is the main procedure for building default initialization * procedures for record types. Those initialization procedures are * built if the type given contains some subcomponent for which a * default initialization exists (at any level of nesting), or if it * has determinants. * Note that scalar objects are not initialized at all, which implies * that they get whatever initial value is in that location in memory * This saves some time in object creation. * * All init. procedures have an 'out' parameter that designates the * object begin initialized (the space has already been allocated). * */ int side_effect; Node invar_node; /* TBSL: is invar_node local??*/ Tuple stmts, tup, nstmts, formals, invariant_fields; Tuple discr_list; /* is this local ?? TBSL */ Fortup ft1; Symbol d, proc_name; Node param, var_node, out_param; Node node, node1, node2, discr_value_node; #ifdef TRACE if (debug_flag) gen_trace_symbol("BUILD_PROC_INIT_REC", type_name); #endif side_effect = FALSE; /* Let's hope... TBSL */ /* * The initialization procedure for records has the usual out param., * and one in parameter per discriminant. The CONSTRAINED flag is the * first of the discriminants */ proc_name = new_unique_name("Init_ type_name"); out_param = new_param_node("param_type_name", proc_name, type_name, na_out); generate_object(proc_name); generate_object(N_UNQ(out_param)); tup = SIGNATURE(type_name); invar_node = (Node) tup[1]; var_node = (Node) tup[2]; discr_list = (Tuple) tup[3]; invariant_fields = build_comp_names(invar_node); stmts = tup_new(0); if (tup_size(discr_list)) { /* Generate formal parameters for each. The body of the procedure */ /* assigns them to the field of the object. */ /* Note: the 'constrained' field is part of the discriminants. */ formals = tup_new(0); FORTUP(d=(Symbol), discr_list, ft1); param = new_param_node("param_type_name", proc_name, TYPE_OF(d), na_in); generate_object(N_UNQ(param)); formals = tup_with(formals, (char *) param ); stmts = tup_with(stmts, (char *) new_assign_node(new_selector_node(out_param, d), param)); discr_value_node = new_selector_node (out_param, d); /* generate code in order to test if the value of discriminant is * compatible with its subtype */ node1 = new_attribute_node(ATTR_T_FIRST, new_name_node(TYPE_OF(d)), OPT_NODE, TYPE_OF(d)); node2 = new_attribute_node(ATTR_T_LAST, new_name_node(TYPE_OF(d)), OPT_NODE, TYPE_OF(d)); node = node_new (as_list); make_if_node(node, tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_or, new_binop_node(symbol_lt, discr_value_node, node1, symbol_boolean), new_binop_node(symbol_gt, discr_value_node, node2, symbol_boolean), symbol_boolean), new_raise_node(symbol_constraint_error))), OPT_NODE); stmts = tup_with(stmts, (char *) node); ENDFORTUP(ft1); formals = tup_with(formals, (char *) out_param ); /* if there are default expressions for any other components, */ /* further initialization steps are needed. */ tup = proc_init_rec(type_name, invariant_fields, var_node, out_param); /*stmts += proc_init_rec(invariant_fields, var_node, out_param);*/ nstmts = tup_add(stmts, tup); tup_free(stmts); tup_free(tup); stmts = nstmts; } else { /* record without discriminants. There may still be default values */ /* for some components. */ formals = tup_new1((char *) out_param); stmts = proc_init_rec(type_name,invariant_fields,var_node, out_param); } if (tup_size(stmts)) { INIT_PROC(type_name) = proc_name; return initialization_proc(proc_name, type_name, formals, stmts); } else { return OPT_NODE; } }
Node build_proc_init_ara(Symbol type_name) /*;build_proc_init_ara*/ { /* * This is the main procedure for building default initialization * procedures for array types. Those initialization procedures are * built if the type given contains some subcomponent for which a * default initialization exists (at any level of nesting), or if it * has determinants. * Note that scalar objects are not initialized at all, which implies * that they get whatever initial value is in that location in memory * This saves some time in object creation. * * All init. procedures have an 'out' parameter that designates the * object being initialized (the space has already been allocated). * */ int side_effect; Tuple tup, formals, subscripts; Symbol c_type, ip, index_t, proc_name, index_sym; Node one_component, init_stmt, out_param, i_nodes, d_node, iter_node; Fortup ft1; Node iterator, index_node; #ifdef TRACE if (debug_flag) { gen_trace_symbol("BUILD_PROC_INIT_ARR", type_name); } #endif side_effect = FALSE; /* Let's hope... TBSL */ tup = SIGNATURE(type_name); c_type = (Symbol) tup[2]; one_component = new_node(as_index); ip = INIT_PROC(base_type(c_type)); if (ip != (Symbol)0 ){ /* Use the initialization procedure for the component type */ init_stmt = (Node) build_init_call(one_component, ip, c_type, OPT_NODE); } else if (is_task_type(c_type)) { /* initialization is task creation. */ init_stmt = new_assign_node(one_component, new_create_task_node(c_type)); } else if (is_access_type(c_type)) { /* default value is the null pointer. */ init_stmt = new_assign_node(one_component, new_null_node(c_type)); } else { init_stmt = (Node) 0; } if (init_stmt != (Node)0) { /* body of initialization procedure is a loop over the indices */ /* allocating each component. Generate loop variables and code */ /* for iteration, using the attributes of the type. */ proc_name = new_unique_name("type_name+INIT"); out_param = new_param_node("param_type_name", proc_name, type_name, na_out); generate_object(N_UNQ(out_param)); formals = tup_new1((char *) out_param); subscripts = tup_new(0); FORTUP(index_t=(Symbol), index_types(type_name), ft1); /*index = index_t + 'INDEX';*/ index_sym = new_unique_name("index_t+INDEX"); NATURE (index_sym) = na_obj; TYPE_OF(index_sym) = index_t; subscripts = tup_with(subscripts, (char *)new_name_node(index_sym)); ENDFORTUP(ft1); i_nodes = new_node(as_list); /* need tup_copy since subscripts used destructively below */ N_LIST(i_nodes) = tup_copy(subscripts); /* Build the tree for the one_component of the array. */ N_AST1(one_component) = out_param; N_AST2(one_component) = i_nodes; N_TYPE(one_component) = c_type; while (tup_size(subscripts)) { /* Build loop from innermost index outwards. The iterations */ /* span the ranges of the array being initialized. */ /* dimension spanned by this loop: */ d_node = new_ivalue_node(int_const(tup_size(subscripts)), symbol_integer); iterator = new_attribute_node(ATTR_O_RANGE, new_name_node(N_UNQ(out_param)), d_node, type_name); index_node = (Node) tup_frome(subscripts); iter_node = new_node(as_for); N_AST1(iter_node) = index_node; N_AST2(iter_node) = iterator; init_stmt = new_loop_node(OPT_NODE, iter_node, tup_new1((char *)init_stmt)); } INIT_PROC(type_name) = proc_name; return initialization_proc(proc_name, type_name, formals, tup_new1((char *) init_stmt)); } else { return OPT_NODE; } }
static Tuple proc_init_rec(Symbol type_name, Tuple field_names, Node variant_node, Node out_param) /*;proc_init_rec*/ { /* * This is a subsidiary procedure to BUILD_PROC_INIT, which performs * the recursive part of construction of an initialization procedure * for a record type. * * Input: field_names is a list of component unique names (excluding * discriminants. Variant node is the AST for the variant part * of a component list. * variant_node is the variant part of the record declaration * and has the same structure as a case statement. * * out_param designates the object being initialized * * Output: the statement list required to initialize this fragment of * the record, or [] if not default initialization is needed. */ Tuple init_stmt, stmts; Node one_component, f_init, c_node, variant_list; Symbol f_type, f_name, ip; Fortup ft1; int empty_case; Tuple case_list, comp_case_list; Node choice_list, comp_list, disc_node; Node invariant_node, new_case, list_node, case_node; Tuple tup, index_list; int nb_dim, i; Node d_node, node, node1, node2, node3, node4, node5; Symbol one_index_type; /* process fixed part first. */ init_stmt = tup_new(0); FORTUP(f_name=(Symbol), field_names, ft1); one_component = new_selector_node(out_param, f_name); f_type = TYPE_OF(f_name); CONTAINS_TASK(type_name) = (char *) ((int)CONTAINS_TASK(type_name) | (int) CONTAINS_TASK(f_type)); f_init = (Node) default_expr(f_name); if (f_init != OPT_NODE) { init_stmt = tup_with(init_stmt, (char *) new_assign_node(one_component, remove_discr_ref(f_init, out_param))); } else if ((ip = INIT_PROC(base_type(f_type)))!=(Symbol)0) { init_stmt = tup_with(init_stmt, (char *) build_init_call(one_component, ip, f_type, out_param)); } else if (is_task_type(f_type)) { init_stmt = tup_with(init_stmt, (char *) new_assign_node(one_component, new_create_task_node(f_type))); } else if (is_access_type(f_type)) { init_stmt = tup_with(init_stmt, (char *) new_assign_node(one_component, new_null_node(f_type))); } /* if we have an aray then we have to check if its bounds are * compatible with the index subtypes (of the unconstrained array) * (This code was generated beforehand in type.c ("need_qual_r") but * it was wrong : we have to test the bounds only if the field is * present (case of variant record). * The generation of the tests is easier here */ if (is_array_type (f_type)) { tup = (Tuple) SIGNATURE(TYPE_OF(f_type)); index_list = tup_copy((Tuple) tup[1]); nb_dim = tup_size(index_list); for (i = 1; i <= nb_dim; i++) { one_index_type = (Symbol) (tup_fromb (index_list)); d_node = new_ivalue_node(int_const(i), symbol_integer); node1 = new_attribute_node(ATTR_O_FIRST, one_component, d_node, one_index_type); node2 = new_attribute_node(ATTR_O_LAST, one_component, d_node, one_index_type); node3 = new_attribute_node(ATTR_T_FIRST, new_name_node(one_index_type), OPT_NODE, one_index_type); node4 = new_attribute_node(ATTR_T_LAST, new_name_node(one_index_type), OPT_NODE, one_index_type); node5 = new_binop_node(symbol_or, new_binop_node(symbol_lt, node1, node3, symbol_boolean), new_binop_node(symbol_gt, node2, node4, symbol_boolean), symbol_boolean); node = node_new (as_list); make_if_node(node, tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_and, new_binop_node(symbol_le, node1, node2, symbol_boolean), node5, symbol_boolean), new_raise_node(symbol_constraint_error))), OPT_NODE); init_stmt = tup_with(init_stmt, (char *) (node)); } } ENDFORTUP(ft1); /* then build case statement to parallel structure of variant part. */ empty_case = TRUE; /* assumption */ if (variant_node != OPT_NODE) { disc_node= N_AST1(variant_node); variant_list = N_AST2(variant_node); case_list = tup_new(0); comp_case_list = N_LIST(variant_list); FORTUP(c_node=(Node), comp_case_list, ft1); choice_list = N_AST1(c_node); comp_list = N_AST2(c_node); invariant_node = N_AST1(comp_list); variant_node = N_AST2(comp_list); field_names = build_comp_names(invariant_node); stmts = proc_init_rec(type_name,field_names,variant_node, out_param); /*empty_case and= stmts = [];*/ empty_case = empty_case ? (tup_size(stmts)==0) : FALSE; new_case = (N_KIND(c_node) == as_others_choice) ? new_node(as_others_choice) : new_node(as_variant_choices); N_AST1(new_case) = copy_tree(choice_list); N_AST2(new_case) = new_statements_node(stmts); case_list = tup_with(case_list, (char *) new_case ); ENDFORTUP(ft1); if (! empty_case) { /* Build a case statement ruled by the value of the discriminant */ /* for this variant part. */ list_node = new_node(as_list); N_LIST(list_node) = case_list; case_node = new_node(as_case); N_AST1(case_node) = new_selector_node(out_param, N_UNQ(disc_node)); N_AST2(case_node) = list_node; init_stmt = tup_with(init_stmt, (char *) case_node ); } } return init_stmt; }