/*
 * 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 "vars.h"
#include "segment.h"
#include "gvars.h"
#include "set.h"
#include "segment.h"
#include "dbx.h"
#include "misc.h"
#include "gmisc.h"
#include "smisc.h"
#include "gutil.h"
#include "init.h"

static short nature_root_type(Symbol);

//extern Tuple segment_map_new(), segment_map_put();
//extern Segment segment_map_get();
//extern Segment	CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;

/* create dummy entry for p (np is string with name of p)
 * and call chaos if p is called
 */
#define undone(p, np) p() { chaos(strjoin(np, " not implemented")); }

int ada_bool(int x)												/*;ada_bool*/
{
	return (x != 0 ? 1 : 0) ;
}

int assoc_symbol_exists(Symbol sym, int aname)			/*;assoc_symbol_exists*/
{
	/* return TRUE if assoc_symbol_get would succeed, FALSE otherwise */

	Tuple	tup;

	tup = ASSOCIATED_SYMBOLS(sym);
	if (tup == (Tuple)0)
		return FALSE;
	else
		return (tup[aname] != (char *)0);
}

Symbol assoc_symbol_get(Symbol sym, int aname)			/*;assoc_symbol_get*/
{
	/* Enter asym as associated symbol of symbol sym. Aname is code
	 * definining position in tuple of associated symbols. The tuple
	 * is allocated if not already defined 
	 */

	Tuple	tup;

	tup = ASSOCIATED_SYMBOLS(sym);
	if (tup == (Tuple)0)	/* if not allocated*/
		chaos(__FILE__, __LINE__, "assoc_symbol_get: tuple not allocated");
	if (tup_size(tup)<aname)
		chaos(__FILE__, __LINE__, "associate_symbol_get: index out of range");
	if (tup[aname] == (char *)0)
		chaos(__FILE__, __LINE__, "assoc_symbol_get: symbol not present");
	return (Symbol) tup[aname];
}

void assoc_symbol_put(Symbol sym, int aname, Symbol asym) /*;assoc_symbol_put*/
{
	/* Enter asym as associated symbol of symbol sym. Aname is code
	 * definining position in tuple of associated symbols. The tuple
	 * is allocated if not already defined 
	 */

	Tuple	tup;

	tup = ASSOCIATED_SYMBOLS(sym);
	if (tup == (Tuple)0) { /* if need new tuple */
		/* allocate three entries for now, should allocate proper count later */
		tup = tup_new(3);
		tup[1] = (char *)0;
		tup[2] = (char *)0;
		tup[3] = (char *)0;
	}
	if (tup_size(tup) < aname)
		chaos(__FILE__, __LINE__, "associate_symbol_put: index out of range");
	tup[aname] = (char *) asym;
	ASSOCIATED_SYMBOLS(sym) = tup;
}

#ifdef DEBUG
/* Calls to COMPILER_ERROR in SETL are translated to calls to
 * commpiler_error in C. Where the SETL version builds up a string
 * the C version adds a suffix to indicate argument type. For example
 * compiler_error_n(s, n) to pass node. The case compiler_error_k is
 * used to pass node for which the SETL version has
 *	COMPILER_ERROR(s  + str N_KIND(node)
 * This is written in C as
 *	compiler_error_k(s, node)
 * These are defined for DEBUG (base) version only. In the export version,
 * they are redefined as macros (in ghdr.c) to call procedure
 * exit_internal_error().
 */

void compiler_error_k(char *s, Node node) 				/*;compiler_error_k*/
{
	printf("compiler error: %s\n", s); 
	zpnod(node);
	errors++;
	chaos(__FILE__, __LINE__, "compiler_error_k");
}

void compiler_error_c(char *s, Tuple t)					/*;compiler_error_c*/
{
	/* second arg is tuple corresponding to constraint*/
	printf("compiler_error_c: %s\n", s);
	errors++;
	chaos(__FILE__, __LINE__, "compile_error_c");
}

