/************************************************************************/
/*                                                                      */
/* Copyright (c) 1988 -                                                 */
/*     The Rector and Visitors of the University of Virginia            */
/*                                                                      */
/* This code may not be distributed further without permission          */
/*      from the University of Virginia.                                */
/* This code is distributed WITHOUT ANY WARRANTY.  No claims are        */
/*      made as to whether it serves any particular purpose or even     */
/*      works at all.                                                   */
/*                                                                      */
/************************************************************************/

#include <stdio.h>
#include <string.h>
#include "types.h"
#include "scan.h"
#include "tword.h"
#include "object.h"
#include "node.h"
#include "error.h"

extern int opt_t, p_sawextern;

/*
 * ck_compatible() returns 1 of two types are compatible,
 * otherwise 0.
 */

int
ck_compatible(type1, type2)
	register OBJECT *type1, *type2;
{
	register int subrflag=0;

	/* identical types are compatible */

	if (OB_SAMETYPE(type1, type2))
		return(1);

	/*
	 * if either or both types are subranges, the parent types
	 * must be the same.
	 */

	if (type1->ob_kind == OB_SUBRANGE) {
		type1 = type1->ob_type;
		subrflag++;
	}
	if (type2->ob_kind == OB_SUBRANGE) {
		type2 = type2->ob_type;
		subrflag++;
	}
	if (subrflag)
		return(OB_SAMETYPE(type1, type2));

	/*
	 * if both types are set types, they must both be packed or
	 * both be unpacked and the base types of the sets must
	 * be compatible.  OB_SETCONS indicates a set-constructor
	 * which is compatible with both packed and unpacked sets.
	 */

	if (type1->ob_kind == OB_SET && type2->ob_kind == OB_SET &&
		((type1->ob_flags | type2->ob_flags) & OB_SETCONS ||
		(type1->ob_flags & OB_PACKED) == (type2->ob_flags & OB_PACKED)))
	{
		return(ck_compatible(type1->ob_type, type2->ob_type));
	}

	/* if both types are strings, they must be the same length */

	if (ck_string(type1) && ck_string(type2))
		return(type1->ob.array.upper == type2->ob.array.upper);

	/* "nil" is compatible with any pointer type */

	if (type1->ob_kind == OB_POINTER && type2->ob_kind == OB_POINTER &&
		(type1 == std_nil || type2 == std_nil))
	{
		return(1);
	}
	return(0);
}

/*
 * ck_string determines if the type is a string type:
 * packed array [1..n] of char;
 * where n > 1.
 */

int
ck_string(type)
	register OBJECT *type;
{
	register OBJECT *idx;
	return (
		type->ob_kind == OB_ARRAY && 
		(type->ob_flags & OB_PACKED) &&
		type->ob_type == std_char &&
		(idx = type->ob.array.indextype)->ob_kind == OB_SUBRANGE &&
		idx->ob_type == std_integer &&
		type->ob.array.lower == 1 &&
		type->ob.array.upper > 1
	);
}

/*
 * ck_asgcompat() determines if the destination type is assignment
 * compatible with the source type.
 */

ck_asgcompat(expr, dest, src)
	register NODE **expr;
	register OBJECT *dest, *src;
{
	/*
	 * if the two types are compatible, neither may contain a file.
	 * add a range check to the source parse tree.
	 */
	if (ck_compatible(dest, src)) {
		*expr = ck_subrange(*expr, dest, 0);
		return(!ck_hasfile(dest) && !ck_hasfile(src));
	}
	/*
	 * integers may be assigned to reals with implicit type
	 * coercion.  Convert the source parse tree to real.
	 */
	if (dest == std_real && OB_SAMETYPE(src, std_integer)) {
		*expr = nd_build(ND_SCONV, TW_DOUBLE, *expr, ND_NULL);
		return(1);
	}
	return (0);
}
	
/* 
 * ck_hasfile() determines if the type has any components of file type
 */

int
ck_hasfile(type)
	OBJECT *type;
{
	register OBJECT *field;

	switch(type->ob_kind) {
	case OB_FILE:
		return(1);
	case OB_ARRAY:
	case OB_CONFARRAY:
		return(ck_hasfile(type->ob_type));
	case OB_RECORD:
		for (field = type->ob.record.field; field;
			field = field->ob_prev)
		{
			if (field->ob_kind == OB_FIELD &&
				ck_hasfile(field->ob_type))
			{
				return(1);
			}
		}
		break;
	}
	return(0);
}

