/*
 * 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 "axqrp.h"
#include "genp.h"
#include "segmentp.h"
#include "ginterp.h"
#include "setp.h"
#include "bmainp.h"
#include "gutilp.h"
#include "dclmapp.h"
#include "libp.h"
#include "libfp.h"
#include "librp.h"
#include "glibp.h"
#include "miscp.h"
#include "gmiscp.h"
#include "smiscp.h"
#include "gnodesp.h"
#include "blibp.h"

#ifdef MAC_GWADA
#include "ShellInterface.h"
#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;

#ifdef MAC_GWADA
	ProgressBar(1);
#endif

	/*  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) {
			user_error("No subprogram in library");
			return FALSE;
		}
		else if (tup_size(to_check) == 1) {
			main_name = tup_frome(to_check);
			MAINunit  = unit_name_name(main_name);
		}
		else {
			user_error(
				  "Several subprograms in library please specify main from:");
			FORTUP(name = (char *), to_check, ft1);
				user_info(unit_name_name(name));
			ENDFORTUP(ft1);
			return FALSE;
		}
	}
	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 */
		user_error(strjoin(formatted_name(main_name),
		  " is not a valid main program."));
		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) {
		user_error("Missing units in library:");
		FORTUP(name = (char *), missing_units, ft1);
			user_info(formatted_name(name));
		ENDFORTUP(ft1);
		return FALSE;
	}
	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) {
		user_error("Circularity detected among these units:");
		for (i = 1; i <= n; i += 2) {
			delayed = (Tuple) DELAYED_MAP[i+1];
			FORTUP(delayed_unit = (int), delayed, ft1);
				user_info(formatted_name(pUnits[delayed_unit]->name));
			ENDFORTUP(ft1);
		}
		return FALSE;
	}

	/* 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)) {

#ifdef MAC_GWADA
			ProgressBar(1);
#endif

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

#ifdef MAC_GWADA
	ProgressBar(1);
#endif

	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(__FILE__, __LINE__, "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;
	/* 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) {
		user_error(strjoin(formatted_name(unit), " not present in library"));
		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 {
		user_error(strjoin("Cannot retrieve unit ", formatted_name(unit)));
		user_info(strjoin(" from file ", fname));
		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 */
	}
#ifdef MAC_GWADA
	ifile = ifopen(fname, "axq", "rb", 0);
#else
	ifile = ifopen(fname, "axq", "r", 0);
#endif
	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(__FILE__, __LINE__, "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;
}
