/*
 * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
 * See the copyright notice in the ACK home directory, in the file "Copyright".
 *
 * Author: Ceriel J.H. Jacobs
 */

/*	T Y P E   D E F I N I T I O N   M E C H A N I S M	 */

/* $Id$ */

#include	"parameters.h"
#include	"debug.h"

#include	<stdlib.h>
#include	<assert.h>
#include	<ack_string.h>
#include	<alloc.h>
#include	<em_arith.h>
#include	<em_label.h>
#include	<em_code.h>

#include	"LLlex.h"
#include	"def.h"
#include	"type.h"
#include	"idf.h"
#include	"node.h"
#include	"scope.h"
#include	"error.h"
#include	"walk.h"
#include	"lookup.h"
#include	"stab.h"
#include	"enter.h"
#include	"typequiv.h"
#include	"main.h"
#include	"chk_expr.h"
#include	"warning.h"

#ifndef NOCROSS
int
	word_align = AL_WORD,
	short_align = AL_SHORT,
	int_align = AL_INT,
	long_align = AL_LONG,
	float_align = AL_FLOAT,
	double_align = AL_DOUBLE,
	pointer_align = AL_POINTER,
	struct_align = AL_STRUCT;

arith
	word_size = SZ_WORD,
	dword_size = 2 * SZ_WORD,
	int_size = SZ_INT,
	short_size = SZ_SHORT,
	long_size = SZ_LONG,
	float_size = SZ_FLOAT,
	double_size = SZ_DOUBLE,
	pointer_size = SZ_POINTER;
#endif

arith	ret_area_size;

struct type
	*bool_type,
	*char_type,
	*int_type,
	*card_type,
	*longint_type,
	*longcard_type,
	*real_type,
	*longreal_type,
	*word_type,
	*byte_type,
	*address_type,
	*intorcard_type,
	*longintorcard_type,
	*bitset_type,
	*void_type,
	*std_type,
	*error_type;


struct type *construct_type(int fund, register struct type *tp)
{
	/*	fund must be a type constructor.
		The pointer to the constructed type is returned.
	*/
	register struct type *dtp = new_type();

	switch (dtp->tp_fund = fund)	{
	case T_PROCEDURE:
	case T_POINTER:
	case T_HIDDEN:
		dtp->tp_align = pointer_align;
		dtp->tp_size = pointer_size;
		break;

	case T_SET:
		dtp->tp_align = word_align;
		break;

	case T_ARRAY:
		dtp->tp_value.tp_arr = new_array();
		dtp->tp_align = struct_align;
		break;

	case T_SUBRANGE:
		assert(tp != 0);
		dtp->tp_value.tp_subrange = new_subrange();
		dtp->tp_align = tp->tp_align;
		dtp->tp_size = tp->tp_size;
		break;

	default:
		crash("funny type constructor");
	}

	dtp->tp_next = tp;
	return dtp;
}

/* Aligns "pos" to the specified alignment "al"
 * and returns the aligned "pos".
 */
arith align(arith pos, int al)
{
	int i = pos % al;

	if (i) return pos + (al - i);
	return pos;
}

struct type *standard_type(int fund, int algn, arith size)
{
	register struct type *tp = new_type();

	tp->tp_fund = fund;
	tp->tp_align = algn;
	tp->tp_size = size;
	if (fund == T_ENUMERATION || fund == T_CHAR) {
		tp->tp_value.tp_enum = new_enume();
	}

	return tp;
}