/* ck_localfile() sees if any local file variable has been declared in
 * the current block.  If so, we must generate a call to the run time
 * system to close any files opened during this activation.
 */

int
ck_localfile(var)
	register OBJECT *var;
{
	for(; var; var = var->ob_prev) {
		if (var->ob_kind == OB_VARIABLE && ck_hasfile(var->ob_type))
			return(1);
	}
	return(0);
}


/*
 * ck_congruous() sees if the actual functional parameter and its
 * corresponding formal parameter are compatible, which means that
 * they must have congruous parameter lists.  Returns 1 on success,
 * otherwise 0.
 * Note:  when this function is called non-recursively, first == 1,
 * and ap and fp point to the actual and formal functional parameters,
 * respectively, NOT THE PARAMETER LISTS THAT WE NEED TO CHECK!
 */

int
ck_congruous(fp, ap, first)
	register OBJECT *fp, *ap;
	register int first;
{
	if (!first) {
		/*
		 * We are recursing down a parameter list.  Be sure both
		 * parameter list pointers point to a parameter.
		 */
		fp = p_nextfp(fp);
		ap = p_nextfp(ap);
	
		/* both lists must end at the same time */
	
		if ((fp == OB_NULL) != (ap == OB_NULL))
			return(0);
		if (fp == OB_NULL)
			return(1);
	}
	/*
	 * both parameters must be variable, value, functional,
	 * or procedural
	 */
	if (fp->ob_kind != ap->ob_kind)
		return(0);

	switch(fp->ob_kind) {
	case OB_VALPARM:
	case OB_VARPARM:
		/*
		 * The two parameters must have the same type, and be in
		 * the same formal-parameter-section or they must
		 * have equivalent confomant array schemas.
		 */
		if (OB_SAMETYPE(fp->ob_type, ap->ob_type)) {
			if (fp->ob.parameter.section != ap->ob.parameter.section)
				return(0);
		}
		else if (!ck_confequiv(fp->ob_type, ap->ob_type))
			return(0);
		break;
	case OB_FUNC:
	case OB_PROC:
		/*
		 * The actual parameter may not be a required function such
		 * as "sqr()".  Both parameters must have the same return type
		 * and both parameters must have congruous parameter lists.
		 */
		if (ap->ob.subp.standard ||
			!OB_SAMETYPE(fp->ob_type, ap->ob_type) ||
			!ck_congruous(fp->ob.subp.parameter, ap->ob.subp.parameter, 0))
		{
			return(0);
		}
	}
	return(first || ck_congruous(fp->ob_prev, ap->ob_prev, 0));
}

/*
 * ck_confequiv determines if two conformant array schemas are equivalent.
 */

ck_confequiv(conf1, conf2)
	register OBJECT *conf1, *conf2;
{
	/* both must be conformant arrays */

	if (conf1->ob_kind != OB_CONFARRAY || conf2->ob_kind != OB_CONFARRAY)
		return(0);

	/* both or neither must be packed */

	if ((conf1->ob_flags & OB_PACKED) != (conf2->ob_flags & OB_PACKED))
		return(0);

	/* the index types must match */

	if (conf1->ob.confarray.indextype != conf2->ob.confarray.indextype)
		return(0);

	/* the base types must match or be equivalent conf. array schemas */

	if (conf1->ob_type == conf2->ob_type)
		return(1);
	else
		return (ck_confequiv(conf1->ob_type, conf2->ob_type));
}

/*
 * ck_conforms determines if a type conforms to a conformant array schema
 */

ck_conforms(array, conf)
	register OBJECT *array, *conf;
{
	register OBJECT *aidx, *cidx;
	int cmin, cmax, amin, amax;

	if (array == std_universal || conf == std_universal)
		return(1);

	/* be sure we have a conf. array and an array */

	if (conf->ob_kind != OB_CONFARRAY ||
		!(array->ob_kind & (OB_ARRAY|OB_CONFARRAY)))
	{	
		return(0);
	}

	/* both or neither must be packed */

	if ((array->ob_flags & OB_PACKED) != (conf->ob_flags & OB_PACKED))
		return(0);

	/* index types must be compatible and whithin range */

	aidx = array->ob_kind == OB_ARRAY ? array->ob.array.indextype
		: array->ob.confarray.indextype;
	cidx = conf->ob.confarray.indextype;
	if (!ck_compatible(aidx, cidx))
		return(0);

	/* get min and max for indices */

	cmin = cidx->ob.subrange.min;
	cmax = cidx->ob.subrange.max;
	amin = aidx->ob.subrange.min;
	amax = aidx->ob.subrange.max;

	/*
	 * array index range must be entirely contained within conformant
	 * array index range.  If array is itself a conformant array, then
	 * we must at least have some overlap in the index ranges.
	 */

	if (array->ob_kind == OB_ARRAY) {
		if (amin < cmin || amax > cmax)
			return(0);
	}
	else if (amax < cmin || cmax < amin)
		return(0);
		
	/* base types must match or conform to another schema */

	if (OB_SAMETYPE(array->ob_type, conf->ob_type))
		return(1);
	else
		return(ck_conforms(array->ob_type, conf->ob_type));
}

