static Node val_node3(Rational init_val) /*;val_node3*/
{
/* Called from init_sem to initialize the bounds of predefined types.*/
Node node;
node = node_new(as_ivalue);
init_node_save(node);
/* INTEGER TUPLE case */
N_TYPE(node) = symbol_universal_real;
N_VAL(node) =(char *) rat_const(init_val);
return node;
}
static Node val_nodea1(int init_val) /*;val_nodea1*/
{
/* Called from init_sem to initialize the bounds of predefined types.*/
/* like val_node1, but does not save generated node */
Node node;
node = node_new(as_ivalue);
/* INTEGER case */
N_TYPE(node) = symbol_integer;
N_VAL(node) =(char *) int_const(init_val);
return node;
}
void TTR_set_ident_data_type(
Symbol_Table *table, TTR_Node *identifier, int type)
{
TTR_Node *sym_node;
assert(table != NULL);
assert(identifier != NULL);
assert(N_TYPE(identifier) == N_IDENTIFIER ||
N_TYPE(identifier) == N_FUNCDEF);
sym_node = symbol_table_lookup(table, N_STR(identifier));
if (sym_node == NULL) {
N_DTYPE(identifier) = type;
symbol_table_add(table, N_STR(identifier), identifier);
} else {
if (N_DTYPE(sym_node) == UNDEFINED_T) {
N_DTYPE(identifier) = type;
N_DTYPE(sym_node) = type;
} else {
N_DTYPE(identifier) = N_DTYPE(sym_node);
}
}
}
static Node val_node2(double init_val) /*;val_node2*/
{
/* Called from init_sem to initialize the bounds of predefined types.*/
Node node;
/* 'REAL' case */
node = node_new(as_ivalue);
init_node_save(node);
N_TYPE(node) = symbol_float;
N_VAL(node) = (char *)real_const(init_val);
return node;
}
void patch(void)
{
TTR_Node *node, *stored;
int type;
SET_GLOBAL_SCOPE();
for ( node = dll_pop_head(call_patch_list);
node != NULL;
node = dll_pop_head(call_patch_list)) {
stored = GET_SYMBOL(N_STR(node));
if (stored == NULL) {
fprintf(stderr, "<Line %d> Function \"%s\" never defined\n",
N_LINE(node), N_STR(node));
err_exit("Fatal error");
} else {
N_DTYPE(node) = N_DTYPE(stored);
if (COMPARE_TYPES(N_CHILD(stored, 0), N_CHILD(node, 0))) {
fprintf(stderr,
"<Line %d> Incompatible types in call to %s.\n",
N_LINE(node), N_STR(node));
err_exit("Fatal error");
}
}
}
for ( node = dll_pop_head(var_patch_list);
node != NULL;
node = dll_pop_head(var_patch_list)) {
SET_GLOBAL_SCOPE();
ENTER_SCOPE(N_SCOPE(node));
if (N_TYPE(node) == N_ASSIGN) {
TTR_set_ident_data_type(symbol_table,
N_CHILD(node, 0), N_DTYPE(N_CHILD(node, 1)));
}
type = TTR_infer_data_type(node);
if (type == INVALID_T) {
fprintf(stderr, "<Line %d> Incompatible types.\n",
N_LINE(node));
err_exit("Fatal error");
} else if (type == UNDEFINED_T) {
fprintf(stderr, "<Line %d> Unknown symbol.\n", N_LINE(node));
print_tree(node, 0);
err_exit("Fatal error");
}
}
}
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);
}
}
/* Object evaluation */
void gen_address(Node node) /*;gen_address*/
{
/*
* This procedure generates code for the o_expressions
* or, in other words, the left-handsides.
*/
Node pre_node, array_node, range_node, lbd_node, ubd_node, record_node,
field_node, id_node;
Symbol node_name, type_name, record_name, record_type,
field_name, comp_type, proc_name, return_type;
int f_off, bse, off, nk;
Fortup ft1;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_ADDRESS", node);
#endif
while (N_KIND(node) == as_insert) {
FORTUP(pre_node=(Node), N_LIST(node), ft1);
compile(pre_node);
ENDFORTUP(ft1);
node = N_AST1(node);
}
node_name = N_UNQ(node);
if (is_simple_name(node)) {
type_name = get_type(node);
if (is_renaming(node_name))
gen_ks(I_PUSH, mu_addr, node_name);
else
gen_s(I_PUSH_EFFECTIVE_ADDRESS, node_name);
/* Arrays are treated in a different manner, depending on their */
/* nature: parameters, constants, variables... */
if (is_array_type(type_name)) {
if (is_formal_parameter(node_name)) {
type_name = assoc_symbol_get(node_name, FORMAL_TEMPLATE);
}
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
}
}
else {
switch (nk = N_KIND(node)) {
case as_raise:
compile(node);
break;
case as_index:
gen_subscript(node);
break;
case as_slice:
array_node = N_AST1(node);
range_node = N_AST2(node);
/*range_name = N_UNQ(range_node); -- never used ds 7-8-85 */
/* Note: case of type simple name changed into range attribute */
/* by expander */
if (N_KIND(range_node) == as_attribute) {
gen_attribute(range_node);
}
else { /* range */
lbd_node = N_AST1(range_node);
ubd_node = N_AST2(range_node);
gen_value(lbd_node);
gen_value(ubd_node);
}
if (N_KIND(array_node) == as_attribute) {
gen_attribute(array_node);
}
else {
gen_address(array_node);
}
gen(I_ARRAY_SLICE);
break;
case as_selector:
record_node = N_AST1(node);
field_node = N_AST2(node);
record_name = N_UNQ(record_node);
record_type = get_type(record_node);
field_name = N_UNQ(field_node);
f_off = FIELD_OFFSET(field_name);
if (f_off >= 0 &&
((! has_discriminant(record_type))
|| NATURE(field_name) == na_discriminant)){
if (is_simple_name(record_node)
&& !(is_renaming(record_name)) && is_global(record_name)) {
reference_of(record_name);
bse = REFERENCE_SEGMENT;
off = REFERENCE_OFFSET;
/* The SETL version has generate(I_PUSH_IMMEDIATE, mu_addr,
* ref, field_name);
* which we translate as (I_PUSH_EFFECTIVE_ADDRESS ...
* ref = [bse, off+f_off];
* Replace use of explicit ref by PUSH_IMMEDIATE
*/
/* gen_rc(I_PUSH_IMMEDIATE, explicit_ref_new(bse,
* off+f_off), "");
*/
gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(bse));
gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(off+f_off));
}
else {
gen_address(record_node);
if (f_off != 0 ) {
gen_ki(I_ADD_IMMEDIATE, mu_word, f_off);
}
}
if (is_array_type(comp_type=TYPE_OF(field_name))) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type);
}
}
else {
gen_address(record_node);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, record_type);
/* translating following assuming field_name is comment part of
*-- instruction ds 7-5-86
* gen_i(I_SELECT, FIELD_NUMBER(field_name), field_name);
*/
gen_i(I_SELECT, (int) FIELD_NUMBER(field_name));
}
break;
case as_all:
id_node = N_AST1(node);
gen_value(id_node);
if (is_array_type(N_TYPE(node)))
gen_k(I_DEREF, mu_dble);
break;
case as_call:
id_node = N_AST1(node);
proc_name = N_UNQ(id_node);
return_type = TYPE_OF(proc_name);
gen_kc(I_DUPLICATE, kind_of(return_type), "place holder");
compile(node); /* processed from now as a procedure call */
break;
case as_un_op:
gen_unary(node);
break;
case as_op:
gen_binary(node);
break;
case as_string_ivalue:
gen_value(node);
break;
default:
compiler_error_k("GEN_ADDRESS called with kind ", 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 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;
}