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;
}