/*
 * ck_constant determines if a constant is a value of a given type
 */

ck_constant(const, type)
	register OBJECT *const, *type;
{
	register int value;
	if (ck_compatible(const->ob_type, type)) {
		if (type->ob_kind == OB_SUBRANGE) {
			value = const->ob.const.val.i;
			return(value >= type->ob.subrange.min &&
				value <= type->ob.subrange.max);
		}
		return(1);
	}
	return(0);
}

/*
 * ck_used Generates warning messages if any of the declared identifiers
 * in a block have not been used.  Also checks statement labels.
 */

ck_used(list)
	register OBJECT *list;
{
	register int flags, defltmsg, severity;

	if (ob_level == 1 && p_sawextern)
		return;
	for (; list; list = list->ob_prev) {
		if (!*(list->ob_name))		/* skip anonymous objects */
			continue;
		flags = list->ob_flags;
		severity = E_WARNING;
		*err_text = '\0';
		defltmsg = 0;
		switch(list->ob_kind) {
		case OB_FUNC:
		case OB_PROC:
		case OB_ARRAY:
		case OB_ENUMER:
		case OB_FILE:
		case OB_POINTER:
		case OB_RECORD:
		case OB_SET:
		case OB_SUBRANGE:
		case OB_TYPE:
		case OB_VALPARM:
			if (!(flags & OB_USED))
				defltmsg++;
			break;
		case OB_CONST:
			if (list->ob_type->ob_kind != OB_ENUMER &&
				!(flags & OB_USED))
			{
				defltmsg++;
			}
			break;
		case OB_VARPARM:
			if (!(flags & (OB_USED|OB_INIT)))
				defltmsg++;
			break;
		case OB_VARIABLE:
			switch(flags & (OB_USED|OB_INIT)) {
			case 0:
				defltmsg++;
				break;
			case OB_INIT:
				sprintf(err_text,
					"variable \"%s\" was initialized but never used",
					list->ob_name);
				break;
			case OB_USED:
				sprintf(err_text,
					"variable \"%s\" was used but never initialized",
					list->ob_name);
				break;
			}
			break;
		case OB_LABEL:
			switch(flags & (OB_USED|OB_INIT)) {
			case 0:
			case OB_USED:
				sprintf(err_text, "no statement is labeled with \"%s\"",
					list->ob_name);
				severity = E_FATAL;
				break;
			case OB_INIT:
				sprintf(err_text, "no \"goto %s\" statement",
					list->ob_name);
				break;
			}
			break;
		default:
			continue;
		}
		if (defltmsg)
			sprintf(err_text, "%s \"%s\" was never used",
				err_kind(list->ob_kind), list->ob_name);
		if (*err_text)
			err_msg(severity, E_CURLINE);
	}
}

/*
 * ck_subpdef sees if any procedure or function has been declared with
 * forward directive but not defined.
 */

ck_subpdef(list)
	register OBJECT *list;
{
	while (list) {
		if (*list->ob_name && list->ob_kind & (OB_FUNC|OB_PROC) &&
			list->ob_flags & OB_FORWARD) 
		{
			sprintf(err_text, err_notdef, err_kind(list->ob_kind),
				list->ob_name);
			err_msg(E_FATAL, E_CURLINE);
		}
		list = list->ob_prev;
	}
}

/*
 * ck_files sees if any files declared in the program heading
 * have not been defined as variables.  Initializes all files in
 * program heading with calls to RT_initfile().
 */