void compiler_error_s(char *s, Symbol sym)				/*;compiler_error_s*/
{
	/* second argument is symbol */
	printf("compiler_error_s: %s\n", s); 
	zpsym(sym);
	errors++;
	chaos(__FILE__, __LINE__, "compiler_error_s");
}
#endif

Tuple discriminant_list_get(Symbol record)			/*;discriminant_list_get*/
{
	/* DISCRIMINANT_LIST(record); SIGNATURE(root_type(record))(2)  */
	Tuple	tup;
	tup = SIGNATURE(root_type(record));
	return (Tuple) tup[3];
}

/* The SETL map EMAP is accessed in C by the following procedures:
 *	 emap_get(symbol)
 *	emap_put(symbol, value)
 *  Note that emap_get returns TRUE if EMAP defined for the argument,
 *  and sets EMAP_VALUE to the value, or returns FALSE if the value
 *  not defined.
 *  The SETL sequence
 *	EMAP(s) = OM;
 *  is translated as
 *	emap_undef(s);
 */

int emap_get(Symbol sym)									/*;emap_get*/
{
	int	i, n;
	n = tup_size(EMAP);
	for (i = 1; i <= n; i += 2) {
		if (EMAP[i] == (char *) sym) {
			EMAP_VALUE = (Tuple) EMAP[i+1];
			return TRUE;
		}
	}
	return FALSE;
}

void emap_put(Symbol sym, char *val)			/*;emap_put*/
{
	int		i, n;
	n = tup_size(EMAP);
	for (i = 1; i <= n; i += 2) {
		if (EMAP[i] == (char *) sym) {
			EMAP[i+1] = val;
			return;
		}
	}
	EMAP = tup_with(EMAP, (char *) sym); /* add as new entry */
	EMAP = tup_with(EMAP, (char *) val); /* add new value */
}

void emap_undef(Symbol s)									/*;emap_undef*/
{
	int	i, n, j;

	n = tup_size(EMAP);
	for (i = 1; i <= n; i += 2) {
		if (EMAP[i] == (char *) s) {
			/* if defined here, move down later entries*/
			for (j = i; j < n - 1; j ++) {
				EMAP[j] = EMAP[j+2];
			}
		}
	}
}

void generate_object(Symbol s)							/*;generate_object*/
{
	if (!tup_mem((char *)s, GENERATED_OBJECTS))
		GENERATED_OBJECTS = tup_with(GENERATED_OBJECTS, (char *) s);
}

Tuple get_constraint(Symbol type_name)					/*;get_constraint*/
{
	/* constraints on access types are now also tuples in the C version.*/
	if (is_array(type_name) || NATURE(base_type(type_name)) == na_subtype) {
		Tuple tup; /* TBSL: make this a static constant */
		tup = tup_new(5);
		tup[1] = (char *)co_index;
		tup[2] = (char *)OPT_NODE;
		tup[3] = (char *)OPT_NODE;
		return tup;
	}
	else {
		return SIGNATURE(type_name);
	}
}

Symbol get_type(Node node)										/*;get_type*/
{
	int	nk;
	Symbol	sym;

	nk = N_KIND(node);
	if (nk == as_simple_name || nk == as_subtype_indic) {
		sym = N_UNQ(node);
		if (sym == (Symbol)0) {
#ifdef DEBUG
			zpnod(node);
#endif
			chaos(__FILE__, __LINE__, "get_type: N_UNQ not defined for node");
		}
		else {
			sym =  TYPE_OF(sym);
		}
	}
	else {
		sym = N_TYPE(node);
	}
	return sym;
}

int has_discriminant(Symbol typ)						/*;has_discriminant*/
{
	/* Note that has_discriminant is adasem macro that is NOT same as
	 * discriminant_list macro defined in adagen. Calls of the latter must
	 * be translated as discriminant_list_get.
	 */
	Tuple	tup;
	tup = discriminant_list_get(typ);
	if (tup == (Tuple)0) return FALSE;
	return tup_size(tup) > 0;
}

