This is blib.c in view mode; [Download] [Up]
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#define GEN
#include "hdr.h"
#include "libhdr.h"
#include "vars.h"
#include "segment.h"
#include "gvars.h"
#include "ops.h"
#include "type.h"
#include "ifile.h"
#include "axqrprots.h"
#include "genprots.h"
#include "segmentprots.h"
#include "ginterprots.h"
#include "setprots.h"
#include "bmainprots.h"
#include "gutilprots.h"
#include "dclmapprots.h"
#include "libprots.h"
#include "libfprots.h"
#include "librprots.h"
#include "glibprots.h"
#include "miscprots.h"
#include "gmiscprots.h"
#include "smiscprots.h"
#include "gnodesprots.h"
#include "blibprots.h"
#ifdef vms
#define vms_BINDER
#endif
#ifdef vms_BINDER
/*
#include "adabind.h"
*/
#include descrip
struct dsc$descriptor_s unit_name_desc;
#endif
static void update_elaborate(char *);
static void main_code_segment();
static Tuple delayed_map_get(int);
static void delayed_map_put(int, Tuple);
static void delayed_map_undef(int);
static void add_code(char *);
static int needs_body_bnd(char *);
static int depth_level(char *);
static Tuple build_relay_sets(char *, int);
static void update_subunit_context(char *);
static int load_binding_unit(char *);
static char *read_binding_ais(char *, char *);
extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
extern int adacomp_option;
extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
extern Segment CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
extern IFILE *AXQFILE, *LIBFILE, *AISFILE, *STUBFILE;
/* variables used only by binder */
static Symbol mainunit_sym;
int binder(Tuple aisread_tup) /*;binder*/
{
/*
* BINDER checks the program library of a given main program for
* completeness. Missing modules are printed.
* Otherwise, idle_task and main_task are generated. idle_task calls
* the initialization procedures required to elaborate the various
* units in (one of) the order(s) prescribed by the language
*/
char *name, *body, *main_name, *s_name;
int prior, unit, name_num, delayed_unit;
Set elaborated, idle_precedes, precedes;
struct unit *pUnit;
Tuple missing_units, to_check, to_bind, u_slots, tup;
Tuple elaboration_table, compiled_units, delayed, s, u_rs;
Fortup ft1;
Forset fs1;
Unitdecl ud;
int i, n;
int is_interfaced_bind_unit_now;
#ifdef DEBUG
Tuple axq_needed; /* list of predefined units */
#endif
/* Reset global tuple of node and symbols for binder. */
seq_node_n = 0;
seq_node = tup_new(SEQ_NODE_INC);
seq_symbol_n = 0;
/* Miscelleanous variables needed for code generation */
LOCAL_REFERENCE_MAP = local_reference_map_new();
RELAY_SET = tup_new(0);
/*
* POSITION and PATCHES is stored in EMAP and is set implicitly when a new
* EMAP is created for a symbol and therefore is not needed here.
*
* POSITION = {};
* PATCHES = {};
*/
CURRENT_LEVEL = 0;
LAST_OFFSET = 0;
MAX_OFFSET = 0;
call_lib_unit = tup_new(0);
if (streq(MAINunit, "")) {
to_check = tup_new(0);
/* collect all possible main units i.e. all parameterless subprograms
* which are not proper bodies (subunits).
*/
for (i = 15; i <= unit_numbers; i++) {
struct unit *pUnit = pUnits[i];
if (pUnit->isMain && !streq("ma", unit_name_type(pUnit->name)))
to_check = tup_with(to_check,pUnit->name);
}
if (tup_size(to_check) == 0) {
#ifdef vms
if (adacomp_option)
user_error("No subprogram in library");
else {
LIB$SIGNAL(MSG_NOSUBPROG);
exit();
}
#else
user_error("No subprogram in library");
#endif
return FALSE;
}
else if (tup_size(to_check) == 1) {
main_name = tup_frome(to_check);
MAINunit = unit_name_name(main_name);
}
else {
#ifdef vms
if (adacomp_option) {
user_error(
"Several subprograms in library please specify main from:");
}
else {
LIB$SIGNAL(MSG_MANYMAIN);
unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
}
#else
user_error(
"Several subprograms in library please specify main from:");
#endif
FORTUP(name = (char *), to_check, ft1);
#ifdef vms
if (adacomp_option) {
user_info(unit_name_name(name));
}
else {
unit_name_desc.dsc$a_pointer = unit_name_name(name);
unit_name_desc.dsc$w_length =
strlen(unit_name_desc.dsc$a_pointer);
LIB$SIGNAL(MSG_UNITNAME, 1, &unit_name_desc);
}
#else
user_info(unit_name_name(name));
#endif
ENDFORTUP(ft1);
#ifdef vms
if (adacomp_option)
return FALSE;
else
exit();
#else
return FALSE;
#endif
}
}
else {
main_name = strjoin("su", MAINunit);
}
if (!load_binding_unit(main_name)) {
/* message cannot retrieve... already printed */
return FALSE;
}
update_elaborate(main_name);
ud = unit_decl_get(main_name);
mainunit_sym = ud->ud_unam;
if (NATURE(mainunit_sym) != na_procedure /* only procedures */
|| tup_size(SIGNATURE(mainunit_sym)) != 0) { /* without parameters */
#ifdef vms
if (adacomp_option) {
user_error(strjoin(formatted_name(main_name),
" is not a valid main program."));
}
else {
unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
unit_name_desc.dsc$a_pointer = formatted_name(main_name);
unit_name_desc.dsc$w_length = strlen(unit_name_desc.dsc$a_pointer);
LIB$SIGNAL(MSG_NOTMAIN, 1, &unit_name_desc);
exit();
}
#else
user_error(strjoin(formatted_name(main_name),
" is not a valid main program."));
#endif
return FALSE;
}
name = strjoin(MAINunit, "_idle_task");
/* The name of the binding unit is "ma" followed by the name */
/* In SETL unit_name was ['main_unit', name] */
/* Note that this may create a new unit */
unit_name = strjoin("ma", name);
unit_number_now = unit_number(unit_name);
lib_unit_put(unit_name, AISFILENAME);
/* Symbol table initialized with 'main_task_type' */
symbol_main_task_type = sym_new(na_task_type);
TYPE_OF(symbol_main_task_type) = symbol_main_task_type;
SIGNATURE(symbol_main_task_type) = tup_new(0);
ALIAS(symbol_main_task_type) = symbol_main_task_type;
ORIG_NAME(symbol_main_task_type) = "main_task_type";
DECLARED(symbol_main_task_type) = dcl_new(0);
TYPE_KIND(symbol_main_task_type) = TK_WORD;
TYPE_SIZE(symbol_main_task_type) = su_size(TK_WORD);
#ifdef TBSL
/* REFERENCE_MAP = {['main_task_type', [1, 47]]}; */
S_SEGMENT(symbol_main_task_type) = 1;
S_OFFSET(symbol_main_task_type) = 47;
#endif
MISC(symbol_main_task_type) = (char *)TRUE;
/* Here we duplicate that part of the code from init_gen needed
* when starting a new unit
*
* Set initial unit_slots map to null value
* assume unit_number_now gives curent unit number; the correct
* assignment of this may best be done elsewhere
*/
tup = tup_new(5);
for (i = 1; i <= 5; i++)
tup[i] = (char *) tup_new(0);
unit_slots_put(unit_number_now, tup);
to_check = tup_new1(main_name);
idle_precedes = set_new1((char *) unit_numbered(main_name));
to_bind = tup_new(0);
missing_units = tup_new(0);
compiled_units = tup_new(unit_numbers);
for (i = 1; i <= unit_numbers; i++)
compiled_units[i] = pUnits[i]->libUnit;
/* check that any needed unit has been compiled.
*
* All units needed (directly or indirectly) by main_name are checked.
* The order in which these checks are performed is unimportant. The
* ordering map 'precedes' has been loaded from library, for later use
* in a topological sort.
*
* All units needed, but not referenced by with clauses (typically
* package bodies, procedure bodies and subunits) are noted into
* idle_precedes to make later idle_task depend on them, in order to
* suppress the binding unit if they are recompiled.
*/
while (tup_size(to_check)!= 0) {
/* always load the item at the front of the queue so that specs are
* read before their bodies.
* TBSL: this is due to the fact that the body sometimes contains
* info that is not in the spec(e.g. ASSOC_SYMBOLS) and since they share
* the same symbol the info would be overridden by the spec if the spec
* was read last.
*/
name = tup_fromb(to_check);
if (is_generic(name))
continue;
/* Check to see whether a package specification requires a body and
* if yes, that the body has been compiled.
*/
if (streq(unit_name_type(name), "sp")
|| streq(unit_name_type(name), "bo")) {
/* AXQ needed */
if (!load_binding_unit(name))
missing_units = tup_with(missing_units, name);
else
update_elaborate(name);
}
/* Collect the stubs of the current unit. */
s = stubs(name);
/*
* to_check +:= s;
* missing_units +:= s - compiled_units;
* idle_precedes +:= s;
*/
FORTUP(s_name = (char *), s, ft1);
if (!tup_memstr(s_name, to_check))
to_check = tup_with(to_check, s_name);
if (!tup_memstr(s_name, compiled_units))
missing_units = tup_with(missing_units, s_name);
idle_precedes = set_with(idle_precedes,
(char *) unit_numbered(s_name));
ENDFORTUP(ft1);
if (streq(unit_name_type(name), "sp")) {
body = strjoin("bo", unit_name_name(name));
if (tup_memstr(body, compiled_units)) {
to_check = tup_with(to_check, body);
idle_precedes = set_with(idle_precedes,
(char *)unit_numbered(body));
}
else if (needs_body_bnd(name))
missing_units = tup_with(missing_units, body);
}
else if (streq(unit_name_type(name), "ss")) {
/* Suprogram body must be present.*/
body = strjoin("su", unit_name_name(name));
if (tup_memstr(body, compiled_units) && load_binding_unit(body)) {
to_check = tup_with(to_check, body);
update_elaborate(body);
}
else
missing_units = tup_with(missing_units, body);
idle_precedes = set_with(idle_precedes,
(char *) unit_numbered(body));
}
else if (streq(unit_name_type(name), "su")) {
if (is_subunit(name)) { /* no previous unit spec, of course. */
if (load_binding_unit(name))
update_elaborate(name);
}
else if (!tup_memstr(name, compiled_units)) /* no previous spec */
missing_units = tup_with(missing_units, name);
}
/* Check the units indicated by visibility lists (precedes).
*
* loop forall prior in precedes{name} | prior notin to_bind do
* to_check with= prior;
* end loop forall;
*/
precedes = precedes_map_get(name);
FORSET(prior = (int), precedes, fs1);
if (!tup_memstr(pUnits[prior]->name, to_bind))
to_check = tup_with(to_check, pUnits[prior]->name);
ENDFORSET(fs1);
if (is_subunit(name) && tup_memstr(name, compiled_units))
update_subunit_context(name);
to_bind = tup_with(to_bind, name);
} /* end while */
/* If compilation units are missing, report them and return. */
if (tup_size(missing_units) != 0) {
#ifdef vms
if (adacomp_option) {
user_error("Missing units in library:");
}
else {
LIB$SIGNAL(MSG_MISSUNIT);
unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
}
#else
user_error("Missing units in library:");
#endif
FORTUP(name = (char *), missing_units, ft1);
#ifdef vms
if (adacomp_option) {
user_info(formatted_name(name));
}
else {
unit_name_desc.dsc$a_pointer = formatted_name(name);
unit_name_desc.dsc$w_length =
strlen(unit_name_desc.dsc$a_pointer);
LIB$SIGNAL(MSG_UNITNAME, 1, &unit_name_desc);
}
#else
user_info(formatted_name(name));
#endif
ENDFORTUP(ft1);
#ifdef vms
if (adacomp_option)
return FALSE;
else
exit();
#else
return FALSE;
#endif
}
if (tup_size(interfaced_procedures) != 0) {
int i, j, n, m;
n = tup_size(interfaced_procedures);
m = tup_size(to_bind);
for (i = 1; i <= n; i += 2) {
for (j = 1; j <= m; j++) {
if((int)interfaced_procedures[i] == unit_numbered(to_bind[j])) {
/* the field of is_main which is usualy always 0 for a
* binding unit is set to 1 in this case to specify that
* this binding unit calls an interfaced subprogram
*/
pUnits[unit_number_now]->isMain = 1;
is_interfaced_bind_unit_now = 1;
break;
}
else {
is_interfaced_bind_unit_now = 0;
}
}
}
}
else {
is_interfaced_bind_unit_now = 0;
}
if (is_interfaced_bind_unit_now) geninter(to_bind);
/*
* call_lib_unit is built in an order consistent with the rules for
* the elaboration of library units.
* The algorithm tries to use the compilation order, unless some unit
* depends on a not yet elaborated unit. In that case, it is appended
* to a list of units depending on one of the not yet elaborated units
* When this unit is elaborated, one tries again to elaborate units
* depending on it.
* If a unit depends on one of its own delayed units, it is a
* circularity
* elaborated: set of already elaborated units
* delayed : map from units to the list of dependant units.
*/
/* Use the compilation order */
/* TBSL: for now we elaborate all units even if we don't use them.
* a better scheme is to have elaboration_table be only units we need.
*/
elaboration_table = tup_copy(compilation_table);
elaborated = set_new1((char *)0);
DELAYED_MAP = tup_new(0);
#ifdef DEBUG
axq_needed = tup_new(0);
#endif
while (tup_size(elaboration_table) != 0) {
name_num = (int) tup_fromb(elaboration_table);
name = pUnits[name_num]->name;
if (is_generic(name) || is_subunit(name)) {
/* Generics are not elaborated
* subunits are elaborated from the parent
*/
elaborated = set_with(elaborated, (char *) name_num);
}
else if (!tup_memstr(name, to_bind)) {
/* Don't need this unit */
}
else if (set_subset(precedes_map_get(name), elaborated)) {
/* May elaborate this unit now */
add_code(name);
elaborated = set_with(elaborated, (char *) name_num);
#ifdef TBSL
if (name_num < 11) { /* predef unit */
#endif
/*
* if (name in domain delayed) then
* -- Retry units depending on this one
* elaboration_table := delayed(name) + elaboration_table;
* delayed(name) := OM;
* end if;
*/
n = tup_size(DELAYED_MAP);
for (i = 1; i <= n; i += 2) {
if (DELAYED_MAP[i] == (char *)name_num) {
/* Retry units depending on this one */
elaboration_table=
tup_add(delayed_map_get(name_num), elaboration_table);
delayed_map_undef(name_num);
break;
}
}
}
else {
/* Depends on a not yet elaborated unit => delay elaboration */
precedes = precedes_map_get(name);
unit = (int) set_arb(set_diff(precedes, elaborated));
/* delayed(unit) = (delayed(unit) ? []) with name; */
delayed = delayed_map_get(unit);
if (delayed == (Tuple)0)
delayed_map_put(unit, tup_new1((char *) name_num));
else
delayed_map_put(unit, tup_with(delayed, (char *)name_num));
/* TBSL: This code to be removed when predef is handled correctly */
if (name_num < num_predef_units) {
elaboration_table =
tup_add(tup_new1((char *)unit), elaboration_table);
}
}
} /* end while */
/* Check for circularity among units */
n = tup_size(DELAYED_MAP);
if (n != 0) {
#ifdef vms
if (adacomp_option)
user_error("Circularity detected among these units:");
else {
LIB$SIGNAL(MSG_CIRCULAR);
unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
}
#else
user_error("Circularity detected among these units:");
#endif
for (i = 1; i <= n; i += 2) {
delayed = (Tuple) DELAYED_MAP[i+1];
FORTUP(delayed_unit = (int), delayed, ft1);
#ifdef vms
if (adacomp_option)
user_info(formatted_name(pUnits[delayed_unit]->name));
else {
unit_name_desc.dsc$a_pointer =
formatted_name(pUnits[delayed_unit]->name);
unit_name_desc.dsc$w_length =
strlen(unit_name_desc.dsc$a_pointer);
LIB$SIGNAL(MSG_UNITNAME, 1, &unit_name_desc);
}
#else
user_info(formatted_name(pUnits[delayed_unit]->name));
#endif
ENDFORTUP(ft1);
}
#ifdef vms
if (adacomp_option)
return FALSE;
else
exit();
#else
return FALSE;
#endif
}
/* Everything is OK: build idle and main task */
#ifdef TBSL
axqfiles_read = tup_with(axqfiles_read, AXQfile);
aisread_tup(1) with= unit_name;
#endif
CURRENT_DATA_SEGMENT = 1;
CURRENT_CODE_SEGMENT = 1;
#ifdef MACHINE_CODE
if (list_code) {
to_gen(" ");
to_gen(" ");
to_gen_unam("============== UNIT : ", formatted_name(unit_name),
" ==============");
to_gen(" ");
to_gen("--- Idle task ---");
to_gen_int(" data slot # ", CURRENT_DATA_SEGMENT);
to_gen_int(" code slot # ", CURRENT_CODE_SEGMENT);
to_gen(" ");
}
#endif
u_slots = tup_new(5);
#ifdef DEBUG
if(tup_size(axq_needed)) { /* binding requiring predef data segments */
tup = read_predef_axq(axq_needed);
u_slots[SLOTS_DATA] = (char *)tup_with((Tuple) tup[1],
(char *)CURRENT_DATA_SEGMENT);
u_slots[SLOTS_CODE] = (char *)tup_with((Tuple) tup[2],
(char *)CURRENT_CODE_SEGMENT);
}
else { /* library option or no predefined unit needed */
u_slots[SLOTS_DATA] = (char *)tup_new1((char *)CURRENT_DATA_SEGMENT);
u_slots[SLOTS_CODE] = (char *)tup_new1((char *)CURRENT_CODE_SEGMENT);
}
#else
u_slots[SLOTS_DATA] = (char *)tup_new1((char *)CURRENT_DATA_SEGMENT);
u_slots[SLOTS_CODE] = (char *)tup_new1((char *)CURRENT_CODE_SEGMENT);
#endif
u_slots[SLOTS_EXCEPTION] = (char *)tup_new(0);
u_slots[SLOTS_DATA_BORROWED] = (char *)tup_new(0);
u_slots[SLOTS_CODE_BORROWED] = (char *)tup_new(0);
unit_slots_put(unit_number_now, u_slots);
precedes_map_put(unit_name, idle_precedes);
DATA_SEGMENT = DATA_SEGMENT_MAIN;
/* Compute the relay sets of subunits:
*
* loop forall name in to_bind | not is_subunit(name) do
* [-, u_rs] = build_relay_sets(name, 1);
* if (u_rs !== []) then
* COMPILER_ERROR ("Relay set at level 1 in "+formatted_name(name));
* if debug_flag then
* gen_trace("BINDER", u_rs);
* end if;
* end if;
* end loop;
*/
FORTUP(name = (char *), to_bind, ft1);
if (!is_subunit(name)) {
tup = build_relay_sets(name, 1);
u_rs = (Tuple) tup[2];
if (tup_size(u_rs) != 0) {
compiler_error (
strjoin("Relay set at level 1 in ", formatted_name(name)));
}
}
ENDFORTUP(ft1);
main_code_segment();
/* Update library */
/* OWNED_SLOTS(unit_name)(2) with= CURRENT_CODE_SEGMENT; */
u_slots[SLOTS_CODE] = (char *)tup_with((Tuple) u_slots[SLOTS_CODE],
(char *)CURRENT_CODE_SEGMENT);
#ifdef TBSL
LIB_UNIT (unit_name) = [NODE_COUNT, '' , AXQfile]
+ OWNED_SLOTS(unit_name);
PRE_COMP (unit_name) = idle_precedes;
COMP_DATE(unit_name) = {
[name, COMP_DATE(name)(name)] :
name in idle_precedes * compiled_units };
today = DATE;
COMP_DATE(unit_name)(unit_name) =
[today(9..17), today(20..27), #aisread_tup(1)];
#endif
/* DATA_SEGMENT_MAP(CURRENT_DATA_SEGMENT) = DATA_SEGMENT; */
DATA_SEGMENT_MAP =
segment_map_put(DATA_SEGMENT_MAP, CURRENT_DATA_SEGMENT, DATA_SEGMENT);
compilation_table = tup_with(compilation_table, (char *)unit_number_now);
pUnit = pUnits[unit_number_now];
pUnit->aisInfo.numberSymbols = seq_symbol_n;
pUnit->aisInfo.symbols = (char *) tup_new(seq_symbol_n);
#ifdef MACHINE_CODE
if (list_code) print_data_segment();
#endif
return TRUE;
}
static void update_elaborate(char *name) /*;update_elaborate*/
{
Set precedes;
Tuple pragma_tup;
char *unam;
int unit, name_num;
Fortup ft1;
name_num = unit_numbered(name);
pragma_tup = (Tuple) pUnits[name_num]->aisInfo.pragmaElab;
precedes = (Set) precedes_map_get(name);
FORTUP(unam = (char *), pragma_tup, ft1);
unit = unit_numbered(unam);
/* if the pragma names a unit which is not explicitly present (unit is 0
* or the body may be obsolete) ignore it
*/
if (unit != 0) {
if (streq(pUnits[unit]->libInfo.obsolete, "ok"))
precedes = set_with(precedes, (char *) unit);
}
ENDFORTUP(ft1);
precedes_map_put(name, precedes);
}
static void main_code_segment() /*;main_code_segment */
{
Node call_node;
Symbol loop_name;
Segment task_id;
Symbol handler1, handler2, handler3;
Fortup ft1;
/* check that symbol_main_task_type defined */
if (symbol_main_task_type == (Symbol)0)
chaos("glib.c main_code_segment symbol_main_task_type not defined");
CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
gen_c(I_NOP, "no handling; go to task trap");
gen(I_NOP);
gen_ic(I_TERMINATE, 6, "task trap in case of dead-lock");
symbol_main_task = sym_new(na_obj);
ORIG_NAME(symbol_main_task) = strjoin("main_task", "");
new_symbol(symbol_main_task, na_obj, symbol_main_task_type, (Tuple)0,
(Symbol)0);
task_id = segment_new(SEGMENT_KIND_DATA, 1);
segment_put_word(task_id, 0);
next_global_reference_segment(symbol_main_task, task_id);
gen(I_ENTER_BLOCK);
gen_s(I_CREATE_TASK, symbol_main_task_type);
gen_ks(I_POP, kind_of(symbol_main_task_type), symbol_main_task);
gen(I_ACTIVATE);
loop_name = new_unique_name("endless_loop");
gen_s(I_LABEL, loop_name);
gen_s(I_JUMP, loop_name);
gen(I_EXIT_BLOCK);
gen(I_END); /* flush peep-hole buffer */
/*CODE_SEGMENT_MAP(CURRENT_CODE_SEGMENT) = CODE_SEGMENT;*/
CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
CODE_SEGMENT);
CURRENT_CODE_SEGMENT = MAIN_CS;
#ifdef MACHINE_CODE
if (list_code) {
to_gen(" ");
to_gen(" ");
to_gen("--- Main task ---");
to_gen_int(" code slot # ", CURRENT_CODE_SEGMENT);
to_gen(" ");
}
#endif
CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
gen(I_LEAVE_BLOCK);
gen(I_RAISE);
gen_ic(I_TERMINATE, 5, "never used");
gen(I_ENTER_BLOCK);
gen_ic(I_END_ACTIVATION, 1, "Ok");
handler1 = new_unique_name("handler");
gen_s(I_INSTALL_HANDLER, handler1);
gen(I_ENTER_BLOCK);
FORTUP(call_node = (Node), call_lib_unit, ft1);
if (N_KIND(call_node) == as_activate_spec) {
gen_ks(I_PUSH, mu_word, N_UNQ(N_AST1(call_node)));
gen(I_LINK_TASKS_DECLARED);
gen(I_ACTIVATE);
}
else {
gen_s(I_CALL, N_UNQ(N_AST1(call_node)));
}
ENDFORTUP(ft1);
handler2 = new_unique_name("handler");
gen_s(I_INSTALL_HANDLER, handler2);
gen_s(I_CALL, mainunit_sym);
gen(I_EXIT_BLOCK);
handler3 = new_unique_name("end_handler");
gen_s(I_JUMP, handler3);
gen_s(I_LABEL, handler2);
gen_ic(I_TERMINATE, 4, "unhandled exception in main");
gen_s(I_LABEL, handler3);
gen(I_EXIT_BLOCK);
handler3 = new_unique_name("end_handler");
gen_s(I_JUMP, handler3);
gen_s(I_LABEL, handler1);
gen_ic(I_TERMINATE, 3, "exception in library unit elaboration");
gen_s(I_LABEL, handler3);
gen_ic(I_TERMINATE, 5, "library tasks are completed");
gen_ic(I_DATA, 0, "size of local objects");
gen(I_END); /* flush peep-hole buffer */
/*CODE_SEGMENT_MAP(CURRENT_CODE_SEGMENT) = CODE_SEGMENT;*/
CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
CODE_SEGMENT);
}
static Tuple delayed_map_get(int unum) /*;delayed_map_get*/
{
int i, n;
n = tup_size(DELAYED_MAP);
for (i = 1; i <= n; i += 2) {
if (DELAYED_MAP[i] == (char *)unum)
return (Tuple) DELAYED_MAP[i+1];
}
return (Tuple)0;
}
static int needs_body_bnd(char *name) /*;needs_body */
{
Unitdecl ud;
Tuple tup;
Symbol unit_unam;
ud = unit_decl_get(name);
/* A spec which is obsolete needs no body */
if (ud == (Unitdecl)0) return FALSE;
unit_unam = ud->ud_unam;
tup = (Tuple) MISC(unit_unam);
return ((int)tup[2] != 0);
}
static void delayed_map_put(int unum, Tuple ntup) /*;delayed_map_put*/
{
int i, n;
n = tup_size(DELAYED_MAP);
for (i = 1; i <= n; i += 2) {
if (DELAYED_MAP[i] == (char *) unum) {
DELAYED_MAP[i+1] = (char *) ntup;
return;
}
}
DELAYED_MAP = tup_exp(DELAYED_MAP, n + 2);
DELAYED_MAP[n+1] = (char *) unum;
DELAYED_MAP[n+2] = (char *) ntup;
}
static void delayed_map_undef(int unum) /*;delayed_map_undef*/
{
int i, n;
n = tup_size(DELAYED_MAP);
for (i = 1; i <= n; i += 2) {
if (DELAYED_MAP[i] == (char *) unum) {
DELAYED_MAP[i] = DELAYED_MAP[n-1];
DELAYED_MAP[i+1] = DELAYED_MAP[n];
DELAYED_MAP[0] = (char *) (n-2);
return;
}
}
}
static void add_code(char *name) /*;add_code*/
{
/*
* Adds to call_lib_unit the calls required to elaborate packages.
* Library subprograms never need elaboration.
* Subunits are elaborated in the parent unit at the location of the
* correponding stub.
*/
Unitdecl ud;
Symbol unit_unam;
Node act_node;
char *unit_kind, *body;
int has_body, i;
/* Late generic instantiations : TBSL */
unit_kind = unit_name_type(name);
/* elaboration only needed for packages */
if (!streq(unit_kind, "sp") && !streq(unit_kind, "bo")) return;
ud = unit_decl_get(name);
unit_unam = ud->ud_unam;
if (streq(unit_kind, "sp")) {
call_lib_unit = tup_with(call_lib_unit, (char *) new_call_node(
assoc_symbol_get(unit_unam, INIT_SPEC), tup_new(0), symbol_none));
body = strjoin("bo", unit_name_name(name));
has_body = FALSE;
for (i = 1; i <= unit_numbers; i++)
if (streq(body, pUnits[i]->name)) {
has_body = TRUE;
break;
}
if (lib_package_with_tasks(unit_unam) /* spec declares tasks */
&& !has_body) { /* but has no body */
act_node = new_node(as_activate_spec);
N_AST1(act_node) = new_name_node(assoc_symbol_get(unit_unam,
INIT_TASKS));
call_lib_unit = tup_with(call_lib_unit, (char *) act_node);
}
}
else if (streq(unit_kind, "bo")) {
call_lib_unit = tup_with(call_lib_unit, (char *) new_call_node(
assoc_symbol_get(unit_unam, INIT_BODY), tup_new(0), symbol_none));
}
}
static int depth_level(char *stub_name) /*;depth_level*/
{
/* calculate the current nesting depth of the subunit by trailing down its
* parent chain until its ancestor os reached.
*/
int level, parent;
char *s_name;
level = 1;
s_name = stub_name;
while (1) {
parent = stub_parent_get(s_name);
if (parent != 0) {
s_name = pUnits[parent]->name;
level++;
}
else {
break;
}
}
return level;
}
static Tuple build_relay_sets(char *unit, int depth) /*;build_relay_sets*/
{
/*
* This procedure computes the relay sets for the subunits of unit.
* Yield the relay tables of all (direct or indirect) subunits of unit.
* Depth is the level of imbrication ofsubunits (1 if unit is not a
* subunit).
* u_xxx stands for unit xxx
* s_xxx stands for subunit xxx
* sl stands for (relay) slot
* rs stands for relay set
*/
Tuple save_relay_set, save_local_reference_map;
Tuple s_rs, u_rs, stubs_tup, s_table, return_tup;
Tuple stubtup, tup;
Stubenv ev;
struct unit *pUnit;
int u_sl, s_sl, offset, seg_num, si;
Symbol name;
Fortup ft1, ft2;
char *s_name;
/******
save_local_reference_map = LOCAL_REFERENCE_MAP;
save_relay_set = RELAY_SET;
[-,-,-,-,-,-,[u_sl,LOCAL_REFERENCE_MAP]] = LIB_UNIT(unit);
if (is_subunit(unit)) {
[-,-,-,-,-,-,-,RELAY_SET,DANGLING_RELAY_SETS] = STUB_ENV(unit);
DATA_SEGMENT += DANGLING_RELAY_SETS;
}
else {
RELAY_SET = [];
}
********/
save_local_reference_map = tup_copy(LOCAL_REFERENCE_MAP);
save_relay_set = tup_copy(RELAY_SET);
pUnit = pUnits[unit_numbered(unit)];
u_sl = (int)pUnit->libInfo.currCodeSeg;
LOCAL_REFERENCE_MAP = tup_copy((Tuple) pUnit->libInfo.localRefMap);
if (is_subunit(unit) && !is_generic(unit)) {
si = stub_numbered(unit);
stubtup = (Tuple) stub_info[si];
ev = (Stubenv) stubtup[2];
RELAY_SET = tup_copy(ev->ev_relay_set);
DANGLING_RELAY_SETS = tup_copy(ev->ev_dangling_relay_set);
FORTUP(seg_num = (int), DANGLING_RELAY_SETS, ft1);
segment_put_int(DATA_SEGMENT, seg_num);
ENDFORTUP(ft1);
}
else {
RELAY_SET = tup_new(0);
}
/******
loop forall s_name in stubs(unit) | #s_name = depth+2 do
[s_sl, s_rs] = build_relay_sets(s_name, depth+1);
s_table = [reference_of(name)(2): name in s_rs];
DATA_SEGMENT += [s_sl, #s_table] + s_table;
end loop;
*****/
stubs_tup = stubs(unit);
FORTUP(s_name = (char *), stubs_tup, ft1);
if (depth_level(s_name) != depth+1) continue;
tup = build_relay_sets(s_name, depth+1);
s_sl = (int) tup[1];
s_rs = (Tuple) tup[2];
s_table = tup_new(0);
FORTUP(name = (Symbol), s_rs, ft2);
reference_of(name);
s_table = tup_with(s_table, (char *) REFERENCE_OFFSET);
ENDFORTUP(ft2);
segment_put_int(DATA_SEGMENT, s_sl);
segment_put_int(DATA_SEGMENT, tup_size(s_table));
FORTUP(offset = (int), s_table, ft2);
segment_put_int(DATA_SEGMENT, offset);
ENDFORTUP(ft2);
ENDFORTUP(ft1);
/******
u_rs = RELAY_SET;
RELAY_SET = save_relay_set;
LOCAL_REFERENCE_MAP = save_local_reference_map;
return [u_sl, u_rs];
*****/
u_rs = tup_copy(RELAY_SET);
RELAY_SET = save_relay_set;
LOCAL_REFERENCE_MAP = save_local_reference_map;
return_tup = tup_new(2);
return_tup[1] = (char *) u_sl;
return_tup[2] = (char *) u_rs;
return return_tup;
}
static void update_subunit_context(char *subunit) /*;update_subunit_context*/
{
Set stub_context, precedes;
char *ancestor_body;
int ancestor_num, unum, subunit_num;
Forset fs1;
int has_ancestor, i;
/* Add the library units mentioned in the context clause for the subunit
* to the precedes map for the ancestor unit of the stub since all the units
* in the context clause need to be elaborated before the ancestor.
*/
subunit_num = unit_numbered(subunit);
stub_context = precedes_map_get(subunit);
/* if the unit has not been loaded return */
if (stub_context == (Set)0) return;
ancestor_body = strjoin("bo", stub_ancestor(subunit));
/* determine if the ancestor unit is package or subprogram */
has_ancestor = FALSE;
for (i = 1; i <= unit_numbers; i++)
if (streq(ancestor_body, pUnits[i]->libUnit)) {
has_ancestor = TRUE;
break;
}
if (!has_ancestor)
ancestor_body = strjoin("su", stub_ancestor(subunit));
ancestor_num = unit_numbered(ancestor_body);
precedes = precedes_map_get(ancestor_body);
FORSET(unum = (int), stub_context, fs1);
/* add in units that were in context clause of subunit so exclude
* subunits which happen to be in the PRE_COMP field of this subunit.
*/
if (!is_subunit(pUnits[unum]->name) && unum != ancestor_num)
precedes = set_with(precedes, (char *)unum);
ENDFORSET(fs1);
precedes_map_put(ancestor_body, precedes);
}
static int load_binding_unit(char *unit) /*;load_binding_unit*/
{
char *fname;
int file_retrieved;
Unitdecl ud;
#ifdef vms_BINDER
struct dsc$descriptor_s unit_name_desc;
#endif
/* When binding is done load the necessary units if they are not loaded
* already. However, when a unit is to be loaded use read_binding_ais so
* that only the absolute necessary components of the ais are read.
*/
fname = lib_unit_get(unit);
if (fname == (char *)0) {
#ifdef vms
if (adacomp_option)
user_error(strjoin(formatted_name(unit)," not present in library"));
else {
unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
unit = formatted_name(unit);
unit_name_desc.dsc$a_pointer = unit;
unit_name_desc.dsc$w_length = strlen(unit);
LIB$SIGNAL(MSG_NOTINLIB, 1, &unit_name_desc);
LIB$SIGNAL(MSG_BINDABORT);
}
#else
user_error(strjoin(formatted_name(unit), " not present in library"));
#endif
return FALSE;
}
else if (in_aisunits_read(unit)) {
file_retrieved = TRUE;
}
else {
file_retrieved = (read_binding_ais(fname, unit) != (char *)0);
if (is_subunit(unit)) read_stub(lib_unit_get(unit), unit, "st2");
}
if (file_retrieved && (ud = unit_decl_get(unit)) != (Unitdecl)0) {
return TRUE;
}
else {
#ifdef vms
if (adacomp_option) {
user_error(strjoin("Cannot retrieve unit ", formatted_name(unit)));
user_info(strjoin(" from file ", fname));
}
else {
unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
unit = formatted_name(unit);
unit_name_desc.dsc$a_pointer = unit;
unit_name_desc.dsc$w_length = strlen(unit);
LIB$SIGNAL(MSG_RETRIEVE, 1, &unit_name_desc);
LIB$SIGNAL(MSG_BINDABORT);
}
#else
user_error(strjoin("Cannot retrieve unit ", formatted_name(unit)));
user_info(strjoin(" from file ", fname));
#endif
return FALSE;
}
}
static char *read_binding_ais(char *fname, char *uname) /*;read_binding_ais*/
{
long rec, genoff;
int fnum, unum, n, nodes, symbols, i, is_main_unit;
Tuple symptr, tup;
struct unit *pUnit;
char *funame, *retrieved ;
Unitdecl ud;
IFILE *ifile;
Symbol sym;
char *lname, *tname;
int is_predef; /* set when reading predef file */
/* This is a modified version of read_ais, which reads only the neccesary
* items needed for binding. All other information is skipped.
*/
retrieved = (char *)0;
is_predef = streq(fname, "0");
if (is_predef) {
fname = "predef" ;
lname= libset(PREDEFNAME);/* use predefined library */
}
ifile = ifopen(fname, "axq", "r", "a", iot_ais_r, 0);
if (is_predef) {
tname= libset(lname); /* restore library name */
}
for (rec = read_init(ifile); rec != 0; rec = read_next(ifile, rec)) {
funame = getstr(ifile, "unit-name");
if (uname != (char *)0 && streq(uname, funame) == 0) continue;
fnum = getnum(ifile, "unit-number");
unum = unit_number(funame);
if (unum != fnum)
chaos("read_ais sequence number error");
genoff = getlong(ifile, "code-gen-offset");
is_main_unit = streq(unit_name_type(funame), "ma");
if (!is_main_unit) { /* read only if NOT main unit (it has no ais info*/
symbols = getnum(ifile, "seq-symbol-n");
nodes = getnum(ifile, "seq-node-n");
pUnit = pUnits[unum];
symptr = (Tuple)pUnit->aisInfo.symbols;
if (symptr == (Tuple)0) { /* if tuple not yet allocated */
symptr = tup_new(symbols);
pUnit->aisInfo.symbols = (char *) symptr;
}
/* ELABORATE PRAGMA INFO */
n = getnum(ifile, "pragma-info-size");
tup = tup_new(n);
for (i = 1; i <= n; i++) {
tup[i] = getstr(ifile, "pragma-info-value");
}
pUnit->aisInfo.pragmaElab = (char *)tup;
/* UNIT_DECL */
ud = unit_decl_new();
pUnit->aisInfo.unitDecl = (char *)ud;
sym = getsym(ifile, "ud-unam");
ud->ud_unam = sym;
ud->ud_useq = S_SEQ(sym);
ud->ud_unit = S_UNIT(sym);
get_unit_unam(ifile, sym);
aisunits_read = tup_with(aisunits_read, funame);
}
retrieved = funame;
break;
}
ifclose(ifile);
return retrieved;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.