/************************************************************************/
/*                                                                      */
/* 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.                                                   */
/*                                                                      */
/************************************************************************/

/*
 * This file contains the code for dealing with the symbol table.
 * The symbol table is an array of linked lists of OBJECTS called
 * "ob_block".  Each linked list corresponds to a static scope level
 * in the Pascal program.  The current scope level is kept in global
 * variable "ob_level".  ob_block[0] contains all the required
 * predefined objects such as "integer", "real", "new", "true", etc.
 * ob_block[1] contains all the objects defined in the outermost
 * block, and so forth.  The number of nesting levels is limited to
 * OB_MAXLEVEL.  When the compiler needs to find the symbol table
 * entry for an identifier, it searches the list at the current scope
 * level and if not found, searches the previous lists back to the
 * 0th level.
 *
 * The symbol table is built of structs called OBJECTs and they are
 * everywhere in the compiler code.  An OBJECT consists of several
 * common fields whose names begin with "ob_" and a union named "ob".
 *
 * ob_kind (int) stores the kind of object we have.  The possible
 *     values are:
 * 
 *     OB_ARRAY:     an array type
 *     OB_BOUNDID    a conformant array bound-identifier.  It is a
 *                   special parameter to which is passed a conformant
 *                   array subscript bound.
 *     OB_CONFARRAY: a conformant array type
 *     OB_CONST:     a constant (includes enumeration constants)
 *     OB_DIRECTIVE: a directive ("forward" or "external")
 *     OB_ENUMER:    an enumerated type
 *     OB_FIELD:     a record field
 *     OB_FILE:      a file type
 *     OB_FUNC:      a function or formal functional parameter
 *     OB_KEEPOFF:   a dummy entry to prevent redefinition of a
 *                   referenced OBJECT
 *     OB_LABEL:     a statement label
 *     OB_POINTER:   a pointer type
 *     OB_PROC:      a procedure or formal procedural parameter
 *     OB_RECORD:    a record type
 *     OB_SET:       a set type
 *     OB_STDTYPE:   a standard type (integer, real, char, boolean)
 *     OB_SUBRANGE:  a subrange type
 *     OB_TYPE:      another name for a type, eg "type T2 = T1;"
 *     OB_VALPARM:   a formal value parameter
 *     OB_VARIABLE:  a variable
 *     OB_VARPARM:   a formal variable parameter
 * 
 * ob_flags (int)  has extra information about the OBJECT.  The
 *     following modifiers are OR'ed together in ob_flags
 * 
 *     OB_EXTERNAL:  function or procedure was declared "external"
 *     OB_FORIDX:    variable is a "for" control variable
 *     OB_FORWARD:   function or procedure was declared "forward"
 *     OB_FREETMP:   variable is reusable, temporary, compiler-generated
 *     OB_INIT:      OBJECT has been initialized.  If a function, the
 *                   function name has been assigned a return value.  If
 *                   a label, a statement is labeled with it. If a
 *                   variable, a value has been stored in it, etc.
 *     OB_PACKED:    type is packed.
 *     OB_PARMSUBP:  procedural or functional parameter
 *     OB_PROGPARM:  file variable listed in the program heading
 *     OB_SEEN:      recursive functions set and clear this bit
 *                   to avoid infinite recursion.
 *     OB_SETCONS:   set type resulted from a set-constructor
 *     OB_TAGFIELD:  record field is a tag-field.
 *     OB_THREAT:    variable has been modified in an enclosed block
 *                   so it cannot be used as a "for" control variable
 *     OB_UNDEFINED: type definition not yet finished.  Prevents illegal
 *                   recursive references.
 *     OB_USED:      OBJECT has been used.  If a variable, it has
 *                   appeared in an expression.  If a function or
 *                   procedure, it has been called.  If a label,
 *                   there was a "goto" to it.
 *     
 * ob_name (char*) name of the OBJECT.  Some OBJECTs are anonymous.
 *     If a label, ob_name is the digit-sequence in the program.
 * 
 * ob_prev (OBJECT*) points to the previous OBJECT on a linked list.
 *     Symbol table lists and case constant lists use this link.
 * 
 * ob_type (OBJECT*) points to the type of a variable, parameter,
 *     constant, record field, or bound-identifier.  Points to the
 *     return type of  a function; to the type to which a pointer type
 *     points; to the parent type of a subrange; to the base type of
 *     an array, file, or set.
 * 
 * ob_level (int) static scope level where the OBJECT is defined.
 *     ob_level changes on a record field when its parent record
 *     is in a "with" statement.
 * 
 * ob_tword (TWORD) encoded type word for this OBJECT (see tword.h)
 * 
 * ob_size (int) size of the OBJECT in bytes.
 * 
 * ob.array.indextype (OBJECT*) type of array index
 * 
 * ob.array.lower (int) lower bound of array index
 * 
 * ob.array.upper (int) upper bound of array index
 * 
 * ob.confarray.indextype (OBJECT*) type of array index
 * 
 * ob.confarray.lower (OBJECT*) pointer to lower bound-identifier
 *     of a conformant array.
 * 
 * ob.confarray.upper (OBJECT*) pointer to upper bound-identifier
 *     of a conformant array.
 * 
 * ob.confarray.size (OBJECT*) pointer to hidden parameter through which
 *     the size in bytes of the conformant array is passed.
 * 
 * ob.const.cslab (int) statement label of case arm associated with
 *     this case constant.  Only for processing a case-statement.
 * 
 * ob.const.val.i (int) value of ordinal constant.  If constant is
 *     a string this is the label where the string is stored.
 * 
 * ob.const.val.r (double) value of real constant.
 * 
 * ob.field.tag (OBJECT*) pointer to tag field that controls this
 *     record field.
 * 
 * ob.field.tagval (OBJECT*) pointer to linked list of case constants.
 *     The controlling tag field must have one of these values to
 *     activate this field.
 * 
 * ob.field.offset (int) offset in bytes of this field in the record
 * 
 * ob.subp.parameter (OBJECT*) pointer to linked list of formal
 *     parameters for this function or procedure.
 * 
 * ob.subp.retval (OBJECT*) pointer to variable that holds the return
 *     value of this function.
 * 
 * ob.subp.standard (int) holds numeric identifier for this required
 *     function or procedure.  This field is 0 for any user defined
 *     function or procedure.
 * 
 * ob.label.gotolist (LGRAPH*) pointer to linked list of LGRAPH nodes.
 *     This list contains topographical info about any gotos to this
 *     label.  When we parse the statement labeled by this label we
 *     check the linked list to be sure all those gotos are legal.
 * 
 * ob.label.stmt (LGRAPH*) pointer to LGRAPH node.  Topological info
 *     about the location of the statement labeled with this label.
 *     Subsequent gotos to this label will be checked for legality.
 * 
 * ob.label.id (int) integral value of this label.  This is NOT the
 *     label number from the source code.  It is a unique number
 *     from lb_new().
 * 
 * ob.pointer.ident (IDENT*) pointer to name table entry needed to
 *     finish defining this pointer type.  When a pointer type is
 *     defined before its target type, we save the target name
 *     here and finish the job later.
 * 
 * ob.record.field (OBJECT*) pointer to linked list of the fields in
 *     this record type.
 * 
 * ob.subrange.min (int) minimum value of this subrange, enumerated, or
 *     standard type.
 * 
 * ob.subrange.max (int) maximum value of this subrange, enumerated,
 *     or standard type.
 *     
 * ob.parameter.section (int) The number of the formal-parameter-section
 *     that this formal parameter appears in.  Used only by
 *     ck_congruous in typecheck.c
 */

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