int has_static_size(Symbol typ)							/*;has_static_size*/
{
	return size_of(typ) >= 0;
}

int is_access_type(Symbol typ)							/*;is_access_type*/
{
	return nature_root_type(typ) == na_access;
}

int is_aggregate(Node node)									/*;is_aggregate*/
{
	register int	nk;
	nk = N_KIND(node);
	return nk == as_array_aggregate || nk == as_array_ivalue
	  ||  nk == as_record_aggregate || nk == as_record_ivalue;
}

int is_array_type(Symbol typ)							/*;is_array_type*/
{
	return nature_root_type(typ) == na_array;
}

int is_entry_type(Symbol typ)								/*;is_entry_type*/
{
	return NATURE(typ) == na_entry_former;
}

int is_enumeration_type(Symbol typ)						/*;is_enumeration_type*/
{
	return NATURE(root_type(typ)) == na_enum;
}

int is_float_type(Symbol typ)								/*;is_float_type*/
{
	Tuple	tup;
	tup = SIGNATURE(typ);
	return (int)tup[1] == co_digits;
}

int is_formal_parameter(Symbol sym)					/*;is_formal_parameter*/
{
	register int	na;
//	int                 s_n, found;
//	Symbol              same_sym, sym_scope;
//	Fortup              ft1;

	na = NATURE(sym);
	return ((na == na_in || na == na_inout || na == na_out)
			&& assoc_symbol_exists(sym,FORMAL_TEMPLATE) );
}

int is_global(Symbol sym)										/*;is_global*/
{
	return sym->s_segment != -1;
}

int is_integer_type(Symbol typ)								/*;is_integer_type*/
{
	return root_type(typ) == symbol_integer;
}

int is_ivalue(Node node)										/*;is_ivalue*/
{
	int	nk = N_KIND(node);
	return nk == as_ivalue || nk == as_int_literal || nk == as_string_ivalue
	  || nk == as_real_literal || nk == as_array_ivalue
	  || nk == as_record_ivalue;
}

int is_object(Node node)										/*;is_object*/
{
	int	nk = N_KIND(node);
	return nk == as_simple_name || nk == as_null || nk == as_name
	  || nk == as_slice || nk == as_index || nk == as_selector;
}

int is_record_subtype(Symbol typ)						/*;is_record_subtype*/
{
	return is_record_type(typ) && NATURE(typ) == na_subtype;
}

int is_record_type(Symbol typ)								/*;is_record_type*/
{
	return nature_root_type(typ) == na_record;
}

int is_renaming(Symbol sym)									/*;is_renaming*/
{
	return ALIAS(sym) != (Symbol)0;
}

int is_simple_name(Node node)								/*;is_simple_name*/
{
	int nk = N_KIND(node);
	return nk == as_simple_name || nk == as_null || nk == as_name;
}

int is_simple_type(Symbol typ)								/*;is_simple_type*/
{
	return nature_root_type(typ) != na_array
	  && nature_root_type(typ) != na_record;
}

int is_static_type(Symbol typ)								/*;is_static_type*/
{
	return is_global(typ) && has_static_size(typ);
}

int local_reference_map_defined(Symbol sym)		/*;local_reference_map_defined*/
{
	/* return TRUE if local_reference_map defined for sym, else FALSE */
	int		i, n;
	n = tup_size(LOCAL_REFERENCE_MAP);
	for (i = 1; i <= n; i += 2) {
		if (LOCAL_REFERENCE_MAP[i] == (char *) sym)
			return TRUE;
	}
	return FALSE;
}

Tuple local_reference_map_new()					/*;local_reference_map_new*/
{
	return tup_new(0);
}