ck_files(list)
	register OBJECT *list;
{
	register NODE *node;
	register int recleng;
	register OBJECT *file;

	for (; list; list = list->ob_prev) {
		if (*list->ob_name && list->ob_kind == OB_VARIABLE &&
			(list->ob_flags & OB_PROGPARM))
		{
			if (!(file = list->ob_type)) {
				sprintf(err_text, err_notdef, "program parameter",
					list->ob_name);
				err_msg(E_FATAL, E_CURLINE);
				list->ob_type = std_text;
				continue;
			}
			if (file->ob_kind != OB_FILE)
				continue;
			if (list == std_input || list == std_output || 
				list == std_error)
			{
				recleng = -1;
			}
			else
				recleng = (file == std_text) ? 0 :
					file->ob_type->ob_size;
			/*
			 * build label node pointing to string containing
			 * file-variable name
			 */
			node = nd_label(p_str_label(list->ob_name));

			/* compile call to RT_initfile() */

			node = nd_build(SY_COMMA, TW_UNDEF, nd_address(list),
				node);
			node = nd_build(SY_COMMA, TW_UNDEF, node,
				nd_icon(recleng, TW_INT));
			nd_compile(nd_build(ND_CALL, TW_UNDEF,
				nd_runtime("RT_initfile", TW_UNDEF), node));
		}
	}
}

/*
 * ck_encloses determines of the subprogram subp encloses the current
 * block.  If subp is the most recently declared subprogram on its
 * level and if subp's level is less than the current level, then
 * subp encloses the current block.
 */

int
ck_encloses(subp)
	register OBJECT *subp;
{
	register OBJECT *p;

	if (subp->ob_level == 0 || subp->ob_level >= ob_level)
		return(0);
	for (p = ob_block[subp->ob_level]; p ; p = p->ob_prev) {
		if (p->ob_kind & (OB_PROC|OB_FUNC))
			break;
	}
	return(p == subp);
}

/*
 * ck_varpart performs checks on a variant-part of a record-type.
 * Each possible value that a tag-field can have must appear in
 * exactly one case-constant-list
 */