void InitTypes(void)
{
	register struct type *tp;

	/* first, do some checking
	*/
	if ((int) int_size != (int) word_size) {
		fatal("integer size not equal to word size");
	}

	if ((int) long_size < (int) int_size) {
		fatal("long integer size smaller than integer size");
	}

	if ((int) double_size < (int) float_size) {
		fatal("long real size smaller than real size");
	}

	ret_area_size = (int) double_size > ((int) pointer_size << 1) ?
				double_size : (pointer_size << 1);

	/* character type
	*/
	char_type = standard_type(T_CHAR, 1, (arith) 1);
	char_type->enm_ncst = 256;
	
	/* boolean type
	*/
	bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
	bool_type->enm_ncst = 2;

	/* integer types, also a "intorcard", for integer constants between
	   0 and MAX(INTEGER)
	*/
	int_type = standard_type(T_INTEGER, int_align, int_size);
	longint_type = standard_type(T_INTEGER, long_align, long_size);
	longcard_type = standard_type(T_CARDINAL, long_align, long_size);
	card_type = standard_type(T_CARDINAL, int_align, int_size);
	intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
	longintorcard_type = standard_type(T_INTORCARD, long_align, long_size);

	/* floating types
	*/
	real_type = standard_type(T_REAL, float_align, float_size);
	longreal_type = standard_type(T_REAL, double_align, double_size);

	/* SYSTEM types
	*/
	word_type = standard_type(T_WORD, word_align, word_size);
	byte_type = standard_type(T_WORD, 1, (arith) 1);
	address_type = construct_type(T_POINTER, word_type);

	/* create BITSET type
	   TYPE BITSET = SET OF [0..W-1];
	   The subrange is a subrange of type cardinal, because the lower bound
	   is a non-negative integer (See Rep. 6.3)
	*/
	tp = construct_type(T_SUBRANGE, card_type);
	tp->sub_lb = 0;
	tp->sub_ub = (int) word_size * 8 - 1;
	bitset_type = set_type(tp);

	/* a unique type for standard procedures and functions
	*/
	std_type = construct_type(T_PROCEDURE, NULLTYPE);

	/* a unique type indicating an error
	*/
	error_type = new_type();
	*error_type = *char_type;
	void_type = error_type;
}

int fit(arith sz, int nbytes)
{
	return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
}

static void u_small(register struct type *tp, arith n)
{
	if (ufit(n, 1)) {
		tp->tp_size = 1;
		tp->tp_align = 1;
	}
	else if (ufit(n, (int)short_size)) {
		tp->tp_size = short_size;
		tp->tp_align = short_align;
	}
}

struct type *enum_type(struct node *EnumList)
{
	register struct type *tp =
		standard_type(T_ENUMERATION, int_align, int_size);

	EnterEnumList(EnumList, tp);
	if (! fit(tp->enm_ncst, (int) int_size)) {
		node_error(EnumList, "too many enumeration literals");
	}
	u_small(tp, (arith) (tp->enm_ncst-1));
	return tp;
}

struct type *qualified_type(struct node **pnd)
{
	register struct def *df;

	if (ChkDesig(pnd, D_USED)) {
		register struct node *nd = *pnd;
		if (nd->nd_class != Def) {
			node_error(nd, "type expected");
			FreeNode(nd);
			return error_type;
		}

		df = nd->nd_def;
		if (df->df_kind&(D_ISTYPE|D_FORWARD|D_FORWTYPE|D_ERROR)) {
			if (! df->df_type) {
node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
				FreeNode(nd);
				return error_type;
		    	}
			FreeNode(nd);
			if (df->df_kind == D_FORWTYPE) {
				/*	Here, df->df_type was already set,
					so there is an actual definition in the
					surrounding scope, which is now used.
				*/
				ForceForwardTypeDef(df);
			}
		   	return df->df_type;
		}
node_error(nd, "identifier \"%s\" is not a type", df->df_idf->id_text);
	}
	FreeNode(*pnd);
	return error_type;
}


int chk_bounds(arith l1, arith l2, int fund)
{

	if (fund == T_INTEGER) {
		return l2 >= l1;
	}
	return (unsigned arith) l2 >= (unsigned arith) l1;
}

int in_range(arith i, register struct type *tp)
{


	switch(tp->tp_fund) {
	case T_ENUMERATION:
	case T_CHAR:
		return i >= 0 && i < tp->enm_ncst;

	case T_SUBRANGE:
		return	chk_bounds(i, tp->sub_ub, SubBaseType(tp)->tp_fund) &&
			chk_bounds(tp->sub_lb, i, SubBaseType(tp)->tp_fund);
	}
	assert(0);
	/*NOTREACHED*/
}