#define OB_CHUNK 50

int ob_level = 0, ob_reclevel = 0;
static int ob_cacherev = 1;
OBJECT *ob_block[OB_MAXLEVEL];
static OBJECT *ob_tmpflist = OB_NULL;

/*
 * ob_alloc() gets memory from system to store an object.
 */

OBJECT *
ob_alloc()
{
	static unsigned count=0;
	static OBJECT *next;
	char *calloc();
	
	if (count == 0) {
		next = (OBJECT *) calloc(count=OB_CHUNK, sizeof(OBJECT));
		if (next == OB_NULL) {
			sprintf(err_text, err_nomem, "ob_alloc()");
			err_msg(E_INTERNAL, E_CURLINE);
		}
	}
	count--;
	return(next++);
}

/*
 * ob_search(ident, level) searches the symbol table at the specified
 * scope level for an object whose name is stored in "ident".  Once an
 * object has been found, a pointer to it is cached to speed up later
 * retrievals.
 */

OBJECT *
ob_search(ident, level)
	IDENT *ident;
	int level;
{
	register OBJECT *ob;
	if (ident && ident != id_noname) { 
		for (ob = ob_block[level]; ob; ob = ob->ob_prev) {
			if (ob->ob_name == ident->id_name) {
				switch(ob->ob_kind) {
				case OB_KEEPOFF:
					break;
				case OB_FIELD:
					ob->ob_level = level;	/* needed by "with" stmt */
					/* fall through */
				default:
					ident->id_object = ob;		/* cache it for later */
					ident->id_cacherev = ob_cacherev;
				}
				return(ob);
			}
		}
	}
	return(OB_NULL);
}