int
ck_varpart(tag, tagtype, field, count)
	OBJECT *tag, *tagtype;
	register OBJECT *field;
	int count;
{
	register int i;
	int min, missing=0, duplicate=0;
	register OBJECT *p, **check = (OBJECT **)0;
	char *malloc();
	void free();

	/* calculate the total number of possible values of the tag-field */

	if (tagtype == std_universal)
		return;
	i = tagtype->ob.subrange.max - (min = tagtype->ob.subrange.min) + 1;

	/* Did we see the same number of case constants as tag-field values ? */

	if (count < i)
		missing++;
	else if (count > i) 
		duplicate++;
	else {

		/*
		 * Just because we have the right number of case constants
		 * doesn't mean that none are duplicated.  Malloc a check
		 * array for further examination.
		 */

		check = (OBJECT**) malloc ((unsigned)(count * sizeof(OBJECT *)));
		if (!check) {
			sprintf(err_text, err_nomem, "ck_varpart()");
			err_msg(E_INTERNAL, E_CURLINE);
		}
		for (i = 0; i < count; i++)		/* clear the check array */
			check[i] = OB_NULL;

		/*
		 * fill the check array such that:
		 *     check[p->ob.const.val.i - min] == p
		 * where p is a pointer to a constant.  If check[i] already has
		 * a non-null value, it better be p or we have a duplicate value
		 * on another list.  We may attempt to place p in the array several
		 * times because more than one field can point to the same
		 * case-constant-list.
		 */

		for (;field; field = field->ob_prev) {
			if (field->ob_kind != OB_FIELD || field->ob.field.tag != tag)
				continue;
			for (p = field->ob.field.tagval; p; p = p->ob_prev) {
				i = p->ob.const.val.i - min;
				if (check[i]) {
					if (check[i] != p) {
						duplicate++;
						goto out;
					}
					break; /* We did this constant-list already; */
					       /* an earlier field pointed to it */
				}
				else {
					check[i] = p;
				}
			}
		}
	}
out:
	if (duplicate) {
		strcpy(err_text, "case constant lists have duplicate values");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	else if (missing) {
		strcpy(err_text, "case constant lists are missing values");
		err_msg(E_FATAL, E_PREVSYMBOL);
	}
	if (check)
		free(check);
}

/*
 * ck_new_args ensures that the constant list passed to "new" or
 * "dispose" is valid.
 */

int
ck_new_args(rec, clist, count)
	OBJECT *rec, *clist;
	int count;
{
	register OBJECT *tag = OB_NULL, *field, *const, *next;

	if (rec->ob_kind != OB_RECORD)
		return(1);

	/* find the topmost tag field; it has no parent tagfield */

	for (field = rec->ob.record.field; field; field = field->ob_prev) {
		if (field->ob_kind == OB_FIELD &&
			field->ob_flags & OB_TAGFIELD &&
			field->ob.field.tag == OB_NULL)
		{
			tag = field;
		}
	}
	if (!tag)
		return(1);	/* error */

	/* clist is backwards, so reverse its order */

	for (const = clist, clist = OB_NULL; const; const = next) {
		next = const->ob_prev;
		const->ob_prev = clist;
		clist = const;
	}

	/*
	 * for each constant passed to "new"/"dispose" we must find a tag
	 * field that becomes active when its parent tag field has the value
	 * of the constant.  A non-tag field will suffice when we are 
	 * examining the last constant on the argument list.
	 */

	while (count--) {
		if (!ck_compatible(tag->ob_type, clist->ob_type))
			return(1);
		for (field = rec->ob.record.field; field;
			field = field->ob_prev)
		{
			if (field->ob_kind == OB_FIELD &&
				field->ob.field.tag == tag &&
				(!count || (field->ob_flags & OB_TAGFIELD)))
			{
				for (const = field->ob.field.tagval; const;
					const = const->ob_prev)
				{
					if (clist->ob.const.val.i == const->ob.const.val.i) {
						tag = field;
						goto out;
					}
				}
			}
		}
		return(1);
	out:
		clist = clist->ob_prev;
	}
	return(0);
}

/*
 * ck_range ensures that an expression is in bounds.  If the expression
 * and bounds are all constants and the runtime flag is 0, the check occurs
 * at compile time.  Otherwise ck_range builds a "range check" tree node.
 * Note that "for" statements sometimes require constants to be checked
 * at run time.
 */

NODE *
ck_range(expr, lower, upper, runtime)
	register NODE *expr, *lower, *upper;
	int runtime;
{
	int val;

	/* do range check at compile time when possible */

	if (!runtime && expr->nd_op == ND_ICON && lower->nd_op == ND_ICON) {
		val = expr->nd.tn.ival;
		if (val < lower->nd.tn.ival || val > upper->nd.tn.ival) {
			sprintf(err_text,
				"array index or other value out of bounds.  ord(value)=%d",
				val);
			err_msg(E_FATAL, E_PREVSYMBOL);
		}
		lower->nd_op = upper->nd_op = ND_FREE;
		return(expr);
	}
	if (opt_t) {	/* run time tests disabled */
		nd_freetree(lower);
		nd_freetree(upper);
		return(expr);
	}
	lower = nd_build(SY_COMMA, TW_UNDEF, lower, upper);
	expr = nd_build(ND_RANGE, expr->nd_type, expr, lower);
	return(expr);
}


/*
 * ck_value(expr, type) generates code to ensure that the expression
 * value lies within the bounds of the type.
 */

NODE *
ck_value (expr, type)
	register NODE *expr;
	register OBJECT *type;
{
	switch (type->ob_kind) {

	case OB_STDTYPE:
		if (type != std_char && type != std_boolean)
			break;
		/* fall through */

	case OB_SUBRANGE:
	case OB_ENUMER:
		expr = ck_range(expr, nd_icon(type->ob.subrange.min, TW_INT),
			nd_icon(type->ob.subrange.max, TW_INT), 0);
		break;
	}
	return(expr);
}

/*
 * ck_subrange(expr, type, runtime) generates code to ensure that the
 * expression could be assigned to the specified subrange type or set
 * of subrange type.
 */

NODE *
ck_subrange(expr, type, runtime)
	register NODE *expr;
	register OBJECT *type;
	int runtime;
{
	switch(type->ob_kind) {

	case OB_SUBRANGE:
		expr = ck_range(expr, nd_icon(type->ob.subrange.min, TW_INT),
			nd_icon(type->ob.subrange.max, TW_INT), runtime);
		break;

	case OB_SET:
		type = type->ob_type;
		if (type->ob_kind == OB_SUBRANGE && !opt_t) {
			expr = nd_build(SY_COMMA, TW_UNDEF, expr,
				nd_icon(type->ob.subrange.min, TW_INT));
			expr = nd_build(SY_COMMA, TW_UNDEF, expr,
				nd_icon(type->ob.subrange.max, TW_INT));
			expr = nd_build(ND_CALL, TW_PTR+TW_STRTY,
				nd_runtime("RT_set_check", TW_PTR+TW_STRTY), expr);
		}
		break;
	}
	return(expr);
}