struct type *subr_type(struct node *lb, struct node *ub, struct type *base)
{
	register struct type *tp = BaseType(lb->nd_type);
	register struct type *res;

	if (tp == intorcard_type) {
		/* Lower bound >= 0; in this case, the base type is CARDINAL,
		   according to the language definition, par. 6.3.
		   But what if the upper-bound is of type INTEGER (f.i.
		   MAX(INTEGER)? The Report does not answer this. Fix this
		   for the time being, by making it an INTEGER subrange.
		   ???
		*/
		assert(lb->nd_INT >= 0);
		if (BaseType(ub->nd_type) == int_type ||
		    (base && BaseType(base) == int_type)) tp = int_type;
		else tp = card_type;
	}

	if (!ChkCompat(&ub, tp, "subrange bounds")) {
		return error_type;
	}

	/* Check base type
	*/
	if (! (tp->tp_fund & T_DISCRETE)) {
		node_error(lb, "illegal base type for subrange");
		return error_type;
	}

	/* Now construct resulting type
	*/
	res = construct_type(T_SUBRANGE, tp);
	res->sub_lb = lb->nd_INT;
	res->sub_ub = ub->nd_INT;

	/* Check bounds
	*/
	if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) {
		node_error(lb, "lower bound exceeds upper bound");
		ub->nd_INT = lb->nd_INT;
		res->sub_ub = res->sub_lb;
	}

	if (tp == card_type) {
		u_small(res, res->sub_ub);
	}
	else if (tp == int_type) {
		if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
			res->tp_size = 1;
			res->tp_align = 1;
		}
		else if (fit(res->sub_lb, (int)short_size) &&
			 fit(res->sub_ub, (int)short_size)) {
			res->tp_size = short_size;
			res->tp_align = short_align;
		}
	}

	if (base) {
		if (base->tp_fund == T_SUBRANGE) {
			/* Check that the bounds of "res" fall within the range
			   of "base".
			*/
			if (! in_range(res->sub_lb, base) || 
			    ! in_range(res->sub_ub, base)) {
				error("base type has insufficient range");
			}
			base = base->tp_next;
		}
		if ((base->tp_fund & (T_ENUMERATION|T_CHAR)) ||
		    base == card_type) {
			if (res->tp_next != base) {
				error("specified basetype for subrange not compatible with bounds");
			}
		}
		else if (base == int_type) {
			if (res->tp_next == card_type &&
			    ! chk_bounds(res->sub_ub,
					 max_int[(int)int_size],
					 T_CARDINAL)){
				error("upperbound too large for type INTEGER");
			}
		}
		else	error("illegal base for a subrange");
		res->tp_next = base;
	}
	return res;
}

struct type *proc_type(struct type *result_type, struct paramlist *parameters, arith n_bytes_params)
{
	register struct type *tp = construct_type(T_PROCEDURE, result_type);

	tp->prc_params = parameters;
	tp->prc_nbpar = n_bytes_params;
	if (! fit(n_bytes_params, (int) word_size)) {
		error("maximum parameter byte count exceeded");
	}
	if (result_type && ! fit(WA(result_type->tp_size), (int) word_size)) {
		error("maximum return value size exceeded");
	}
	return tp;
}

void genrck(register struct type *tp)
{
	/*	generate a range check descriptor for type "tp" when
		neccessary. Return its label.
	*/
	arith lb, ub;
	register label ol;
	arith size = tp->tp_size;
	register struct type *btp = BaseType(tp);

	if (size < word_size) size = word_size;
	getbounds(tp, &lb, &ub);

	if (tp->tp_fund == T_SUBRANGE) {
		if (!(ol = tp->sub_rck)) {
			tp->sub_rck = ++data_label;
		}
	}
	else if (!(ol = tp->enm_rck)) {
		tp->enm_rck = ++data_label;
	}
	if (!ol) {
		C_df_dlb(ol = data_label);
		C_rom_icon(long2str((long)lb,10), size);
		C_rom_icon(long2str((long)ub,10), size);
	}
	c_lae_dlb(ol);
	if (size <= word_size) {
		CAL(btp->tp_fund == T_INTEGER ? "rcki" : "rcku", (int) pointer_size);
	}
	else {
		CAL(btp->tp_fund == T_INTEGER ? "rckil" : "rckul", (int) pointer_size);
	}
}