unsigned int local_reference_map_get(Symbol sym)	/*;local_reference_map_get*/
{
	int		i, n;
	n = tup_size(LOCAL_REFERENCE_MAP);
	for (i = 1; i <= n; i += 2) {
		if (LOCAL_REFERENCE_MAP[i] == (char *) sym)
			return (unsigned int) LOCAL_REFERENCE_MAP[i+1];
	}
	chaos(__FILE__, __LINE__, "local_reference_map_get unable to find value "); 
	return 0;
}

void local_reference_map_put(Symbol sym, int off)	/*;local_reference_map_put*/
{
	int		i, n;
	n = tup_size(LOCAL_REFERENCE_MAP);
	for (i = 1; i <= n; i += 2) {
		if (LOCAL_REFERENCE_MAP[i] == (char *)sym) {
			LOCAL_REFERENCE_MAP[i+1] = (char *) off;
			return;
		}
	}
	LOCAL_REFERENCE_MAP = tup_exp(LOCAL_REFERENCE_MAP, n+2);
	LOCAL_REFERENCE_MAP[n+1] = (char *) sym;
	LOCAL_REFERENCE_MAP[n+2] = (char *) off;
}

int mu_size(int mutyp)											/*;mu_size*/
{
	/* This procedure returns the number of storage units required for
	 * the memory type given by mutyp, one of the mu_ codes.
	 */
#ifdef WORDSIZE16
	switch (mutyp) {
	case(mu_byte):
	case(mu_word):
		return 1;
	case(mu_addr):
	case(mu_long):
	case(mu_xlng): /* check that mu_xlng value right */
		return 2; /* check desired size */
	case(mu_dble):
		return 4;
	default:
		chaos(__FILE__, __LINE__, "mu_size: bad argument"); 
		return 0;
	}
#else
	switch (mutyp) {
	case(mu_byte):
	case(mu_word):
	case(mu_long):
		return 1;
	case(mu_addr):
	case(mu_xlng): /* check that mu_xlng value right */
		return 2; /* check desired size */
	case(mu_dble):
		return 4;
	default:
		chaos(__FILE__, __LINE__, "mu_size: bad argument"); 
		return 0;
	}
#endif
}

int su_size(int ktyp)												/*;su_size*/
{
	/* This procedure returns the number of storage units required for
	 * the memory type given by ktyp, one of the TK_ codes.
	 */
#ifdef WORDSIZE16
	switch (ktyp) {
	case TK_BYTE:
	case TK_WORD: 
		return 1;
	case TK_LONG:
	case TK_XLNG:
	case TK_ADDR: 
		return 2;
	case TK_DBLE: 
		return 4;
	default:
		chaos(__FILE__, __LINE__, "su_size: bad argument");
		return 0; /* for the sake of lint */
	}
#else
	switch (ktyp) {
	case TK_BYTE:
	case TK_LONG:
	case TK_WORD: 
		return 1;
	case TK_XLNG:
	case TK_ADDR: 
		return 2;
	case TK_DBLE: 
		return 4;/* dble is double address, not C double */
	default:
		chaos(__FILE__, __LINE__, "su_size: bad argument");
		return 0; /* for the sake of lint */
	}
#endif
}

void next_local_reference(Symbol name)				/*;next_local_reference*/
{
	LAST_OFFSET		    -= mu_size(mu_addr);
	local_reference_map_put(name, LAST_OFFSET);
}

void next_global_reference_def(Symbol name)		/*;next_global_reference_def*/
{
	/* begin definition of initial data for specified symbol at end
	 * of currrent data segment.
	 */

#ifdef MACHINE_CODE
	Gref	gref;
#endif
	S_SEGMENT(name) = CURRENT_DATA_SEGMENT;
	S_OFFSET(name) = DATA_SEGMENT->seg_maxpos;
	/*REFERENCE_MAP(name) = [CURRENT_DATA_SEGMENT, #DATA_SEGMENT+1];*/
#ifdef MACHINE_CODE
	if (list_code) { /* save for printout */
		gref = (Gref) emalloct(sizeof(Gref_s), "gref");
		gref->gref_sym = name;
		gref->gref_seg = CURRENT_DATA_SEGMENT;
		gref->gref_off = DATA_SEGMENT->seg_maxpos;
		/*n = tup_size(global_reference_tuple);*/
		global_reference_tuple = tup_with(global_reference_tuple, (char *)gref);
	}
#endif
}

