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;
}
static void sym_inits(Symbol sym, Symbol typ, Tuple sig, Symbol ali)
/*;sym_inits*/
{
/* initialize standard part of symbol. These are the fields used
* by both adasem and adagen.
*/
TYPE_OF(sym) = typ;
SIGNATURE(sym) = sig;
ALIAS(sym) = ali;
}
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 Const const_val(Symbol obj) /*;const_val*/
{
/* Return the constant value of the object if it has one;
* else return om.
* The constant value of a user-defined constant is derived from
* its SIGNATURE, when this is a constant value.
* The constant value of a literal is obtained from the literal map
* of its type.
*/
Tuple sig;
if (cdebug2 > 3) TO_ERRFILE("const_val");
if (is_literal(obj)) return eval_lit_map(obj);
sig = SIGNATURE(obj);
if( is_constant(obj) && is_scalar_type(TYPE_OF(obj))
&& N_KIND((Node)sig) == as_ivalue) {
return (Const) N_VAL((Node)sig);
/* TBSL: could be static but not constant folded yet. */
}
else return const_new(CONST_OM);
}
0xa6, 0x87, 0x58, 0x3f, 0x36, 0x13, 0xf4, 0x7e, 0xf0, 0x20, 0x47, 0x87, 0x3f, 0x21, 0x6e, 0x51, 0x3c, 0xf1, 0xef, 0xca, 0x9f, 0x77, 0x9c, 0x91, 0x4f, 0xd4, 0x56, 0xc0, 0x39, 0x11, 0xab, 0x15, 0x2c, 0x5e, 0xad, 0x40, 0x09, 0xe6, 0xde, 0xe5, 0x77, 0x60, 0x19, 0xd4, 0x0d, 0x77, 0x76, 0x24, 0x8b, 0xe6, 0xdd, 0xa5, 0x8d, 0x4a, 0x55, 0x3a, 0xdf, 0xf8, 0x29, 0xfb, 0x47, 0x8a, 0xfe, 0x98, 0x34, 0xf6, 0x30, 0x7f, 0x09, 0x03, 0x26, 0x05, 0xd5, 0x46, 0x18, 0x96, 0xca, 0x96, 0x5b, 0x66, 0xf2, 0x8d, 0xfc, 0xfc, 0x37, 0xf7, 0xc7, 0x6d, 0x6c, 0xd8, 0x24, 0x0c, 0x6a, 0xec, 0x82, 0x5c, 0x72, 0xf1, 0xfc, 0x05, 0xed, 0x8e, 0xe8, 0xd9, 0x8b, 0x8b, 0x67, 0x02, 0x95 ), &md5_algorithm, SIGNATURE ( 0xdb, 0x56, 0x3d, 0xea, 0xae, 0x81, 0x4b, 0x3b, 0x2e, 0x8e, 0xb8, 0xee, 0x13, 0x61, 0xc6, 0xe7, 0xd7, 0x50, 0xcd, 0x0d, 0x34, 0x3a, 0xfe, 0x9a, 0x8d, 0xf8, 0xfb, 0xd6, 0x7e, 0xbd, 0xdd, 0xb3, 0xf9, 0xfb, 0xe0, 0xf8, 0xe7, 0x71, 0x03, 0xe6, 0x55, 0xd5, 0xf4, 0x02, 0x3c, 0xb5, 0xbc, 0x95, 0x2b, 0x66, 0x56, 0xec, 0x2f, 0x8e, 0xa7, 0xae, 0xd9, 0x80, 0xb3, 0xaa, 0xac, 0x45, 0x00, 0xa8 ) ); /** Random message SHA-1 signature test */ RSA_SIGNATURE_TEST ( sha1_test, PRIVATE ( 0x30, 0x82, 0x01, 0x3b, 0x02, 0x01, 0x00, 0x02, 0x41, 0x00, 0xe0, 0x3a, 0x8d, 0x35, 0xe1, 0x92, 0x2f, 0xea, 0x0d, 0x82, 0x60, 0x2e, 0xb6, 0x0b, 0x02, 0xd3, 0xf4, 0x39, 0xfb, 0x06, 0x43, 0x8e, 0xa1, 0x7c, 0xc5, 0xae, 0x0d, 0xc7, 0xee, 0x83, 0xb3, 0x63, 0x20, 0x92, 0x34, 0xe2, 0x94, 0x3d, 0xdd, 0xbb, 0x6c, 0x64, 0x69, 0x68, 0x25, 0x24, 0x81, 0x4b, 0x4d, 0x48, 0x5a, 0xd2, 0x29, 0x14, 0xeb, 0x38, 0xdd, 0x3e, 0xb5, 0x57, 0x45, 0x9b, 0xed, 0x33, 0x02, 0x03, 0x01, 0x00, 0x01, 0x02, 0x40, 0x3d, 0xa9, 0x1c, 0x47, 0xe2, 0xdd, 0xf6, 0x7b, 0x20,
void gen_subscript(Node node) /*;gen_subscript*/
{
Symbol comp_type;
Node index_name, array_node;
Node index_list_node, subscript;
Tuple index_type_list, subscripts, tup;
Symbol array_name, array_type;
int optimized;
int index, seg, offset;
Fortup ft1;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_SUBSCRIPT", node);
#endif
array_node = N_AST1(node);
index_list_node = N_AST2(node);
array_name = N_UNQ(array_node);
array_type = get_type(array_node);
tup = SIGNATURE(array_type);
index_type_list = (Tuple) tup[1];
comp_type = (Symbol) tup[2];
/* need tup_copy since subscripts used in tup_fromb below */
subscripts = tup_copy(N_LIST(index_list_node));
/*
* Before applying the brute force method of the 'do-it-all' instruction
* "subscript", which can solve any case, some optimizations will be
* attempted.
*
* First, we try to compute the address of the indexed element directly,
* when subscripts are immediate values and the index check can be done
* at compile time:
*/
if ((Symbol)index_type_list[1] == symbol_none) {
optimized = FALSE;
}
else if (!(is_unconstrained(array_type))) {
index = compute_index(subscripts, index_type_list);
optimized = index != -1;
if (optimized) {
if (has_static_size(comp_type)) {
index = index * size_of(comp_type);
if (is_simple_name(array_node) && !is_renaming(array_name) ) {
if (is_global(array_name)) {
reference_of(array_name);
seg = REFERENCE_SEGMENT;
offset = REFERENCE_OFFSET;
/*gen_todo(I_PUSH_EFFECTIVE_ADDRESS,[seg, offset+index],
* array_name + '(" + str(get_ivalue(subscripts(1)))
* +/ [', '+str(get_ivalue(subscripts(i))):
* i in [2..#subscripts] ]
* + ")' );
*/
gen_rc(I_PUSH_EFFECTIVE_ADDRESS, explicit_ref_new(seg,
offset+index), "");
}
else {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, array_name);
if (index != 0)
gen_kic(I_ADD_IMMEDIATE, mu_word, index, "offset");
}
}
else {
gen_address(array_node);
gen_ks(I_DISCARD_ADDR, 1, array_type);
if (index != 0)
gen_ki(I_ADD_IMMEDIATE, mu_word, index);
}
}
else {
optimized = FALSE;
}
}
}
else {
optimized = FALSE;
}
/*
* Nothing worked, we are left with the worse case, solved by the
* "subscript" instruction
*/
if (!optimized) {
FORTUP( index_name=(Node), index_type_list, ft1);
subscript = (Node) tup_fromb(subscripts);
gen_value(subscript) ;
ENDFORTUP(ft1);
gen_address(array_node);
gen(I_SUBSCRIPT);
}
if (is_array_type(comp_type)) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type);
}
}
void init_sem() /*; init_sem */
{
Tuple constr_new, tup, boolean_constraint, constr_character, lmap;
Symbol s;
int i;
char *p, *p1;
Symbol sym;
char name[20];
static char *char_names[] = {
"NUL 0",
"SOH 1",
"STX 2",
"ETX 3",
"EOT 4",
"ENQ 5",
"ACK 6",
"BEL 7",
"BS 8",
"HT 9",
"LF 10",
"VT 11",
"FF 12",
"CR 13",
"SO 14",
"SI 15",
"DLE 16",
"DC1 17",
"DC2 18",
"DC3 19",
"DC4 20",
"NAK 21",
"SYN 22",
"ETB 23",
"CAN 24",
"EM 25",
"SUB 26",
"ESC 27",
"FS 28",
"GS 29",
"RS 30",
"US 31",
"EXCLAM 33",
"QUOTATION 34",
"SHARP 35",
"DOLLAR 36",
"PERCENT 37",
"AMPERSAND 38",
"COLON 58",
"SEMICOLON 59",
"QUERY 63",
"AT_SIGN 64",
"L_BRACKET 91",
"BACK_SLASH 92",
"R_BRACKET 93",
"CIRCUMFLEX 94",
"UNDERLINE 95",
"GRAVE 96",
"LC_A 97",
"LC_B 98",
"LC_C 99",
"LC_D 100",
"LC_E 101",
"LC_F 102",
"LC_G 103",
"LC_H 104",
"LC_I 105",
"LC_J 106",
"LC_K 107",
"LC_L 108",
"LC_M 109",
"LC_N 110",
"LC_O 111",
"LC_P 112",
"LC_Q 113",
"LC_R 114",
"LC_S 115",
"LC_T 116",
"LC_U 117",
"LC_V 118",
"LC_W 119",
"LC_X 120",
"LC_Y 121",
"LC_Z 122",
"L_BRACE 123",
"BAR 124",
"R_BRACE 125",
"TILDE 126",
"DEL 127",
" "
};
current_instances = tup_new(0);
lib_stub = tup_new(0);
seq_node = tup_new(400);
seq_node_n = 0;
seq_symbol = tup_new(100);
seq_symbol_n = 0;
unit_nodes = tup_new(0);
#ifdef TBSL
unit_nodes_n = 0;
#endif
stub_info = tup_new(0);
unit_number_now = 0;
init_nodes = tup_new(30);
init_symbols = tup_new(0);
interfaced_procedures = tup_new(0);
OPT_NODE = node_new(as_opt);
N_LIST(OPT_NODE) = tup_new(0);
init_node_save(OPT_NODE);
#ifdef IBM_PC
/* avoid copy of literal for PC */
#define setname(sym, str) ORIG_NAME(sym) = strjoin(str, "")
#else
#define setname(sym, str) ORIG_NAME(sym) = str
#endif
OPT_NAME = sym_new(na_obj);
setname(OPT_NAME, "opt_name");
#ifdef IBM_PC
#define sym_op_enter(sym, name) sym = sym_new(na_op); \
ORIG_NAME(sym) = strjoin(name, "");
#else
#define sym_op_enter(sym, name) sym = sym_new(na_op); ORIG_NAME(sym) = name;
#endif
symbol_integer = sym_new(na_type);
/* note that val_node1 sets N_TYPE field to symbol_integer, so must
* define symbol_integer before calling val_node1
*/
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(ADA_MIN_INTEGER);
numeric_constraint_high(constr_new) = (char *)val_node1(ADA_MAX_INTEGER);
sym_inits(symbol_integer, symbol_integer, constr_new, symbol_integer);
sym_initg(symbol_integer, TK_WORD, 1, 3);
setname(symbol_integer, "INTEGER");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(-32768);
numeric_constraint_high(constr_new) = (char *) val_node1(32767);
symbol_short_integer_base = sym_new(na_type);
sym_inits(symbol_short_integer_base, symbol_integer,
constr_new, symbol_short_integer);
sym_initg(symbol_short_integer_base, TK_WORD, 1, 77);
setname(symbol_short_integer_base, "SHORT_INTEGER\'base");
symbol_short_integer = sym_new(na_type);
sym_inits(symbol_short_integer, symbol_short_integer_base,
SIGNATURE(symbol_short_integer_base), symbol_short_integer);
sym_initg(symbol_short_integer, TK_WORD, 1, 77);
setname(symbol_short_integer, "SHORT_INTEGER");
ALIAS(symbol_short_integer_base) = symbol_short_integer;
symbol_universal_integer = sym_new(na_type);
sym_inits(symbol_universal_integer , symbol_integer,
SIGNATURE(symbol_integer), symbol_integer);
sym_initg(symbol_universal_integer, TK_WORD, 1, 3);
setname(symbol_universal_integer, "universal_integer");
constr_new = constraint_new(CONSTRAINT_DIGITS);
numeric_constraint_low(constr_new) = (char *) val_node2(ADA_MIN_REAL);
numeric_constraint_high(constr_new) = (char *) val_node2(ADA_MAX_REAL);
numeric_constraint_digits(constr_new) = (char *) val_node1(ADA_REAL_DIGITS);
symbol_float = sym_new(na_type);
sym_inits(symbol_float, symbol_float, constr_new, symbol_float);
/* TBSL: there should be TK_REAL for floating point */
sym_initg(symbol_float, TK_LONG, 1, 73);
setname(symbol_float, "FLOAT");
symbol_universal_real = sym_new(na_type);
sym_inits(symbol_universal_real, symbol_float,
SIGNATURE(symbol_float), symbol_universal_real);
sym_initg(symbol_universal_real, TK_LONG, 1, 73);
setname(symbol_universal_real, "universal_real");
constr_new = constraint_new(CONSTRAINT_DELTA);
numeric_constraint_low(constr_new) = (char *) val_node3(rat_fri(int_fri(-1),
int_fri(0)));
numeric_constraint_high(constr_new) = (char *) val_node3(rat_fri(int_fri(1),
int_fri(0)));
numeric_constraint_delta(constr_new) =
(char *) val_node3(rat_fri(int_fri(0), int_fri(1)));
numeric_constraint_small(constr_new) = (char *) OPT_NODE;
symbol_dfixed = sym_new(na_type);
sym_inits(symbol_dfixed , symbol_dfixed, constr_new, symbol_dfixed);
sym_initg(symbol_dfixed, TK_LONG, 1, 67);
setname(symbol_dfixed, "$FIXED");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(0);
numeric_constraint_high(constr_new) = (char *) val_node1(ADA_MAX_INTEGER);
symbol_natural = sym_new(na_subtype);
sym_inits(symbol_natural , symbol_integer, constr_new, symbol_integer);
sym_initg(symbol_natural, TK_WORD, 1, 57);
setname(symbol_natural, "NATURAL");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *) val_node1(1);
numeric_constraint_high(constr_new) = (char *) val_node1(ADA_MAX_INTEGER);
symbol_positive = sym_new(na_subtype);
sym_inits(symbol_positive , symbol_integer,
constr_new, symbol_integer);
sym_initg(symbol_positive, TK_WORD, 1, 22);
setname(symbol_positive, "POSITIVE");
constr_new = constraint_new(CONSTRAINT_DELTA);
numeric_constraint_low(constr_new) = (char *)
val_node3(rat_fri(int_frs("-86400000"), int_fri(1000)));
numeric_constraint_high(constr_new) = (char *)
val_node3(rat_fri(int_frs("86400000"), int_fri(1000)));
numeric_constraint_delta(constr_new) =
(char *) val_node3(rat_fri(int_fri(1), int_fri(1000)));
numeric_constraint_small(constr_new) = (char *)val_node3(rat_fri(int_fri(1),
int_fri(1000)));
symbol_duration = sym_new(na_type);
sym_inits(symbol_duration , symbol_duration, constr_new, symbol_dfixed);
sym_initg(symbol_duration, TK_LONG, 1, 61);
setname(symbol_duration, "DURATION");
constr_character = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_character) = (char *) val_node1(0);
numeric_constraint_high(constr_character) = (char *) val_node1(127);
symbol_character = sym_new(na_enum);
sym_inits(symbol_character , symbol_character, constr_character,
symbol_character);
sym_initg(symbol_character, TK_WORD, 1, 43);
setname(symbol_character, "CHARACTER");
constr_new = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(constr_new) = (char *)val_node1(0);
numeric_constraint_high(constr_new) = (char *) val_node1(1);
/* save constraint - needed to initialize symbol_constrained below*/
boolean_constraint = constr_new;
symbol_boolean = sym_new(na_enum);
sym_inits(symbol_boolean, symbol_boolean, constr_new, symbol_boolean);
sym_initg(symbol_boolean, TK_WORD, 1, 7);
setname(symbol_boolean, "BOOLEAN");
tup = tup_new(2);
tup[1] =(char *) tup_new1((char *) symbol_positive);
tup[2] = (char *) symbol_character;
symbol_string = sym_new(na_array);
sym_inits(symbol_string , symbol_string, tup, symbol_string);
sym_initg(symbol_string, -1, 1, 26);
setname(symbol_string, "STRING");
/* In SETL, symbol_string_type has a different signature from
* that defined by adasem. This symbol should never be
* used by the generator, so it seems safe to give it the
* same signature as is defined by adasem.
*/
/* symbol_character_type references should not be produced by adasem.
* However, in those cases where they do occur they should be treated
* the same as for symbol_character, so we initialize
* symbol_character_type to correspond to symbol_character.
* ds 9-26-85
*/
symbol_character_type = sym_new(na_enum);
sym_inits(symbol_character_type , symbol_character, constr_character,
symbol_character);
sym_initg(symbol_character_type, TK_WORD, 1, 43);
setname(symbol_character_type, "character_type");
symbol_string_type = sym_new(na_array);
tup = tup_new(2);
tup[1] =(char *) tup_new1((char *) symbol_positive);
tup[2] = (char *) symbol_character_type;
sym_inits(symbol_string_type , symbol_string_type, tup, symbol_string_type);
sym_initg(symbol_string_type, -1, 1, 26);
setname(symbol_string_type, "string_type");
symbol_daccess = sym_new(na_access);
sym_inits(symbol_daccess , symbol_daccess, tup_new(0), symbol_daccess);
sym_initg(symbol_daccess, TK_ADDR, 1, 1);
setname(symbol_daccess, "$ACCESS");
symbol_null = sym_new(na_obj);
sym_inits(symbol_null , symbol_daccess, tup_new(0), symbol_null);
sym_initg(symbol_null, TK_ADDR, 255, 32767);
setname(symbol_null, "null");
symbol_main_task_type = sym_new(na_task_type);
sym_inits(symbol_main_task_type , symbol_main_task_type, tup_new(0),
symbol_main_task_type);
sym_initg(symbol_main_task_type, TK_WORD, 1, 47);
setname(symbol_main_task_type, "main_task_type");
/* The signature for symbol_constrained is its default_expr,
* and corresponds to the first value entered for symbol boolean (FALSE)
*/
symbol_constrained = sym_new(na_discriminant);
sym_inits(symbol_constrained , symbol_boolean,
(Tuple) numeric_constraint_low(boolean_constraint), symbol_constrained);
sym_initg(symbol_constrained, 0, 0, 0);
setname(symbol_constrained, "constrained");
symbol_none = sym_new(na_type);
sym_inits(symbol_none , symbol_none, (Tuple)0, symbol_none);
sym_initg(symbol_none, 0, 0, 0);
setname(symbol_none, "none");
symbol_standard0 = sym_new(na_package);
setname(symbol_standard0, "STANDARD#0");
symbol_undef = sym_new(na_obj); /* for '?' case */
setname(symbol_undef, "?-undef");
symbol_standard = sym_new(na_package);
setname(symbol_standard, "standard");
symbol_unmentionable = sym_new(na_package);
setname(symbol_unmentionable, "unmentionable");
symbol_ascii = sym_new(na_package);
setname(symbol_ascii, "ASCII");
symbol_long_integer = sym_new(na_type);
setname(symbol_long_integer, "LONG_INTEGER");
symbol_long_float = sym_new(na_type);
setname(symbol_long_float, "LONG_FLOAT");
symbol_universal_fixed = sym_new(na_type);
setname(symbol_universal_fixed, "universal_fixed");
symbol_array_type = sym_new(na_array);
setname(symbol_array_type, "array_type");
symbol_discrete_type = sym_new(na_type);
setname(symbol_discrete_type, "discrete_type");
symbol_universal_integer_1 = sym_new(na_obj);
setname(symbol_universal_integer_1, "I:1");
symbol_any = sym_new(na_type);
setname(symbol_any, "any");
symbol_any_id = sym_new(na_obj);
root_type(symbol_any_id) = symbol_any;
setname(symbol_any_id, "any_id");
symbol_left = sym_new(na_in);
setname(symbol_left, "LEFT");
symbol_right = sym_new(na_in);
setname(symbol_right, "RIGHT");
symbol_boolean_type = sym_new(na_type);
setname(symbol_boolean_type, "boolean_type");
sym_op_enter(symbol_not, "not");
sym_op_enter(symbol_and, "and");
sym_op_enter(symbol_or, "or");
sym_op_enter(symbol_xor, "xor");
sym_op_enter(symbol_andthen, "andthen");
sym_op_enter(symbol_orelse, "orelse");
sym_op_enter(symbol_assign, ":=");
sym_op_enter(symbol_eq, "=");
sym_op_enter(symbol_ne, "/=");
sym_op_enter(symbol_in, "IN");
sym_op_enter(symbol_notin, "NOTIN");
symbol_order_type = sym_new(na_type);
setname(symbol_order_type, "order_type");
sym_op_enter(symbol_lt, "<");
sym_op_enter(symbol_le, "<=");
sym_op_enter(symbol_ge, ">=");
sym_op_enter(symbol_gt, ">");
symbol_numeric = sym_new(na_void);
setname(symbol_numeric, "numeric");
sym_op_enter(symbol_addu, "+u");
sym_op_enter(symbol_subu, "-u");
sym_op_enter(symbol_abs, "abs");
sym_op_enter(symbol_add, "+");
sym_op_enter(symbol_sub, "-");
sym_op_enter(symbol_mul, "*");
sym_op_enter(symbol_div, "/");
sym_op_enter(symbol_mod, "mod");
sym_op_enter(symbol_rem, "rem");
sym_op_enter(symbol_exp, "**");
sym_op_enter(symbol_cat, "&");
sym_op_enter(symbol_cat_cc, "&cc");
sym_op_enter(symbol_cat_ac, "&ac");
sym_op_enter(symbol_cat_ca, "&ca");
s = sym_new(na_op);
#ifdef IBM_PC
ORIG_NAME(s) = strjoin("any_op", "");
#else
ORIG_NAME(s) = "any_op";
#endif
sym_op_enter(symbol_modi, "modi");
sym_op_enter(symbol_remi, "remi");
sym_op_enter(symbol_addui, "+ui");
sym_op_enter(symbol_subui, "-ui");
sym_op_enter(symbol_absi, "absi");
sym_op_enter(symbol_addi, "+i");
sym_op_enter(symbol_subi, "-i");
sym_op_enter(symbol_muli, "*i");
sym_op_enter(symbol_divi, "/i");
sym_op_enter(symbol_addufl, "+ufl");
sym_op_enter(symbol_subufl, "-ufl");
sym_op_enter(symbol_absfl, "absfl");
sym_op_enter(symbol_addfl, "+fl");
sym_op_enter(symbol_subfl, "-fl");
sym_op_enter(symbol_mulfl, "*fl");
sym_op_enter(symbol_divfl, "/fl");
sym_op_enter(symbol_addufx, "+ufx");
sym_op_enter(symbol_subufx, "-ufx");
sym_op_enter(symbol_absfx, "absfx");
sym_op_enter(symbol_addfx, "+fx");
sym_op_enter(symbol_subfx, "-fx");
sym_op_enter(symbol_mulfx, "*fx");
sym_op_enter(symbol_divfx, "/fx");
sym_op_enter(symbol_mulfxi, "*fxi");
sym_op_enter(symbol_mulifx, "*ifx");
sym_op_enter(symbol_divfxi, "/fxi");
sym_op_enter(symbol_mulfli, "*fli");
sym_op_enter(symbol_mulifl, "*ifl");
sym_op_enter(symbol_divfli, "/fli");
sym_op_enter(symbol_expi, "**i");
sym_op_enter(symbol_expfl, "**fl");
symbol_exception = sym_new(na_exception);/* ?? check this */
symbol_constraint_error = sym_new (na_exception);
setname(symbol_constraint_error, "CONSTRAINT_ERROR");
symbol_numeric_error = sym_new(na_exception);
setname(symbol_numeric_error, "NUMERIC_ERROR");
symbol_program_error = sym_new(na_exception);
setname(symbol_program_error, "PROGRAM_ERROR");
symbol_storage_error = sym_new(na_exception);
setname(symbol_storage_error, "STORAGE_ERROR");
symbol_tasking_error = sym_new(na_exception);
setname(symbol_tasking_error, "TASKING_ERROR");
symbol_system_error = sym_new(na_exception);
setname(symbol_system_error, "SYSTEM_ERROR");
/*
* Printable characters are entered into SYMBTAB, as overloaded
* literals whose source name is the character between single quotes.
*/
{
int i;
char *s;
Symbol sy;
lmap = tup_new(2 * 128);
for (i = 0; i <= 127; i++ ) {
s = smalloc(4);
s[3] = '\0';
s[0] = '\'';
s[1] = i;
s[2] = '\'';
lmap[2 * i + 1] = s;
lmap[2 * i + 2] =(char *) i;
/* if (i>=32 && i<=126 ) -- all ascii chars entered in SYMBTAB */
sy = sym_new(na_literal);
ORIG_NAME(sy) = s;
}
literal_map(symbol_character) =(Set) lmap;
}
for (i = 0; p = char_names[i]; i++) {
if (p[0] == ' ')
break;
p1 = strchr(p, ' ');
if (p1 == p)
break;
sym = sym_new(na_constant);
TYPE_OF(sym) = symbol_character;
SIGNATURE(sym) =(Tuple) val_nodea1(atoi(p1));
name[0] = '\0';
strncat(name, p, p1 - p); /* extract string with name */
setname(sym, strjoin(name, "")); /* p1 points to original name */
}
s = sym_new(na_literal);
setname(s, "FALSE");
TYPE_OF(s) = symbol_boolean;
s = sym_new(na_literal);
setname(s, "TRUE");
TYPE_OF(s) = symbol_boolean;
{
char *litname;
lmap = tup_new(4);
litname = smalloc(6);
lmap[1] = strcpy(litname, "FALSE");
lmap[2] = (char *) 0;
litname = smalloc(5);
lmap[3] = strcpy(litname, "TRUE");
lmap[4] =(char *) 1;
literal_map(symbol_boolean) =(Set) lmap;
}
/* The only predefined aggregate is the one for string literals.*/
sym_new(na_aggregate);
/* Next four symbols introduced for maps incp_types, priv_types */
symbol_private = sym_new(na_type);
setname(symbol_private, "private");
symbol_limited_private = sym_new(na_type);
setname(symbol_limited_private, "limited_private");
symbol_limited = sym_new(na_type);
setname(symbol_limited, "limited");
symbol_incomplete = sym_new(na_type);
setname(symbol_incomplete, "incomplete");
/* the following symbols are used as markers by check_type in chapter 4 */
symbol_universal_type = sym_new(na_void);
setname(symbol_universal_type, "universal_type");
symbol_integer_type = sym_new(na_void);
setname(symbol_integer_type, "integer_type");
symbol_real_type = sym_new(na_void);
setname(symbol_real_type, "real_type");
symbol_composite_type = sym_new(na_void);
setname(symbol_composite_type, "composite_type");
symbol_equal_type = sym_new(na_void);
setname(symbol_equal_type, "equal_type");
/* new symbol definitions that are common with the code generator should */
/* be placed before this comment. */
/* 'task_block' is marker symbol used in expand.c - it need never be
* written out
*/
symbol_task_block = sym_new(na_void);
/* Initialize bounds of predefined types. */
/* Note that val_node is only called from this procedure, so that
* calling sequence can be changed if necessary; moreover the code
* should be put in this module, not in utilities
*/
/* set size of init_nodes.
* NOTE, must NOT make any new entries to init_nodes after
* doing assignment of tup_size below ds 24 sep 84
*/
init_nodes[0] = (char *)init_node_count;
#ifdef DEBUG
if (list_unit_0)
zpunit(0);
#endif
}
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_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;
}
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;
}
}