void getbounds(register struct type *tp, arith *plo, arith *phi)
{
	assert(bounded(tp));

	if (tp->tp_fund == T_SUBRANGE) {
		*plo = tp->sub_lb;
		*phi = tp->sub_ub;
	}
	else {
		*plo = 0;
		*phi = tp->enm_ncst - 1;
	}
}

struct type *set_type(register struct type *tp)
{

	arith lb, ub, diff, alloc_size;

	if (! bounded(tp) || tp->tp_size > word_size) {
		error("illegal base type for set");
		return error_type;
	}

	getbounds(tp, &lb, &ub);

#ifndef NOSTRICT
	if (lb < 0) {
		warning(W_STRICT, "base type of set has negative lower bound");
	}
#endif

	diff = ub - lb + 1;
	if (diff < 0) {
		error("set type limits exceeded");
		return error_type;
	}

	tp = construct_type(T_SET, tp);
	tp->tp_size = WA((diff + 7) >> 3);
	alloc_size = (tp->tp_size / word_size + 1) * sizeof(arith);
	tp->set_sz = alloc_size;
	if (tp->set_sz != alloc_size) {
		error("set size too large");
		return error_type;
	}
	tp->set_low = lb;
	return tp;
}

void ArrayElSize(register struct type *tp)
{
	/* Align element size to alignment requirement of element type.
	   Also make sure that its size is either a dividor of the word_size,
	   or a multiple of it.
	*/
	register arith algn;
	register struct type *elem_type = tp->arr_elem;

	if (elem_type->tp_fund == T_ARRAY) ArraySizes(elem_type);
	algn = align(elem_type->tp_size, elem_type->tp_align);
	if (word_size % algn != 0) {
		/* algn is not a dividor of the word size, so make sure it
		   is a multiple
		*/
		algn = WA(algn);
	}
	if (! fit(algn, (int) word_size)) {
		error("element size of array too large");
	}
	tp->arr_elsize = algn;
	if (tp->tp_align < elem_type->tp_align) {
		tp->tp_align = elem_type->tp_align;
	}
}

void ArraySizes(register struct type *tp)
{
	/*	Assign sizes to an array type, and check index type
	*/
	register struct type *index_type = IndexType(tp);
	arith diff;

	ArrayElSize(tp);

	/* check index type
	*/
	if (index_type->tp_size > word_size || ! bounded(index_type)) {
		error("illegal index type");
		tp->tp_size = tp->arr_elsize;
		return;
	}

	getbounds(index_type, &(tp->arr_low), &(tp->arr_high));
	diff = tp->arr_high - tp->arr_low;

	if (diff < 0 || ! fit(diff, (int) int_size)) {
		error("too many elements in array");
	}

	tp->tp_size = align((diff + 1) * tp->arr_elsize, tp->tp_align);
	/* ??? check overflow ??? */
	if (! ufit(tp->tp_size, (int) pointer_size)) {
		error("array too large");
	}

	/* generate descriptor and remember label.
	*/
	tp->arr_descr = ++data_label;
	C_df_dlb(tp->arr_descr);
	C_rom_cst((arith) 0);
	C_rom_cst(diff);
	C_rom_cst(tp->arr_elsize);
}