void next_global_reference_r(Symbol sym, int seg, unsigned int off)
													/*;next_global_reference_r*/
{
	/* need to extend DATA_SEGMENT with seg and off */

	next_global_reference_def(sym);
	segment_put_word(DATA_SEGMENT, seg);
	segment_put_word(DATA_SEGMENT, off);

}

void next_global_reference_segment(Symbol sym, Segment seg)
											/*;next_global_reference_segment*/
{
	/* install segment seg as next global reference */

	next_global_reference_def(sym);
	segment_append(DATA_SEGMENT, seg);
}

void next_global_reference_template(Symbol sym, Segment seg)
											/*;next_global_reference_template*/
{
	next_global_reference_segment(sym, seg);
}

void next_global_reference_z(Symbol sym)			/*;next_global_reference_z*/
{
	/* This corresponds to SETL case next_global_reference(sym, [0, 0]);]
	 * which we translate to next_global_reference_r for now, though
	 * the correctness of this translation needs to be checked
	 */

	next_global_reference_def(sym);
	segment_put_word(DATA_SEGMENT, 0);
	segment_put_word(DATA_SEGMENT, 0);
}

void next_global_reference_word(Symbol sym, int w)
												/*;next_global_reference_word*/
{
	/* This corresponds to SETL case of adding value [n] where n is assumed
	 * to take only a word.
	 */

	next_global_reference_def(sym);
	segment_put_word(DATA_SEGMENT, w);
}

Symbol new_unique_name(char *s)							/*;new_unique_name*/
{
	/* TBSL: see if this is right translation?  ds  3-12-85 */
	/* If list_code on, then create ORIG_NAME from argument by appending
	 * sequence number
	 */
#ifdef MACHINE_CODE
	Symbol	sym;
	char	seq[10];

	sym = sym_new(na_void);
	sprintf(seq, "#%d", S_SEQ(sym));
	ORIG_NAME(sym) = (s != (char *)0) ? strjoin(s, seq) : strjoin(seq, "");
	return sym;
#else
	return sym_new(na_void);
#endif
}

static short nature_root_type(Symbol typ)				/*;nature_root_type*/
{
	Symbol sym;

	if (typ == (Symbol)0)
		chaos(__FILE__, __LINE__, "gutil.c : nature_root_type argument null");

	sym = root_type(typ);

	if (sym == (Symbol)0)
		chaos(__FILE__, __LINE__, "gutil.c : nature_root_type, root_type of arg null");

	return NATURE(sym);
}

Segment segment_map_get(Tuple tup, int sn)				/*;segment_map_get*/
{
	/* tup is segment map, sn is segment number */

	int		i, n;

	n = tup_size(tup);
	for (i = 1; i<n; i += 2) {
		if ((int) tup[i] == sn)
			return (Segment) tup[i+1];
	}
	return (Segment) 0;
}

Tuple segment_map_put(Tuple tup, int sn, Segment seg)		/*;segment_map_put*/
{
	/* tup is segment map, sn is segment number */

	int		i, n;

	n = tup_size(tup);
	for (i = 1; i<n; i += 2) {
		if ((int) tup[i] == sn) {
			tup[i+1] = (char *) seg;
			return tup;
		}
	}
	/* here if no entry, make new one, possible reallocating tuple */
	tup = tup_exp(tup, n+2);
	tup[n+1] = (char *) sn;
	tup[n+2] = (char *) seg;
	return tup;
}

Const	small_of(Symbol typ)									/*;small_of*/
{
	/* It returns const, that should always be rational and so
	 * perhaps should insert check here that this holds	ds 7-1-85*/
	Tuple tup = SIGNATURE(typ);
	return get_ivalue((Node)tup[5]);
}