/*
 * ob_searchall(ident) searches the symbol table for an object whose name
 * is stored in "ident".  The search progresses from the current scope
 * level outwards.  (Often the cache can be used to bypass the search.)
 */

OBJECT *
ob_searchall(ident)
	IDENT *ident;
{
	register int level;
	register OBJECT *ret;
	if (ident && ident != id_noname) {
		if (ident->id_cacherev == ob_cacherev) {
			ret = ident->id_object;
		}
		else {
			for (level = ob_reclevel; level >= 0; level--) {
				if ((ret = ob_search(ident, level)) &&
					ret->ob_kind != OB_KEEPOFF)
				{
					break;
				}
			}
		}
		return(ret);
	}
	return(OB_NULL);
}

/*
 * ob_shuffle moves a previously defined object to the head of its list.
 * Ob_define uses ob_shuffle to maintain a consistent ordering in the
 * table.  Some functions (eg., p_var_part() and ck_encloses()) depend
 * on the table being in a LIFO order.
 */

ob_shuffle(ob, level)
	OBJECT *ob;
	int level;
{
	register OBJECT *p;
	if (ob == ob_block[level])
		return;
	for (p = ob_block[level]; p && p->ob_prev != ob; p = p->ob_prev)
		;
	if (p) {
		p->ob_prev = ob->ob_prev;
		ob->ob_prev = ob_block[level];
		ob_block[level] = ob;
	}
}

/*
 * ob_define(ident, kind, flags) builds an object of the specified kind,
 * giving the object the name from "ident" and setting the "flags".
 * The object is linked into the symbol table at the current scope level
 * (unless "ident" is null, indicating an anonymous object).
 * Ob_define checks for redefinitions, handling the case where a
 * function/procedure has been declared "forward" and the case where a
 * variable has been defined in the program heading.
 */

OBJECT *
ob_define(ident, kind, flags)
	IDENT *ident;
	int kind, flags;
{
	register OBJECT *ob = OB_NULL;
	int level, redefined=0;

	level = kind == OB_FIELD ? ob_reclevel : ob_level;

	/*
	 * Check for redefinitions.  Note that program parameters and
	 * functions/procedures with "forward" directives get defined 
	 * in two steps.
	 */

	if (ob = ob_search(ident, level)) {
		redefined++;
		if (ob->ob_kind == kind) {
			switch(ob->ob_kind) {

			/* program parameter definition */

			case OB_VARIABLE:
				if (ob->ob_flags & OB_PROGPARM && !ob->ob_type)
					redefined=0;
				break;
			
			/* function or procedure with forward declaration */

			case OB_FUNC:
			case OB_PROC:
				if (ob->ob_flags & (OB_FORWARD|OB_EXTERNAL))
					redefined = 0;
				break;
			}
		}
		if (redefined) {
			sprintf(err_text, "redefinition of \"%s\"", ob->ob_name);
			err_msg(E_FATAL, E_PREVSYMBOL);
			/* 
			 * Neutralize previous definition.  We can't overwrite it
			 * because other objects may be pointing to it.
			 */
			ob->ob_name = "";
			ob = OB_NULL;
		}
		else {
			ob->ob_flags |= flags;
			ob_shuffle(ob, level);	/* move ob to front of list */
		}
	}
	if (ob == OB_NULL) {
		ob = ob_alloc();
		ob->ob_level = level;
		ob->ob_kind = kind;
		ob->ob_flags = flags;
		if (ident) {
			ob->ob_name = ident->id_name;
			ob->ob_prev = ob_block[level];
			ob_block[level] = ob;

			/* cache for quick retrieve */

			ident->id_object = ob;
			ident->id_cacherev = ob_cacherev;
		}
		else {	/* don't link in anonymous object */
			ob->ob_name = "";
			ob->ob_prev = OB_NULL;
		}
	}
	return(ob);
}