void FreeType(register struct type *tp)
{
	/*	Release type structures indicated by "tp".
		This procedure is only called for types, constructed with
		T_PROCEDURE.
	*/
	register struct paramlist *pr, *pr1;

	assert(tp->tp_fund == T_PROCEDURE);

	pr = ParamList(tp);
	while (pr) {
		pr1 = pr;
		pr = pr->par_next;
		free_def(pr1->par_def);
		free_paramlist(pr1);
	}

	free_type(tp);
}

void DeclareType(struct node *nd, register struct def *df, register struct type *tp)
{
	/*	A type with type-description "tp" is declared and must
		be bound to definition "df".
		This routine also handles the case that the type-field of
		"df" is already bound. In that case, it is either an opaque
		type, or an error message was given when "df" was created.
	*/
	register struct type *df_tp = df->df_type;

	if (df_tp && df_tp->tp_fund == T_HIDDEN) {
	  	if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
			node_error(nd,
				   "opaque type \"%s\" is not a pointer type",
				   df->df_idf->id_text);
		}
		df_tp->tp_next = tp;
		df_tp->tp_fund = T_EQUAL;
		while (tp != df_tp && tp->tp_fund == T_EQUAL) {
			tp = tp->tp_next;
		}
		if (tp == df_tp) {
			/* Circular definition! */
			node_error(nd,
				 "opaque type \"%s\" has a circular definition",
				 df->df_idf->id_text);
			tp->tp_next = error_type;
		}
	}
	else {
		df->df_type = tp;
		if (BaseType(tp)->tp_fund == T_ENUMERATION) {
			CheckForImports(df);
		}
	}
#ifdef DBSYMTAB
	if (options['g']) stb_string(df, D_TYPE);
#endif

	SolveForwardTypeRefs(df);
}

void SolveForwardTypeRefs(register struct def *df)
{
	register struct node *nd;

	if (df->df_kind == D_FORWTYPE) {
		nd = df->df_forw_node;

		df->df_kind = D_TYPE;
		while (nd) {
			nd->nd_type->tp_next = df->df_type;
#ifdef DBSYMTAB
			if (options['g'] && nd->nd_type->tp_dbindex < 0) {
				stb_addtp("(forward_type)", nd->nd_type);
			}
#endif
			nd = nd->nd_RIGHT;
		}
		FreeNode(df->df_forw_node);
	}
}


void ForceForwardTypeDef(register struct def *df)
{
	register struct def *df1 = df, *df2;
	register struct node *nd = df->df_forw_node;

	while (df && df->df_kind == D_FORWTYPE) {
		RemoveFromIdList(df);
		if ((df2 = df->df_scope->sc_def) == df) {
			df->df_scope->sc_def = df->df_nextinscope;
		}
		else {
			while (df2->df_nextinscope != df) {
				df2 = df2->df_nextinscope;
			}
			df2->df_nextinscope = df->df_nextinscope;
		}
		df = df->df_forw_def;
	}
	while (nd->nd_class == Link) {
		nd = nd->nd_RIGHT;
	}
	df = lookfor(nd, CurrVis, 1, 0);
	if (! df->df_kind & (D_ERROR|D_TYPE)) {
		node_error(nd, "\"%s\" is not a type", df1->df_idf->id_text);
	}
	while (df1 && df1->df_kind == D_FORWTYPE) {
		df2 = df1->df_forw_def;
		df1->df_type = df->df_type;
		SolveForwardTypeRefs(df1);
		free_def(df1);
		df1 = df2;
	}
}

struct type *RemoveEqual(register struct type *tpx)
{

	if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->tp_next;
	return tpx;
}

int type_or_forward(struct type *tp)
{
	/*	POINTER TO IDENTIFIER construction. The IDENTIFIER resides
		in "dot". This routine handles the different cases.
	*/
	register struct node *nd;
	register struct def *df, *df1;

	if ((df1 = lookup(dot.TOK_IDF, CurrentScope, D_IMPORTED, D_USED))) {
		/* Either a Module or a Type, but in both cases defined
		   in this scope, so this is the correct identification
		*/
		switch(df1->df_kind) {
		case D_FORWARD:
			FreeNode(df1->for_node);
			df1->df_kind = D_FORWTYPE;
			df1->df_forw_node = 0;
			/* Fall through */
		case D_FORWTYPE:
			nd = dot2node(Link, NULLNODE, df1->df_forw_node);
			df1->df_forw_node = nd;
			nd->nd_type = tp;
			return 0;
		default:
			return 1;
		}
	}
	nd = dot2leaf(Name);
	if ((df1 = lookfor(nd, CurrVis, 0, D_USED))->df_kind == D_MODULE) {
		/* A Modulename in one of the enclosing scopes.
		   It is not clear from the language definition that
		   it is correct to handle these like this, but
		   existing compilers do it like this, and the
		   alternative is difficult with a lookahead of only
		   one token.
		   This path should actually only be taken if the next token
		   is a '.'.
		   ???
		*/
		FreeNode(nd);
		return 1;
	}
	/*	Enter a forward reference into a list belonging to the
		current scope. This is used for POINTER declarations, which
		may have forward references that must howewer be declared in the
		same scope.
	*/
	df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
	assert(df->df_kind == D_FORWTYPE);
	df->df_flags |= D_USED | D_DEFINED;
	nd->nd_type = tp;
	df->df_forw_node = nd;
	if (df != df1 && (df1->df_kind & (D_TYPE | D_FORWTYPE))) {
		/*	"df1" refers to a possible identification, but
			we cannot be sure at this point. For the time
			being, however, we use this one.
		*/
		df->df_type = df1->df_type;
		df->df_forw_def = df1;
	}
	return 0;
}

int gcd(int m, int n)
{
	/*	Greatest Common Divisor
 	*/
	register int r;

	while (n)	{
		r = m % n;
		m = n;
		n = r;
	}
	return m;
}

int lcm(int m, int n)
{
	/*	Least Common Multiple
 	*/
	return m * (n / gcd(m, n));
}

struct type *intorcard(register struct type *left, register struct type *right)
{
	if (left->tp_fund == T_INTORCARD) {
		struct type *tmp = left;
		left = right;
		right = tmp;
	}
	if (right->tp_fund == T_INTORCARD) {
		if (left->tp_fund == T_INTEGER || left->tp_fund == T_CARDINAL) {
			return left;
		}
	}
	return 0;
}

#ifdef DEBUG
void DumpType(register struct type *tp)
{
	if (!tp) return;

	print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);

	print(" fund:");
	switch(tp->tp_fund) {
	case T_RECORD:
		print("RECORD");
		break;
	case T_ENUMERATION:
		print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
	case T_INTEGER:
		print("INTEGER"); break;
	case T_CARDINAL:
		print("CARDINAL"); break;
	case T_REAL:
		print("REAL"); break;
	case T_HIDDEN:
		print("HIDDEN"); break;
	case T_EQUAL:
		print("EQUAL"); break;
	case T_POINTER:
		print("POINTER"); break;
	case T_CHAR:
		print("CHAR"); break;
	case T_WORD:
		print("WORD"); break;
	case T_SET:
		print("SET"); break;
	case T_SUBRANGE:
		print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
		break;
	case T_PROCEDURE:
		{
		register struct paramlist *par = ParamList(tp);

		print("PROCEDURE");
		if (par) {
			print("(");
			while(par) {
				if (IsVarParam(par)) print("VAR ");
				DumpType(TypeOfParam(par));
				par = par->par_next;
			}
		}
		break;
		}
	case T_ARRAY:
		print("ARRAY");
		print("; element:");
		DumpType(tp->arr_elem);
		print("; index:");
		DumpType(tp->tp_next);
		print(";");
		return;
	case T_STRING:
		print("STRING"); break;
	case T_INTORCARD:
		print("INTORCARD"); break;
	default:
		crash("DumpType");
	}
	if (tp->tp_next && tp->tp_fund != T_POINTER) {
		/* Avoid printing recursive types!
		*/
		print(" next:(");
		DumpType(tp->tp_next);
		print(")");
	}
	print(";");
}
#endif