/*
 * ob_keepoff prevents the redefinition of an identifier defined in an
 * enclosing block and referenced in the current block.  Ob_keepoff
 * inserts a dummy entry into the symbol table that will cause ob_define
 * to complain if the user attempts to define the identifier.
 */

ob_keepoff(ob)
	OBJECT *ob;
{
	register OBJECT *p, *free = OB_NULL;
	int level;

	level = ob->ob_kind & (OB_PROC|OB_FUNC) ? ob_level -1 : ob_reclevel;
	if (level == 0 || level == ob->ob_level)
		return;

	for (p = ob_block[level]; p; p = p->ob_prev) {
		if (p->ob_name == ob->ob_name)
			return;
		if (p->ob_kind == OB_KEEPOFF && !(*p->ob_name))
			free = p;
	}
	if (free)
		free->ob_name = ob->ob_name;
	else {
		p = ob_alloc();
		p->ob_kind = OB_KEEPOFF;
		p->ob_name = ob->ob_name;
		p->ob_prev = ob_block[level];
		ob_block[level] = p;
	}
}

/*
 * ob_newblock increments the scope level of the symbol table.  The cache
 * is nullified, forcing linear searches.
 */

ob_newblock()
{
	if ((ob_reclevel = ++ob_level) >= OB_MAXLEVEL) {
		strcpy(err_text, err_nest);
		err_msg(E_INTERNAL, E_CURLINE);
	}
	ob_block[ob_level] = OB_NULL;
	ob_cacherev++;	/* invalidates cached pointers */
}

/*
 * ob_endblock decrements the scope level of the symbol table.  Note that
 * no storage recovery is attempted, so the compiler's storage requirements
 * are proportional to the length of the program (rather than the scope
 * nesting level).
 */

ob_endblock()
{
	ob_reclevel = --ob_level;
	ob_cacherev++;
	ob_tmpflist = OB_NULL;
}

/*
 * ob_newrecblock increments the record scope level of the symbol table.
 * Because of "with" statements and record field definitions, we need
 * to keep track of two scope levels in the symbol table.
 */

ob_newrecblock()
{
	if (++ob_reclevel >= OB_MAXLEVEL) {
		strcpy(err_text, err_nest);
		err_msg(E_INTERNAL, E_CURLINE);
	}
	ob_block[ob_reclevel] = OB_NULL;
	ob_cacherev++;
}

/*
 * ob_endrecblock() decrements the record scope level of the symbol table.
 */

ob_endrecblock()
{
	ob_reclevel--;
	ob_cacherev++;
}


/*
 * ob_tmpvar() defines a temporary "invisible" local variable of a
 * particular type and size.  The compiler needs these variables to
 * store function return values, implement "for" statments,
 * "with" statements, I/O statements, conformant arrays, etc.
 */

OBJECT *
ob_tmpvar(tword, size, kind)
	TWORD tword;
	int size, kind;
{
	register OBJECT *var, *prev;
	static int tmpname=0;
	char buf[20], *strsave();

	for (var = prev = ob_tmpflist; var; var = (prev=var)->ob_prev) {
		if (var->ob_tword == tword && var->ob_size == size) {
			if (prev == var)		/* first on list */
				ob_tmpflist = var->ob_prev;
			else 
				prev->ob_prev = var->ob_prev;
			var->ob_prev = OB_NULL;
			return(var);
		}
	}
	var = ob_alloc();
	sprintf(buf, "$%d", tmpname++);
	var->ob_name = strsave(buf);
	var->ob_kind = kind;
	var->ob_tword = tword;
	var->ob_size = size;
	var->ob_level = ob_level;
	if (kind == OB_VARIABLE) {	/* declare now */
		var->ob_prev = OB_NULL;
		c_decl(var->ob_tword, var->ob_name, nd_sclass(var),
			var->ob_size, ob_level);
	}
	else {	/* parameter declared later */
		var->ob_flags = OB_USED|OB_INIT;
		var->ob_prev = ob_block[ob_level];
		ob_block[ob_level] = var;
	}
	return(var);
}

/*
 * ob_freetmp() puts a temporary variable on a free list for reuse
 */ 

ob_freetmp(var)
	OBJECT *var;
{
	var->ob_prev = ob_tmpflist;
	ob_tmpflist = var;
}
