/*
 *  MODULE  : idtab.c
{*  last modification:	15.04.92  14:18   }


 *  uli 20.11.90 : checkerror substituted by errput
 *  uli 03.01.91 : moduniquename move from module.c
		   newname is local now
		   aa_count = 0 ,  local vars of idinit deleted
 *  uli 25.01.91 : idinit: idkndtext initialized.
 *  Dima 21.01.91: binncoers: The  subtypes of the same base-type
		 are not compatible now.
		 By VAR-par the coersion from subtype to base-type
		 is allowed.
		 See opcoers in optab.c
 *  Dima 30.01.91: idroutfnd : parameter callclass added
 *  Dima 13.02.91: binparcompare & binncoers moved from bintab
 *  uli 01.03.91 : new style headers.
 *  uli 06.03.91 : stdio.h added.
 *  uli 06.03.91 : initmoduniquename: del_extension replaced by prognam
 *  uli 26.03.91 : idflag forvariable initialized
 *  uli 15.04.91 : moduniquename: errornumber 30004 changed to 5220
 *  uli 23.04.91 : idrdconv and idruconv added.
 *  uli 30.04.91 : idbin: creates a node if idsetbin was missing.
 *  uli 02.05.91 : idimport and idglobal deleted.
 *  uli 02.05.91 : sub_or_base_of is boolean.
 *  uli 15.05.91 : idsetdatyp sets idtab-flags correct now.
 *  uli 17.05.91 : idroutins: "if" added in one call of idfset().
 *  uli 11.06.91 : idtreeins: checks IDTYPE before call of binparcompare.
 *  uli 17.06.91 : iddatyp returns anytype if id==NIL.
 *  uli 08.07.91 : idlclfnd skips with-blocks.
 *  Dima 09.07.91: sub_or_base_of : corrected.
 *  Dima 07.08.91 : binncoers: PTRCHAR added
 *  Dima 08.08.91 : binncoers: lista instead of listf by Varparam
 *  uli 12.08.91 : idfinit: idtab flag "nogener" added.
 *  uli 19.08.91 : idfinit: idtab flag nogener replaced by nodecl and noinit
 *  uli 14.11.91 : initmoduniquename: doesn't cut after 8 chars.
 *  Dima 22.11.91 : sub_or_base_of & binncoers: moved to optab (coers)
 *  uli 28.11.91 : All idset functions check idBAD_ID.
 *  uli 28.11.91 : All fnd routines check idBAD_ID.
 *  uli 17.12.91 : initmoduniquename : namelength added.
 *  Dima 09.01.92: Flag innerused is set for routines as pars. in idroutfnd
 *  uli 18.02.92 : INT_MAX replaced by NOCOERS .
 *  uli 15.04.92 : iddump: only if IDDUMP.
*/

#define CHECK

#include <string.h>
#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include <limits.h>

#include           "impor.t"
#include "error.h"
#include "sysutil.h"        /* import finish */
#include "scan.h"
#include "symtab.h"
#include "option.h"


#include           "expor.t"
#include "idtab.h"

#include           "impor.t"
#include "optab.h"
#include "bintab.h"
#include "blktab.h"

#include           "implemen.t"

#include "runtime.h"


#ifdef LINT_ARGS
local idptr      idalloc     (void);
local void       idfree      (idptr);
local idptr      idtreeins   (idptr *,symptr,idkind,idptr);
local idptr      idtreefnd   (idptr,symptr);
#else
local idptr        idalloc   ();
local void       idfree      ();
local idptr      idtreeins   ();
local idptr      idtreefnd   ();
#endif
							/*---------------*/
static int   MAX_ALLOC = 127;
static idptr freelist  = (idptr)0;
       idptr idrconv   = (idptr)0;
       idptr idrdconv   = (idptr)0;
       idptr idruconv   = (idptr)0;

#ifdef LINT_ARGS
local idptr idalloc ( void)
#else
local idptr idalloc()
#endif
{
  idptr temp;
  int i;

  if (not freelist) {
    freelist = (idptr) calloc(MAX_ALLOC, sizeof(struct id));
    while (not freelist) {
      MAX_ALLOC /= 2;
      freelist =  ((idptr) calloc(MAX_ALLOC, sizeof(struct id)));
      if (MAX_ALLOC < 2)   memerror (pos) ;
    }
    temp = freelist;
    for (i=1;i<MAX_ALLOC;i++) {
      temp->idr = &(freelist[i]);
      temp = temp->idr;
    }
    temp->idr = (idptr)0;
  }
  temp = freelist;
  freelist = freelist->idr;

  return ((idptr) temp);
}

#ifdef LINT_ARGS
local void idfree ( idptr id)
#else
local void idfree(id)
idptr id;
#endif
{
  if (id==NULL)
    printf("Freeing none allocated memory"), finish(-99);
  else {
    id->idr  = freelist;
    freelist = id;
  }
}

local idflags idfinit=
       {           false, /* is_global   */
		   false, /* imported    */
		   false, /* used        */
		   false, /* innerused   */
		   false, /* forward     */
		   false, /* globalglobal*/
		   false, /* generated   */
		   false, /* dynamic     */
		   false, /* hidden      */
		   false, /* external    */
		   false, /* nooverload  */
		   false, /* stdmodule   */
		   false, /* usedglobal  */
		   false, /* arraytype   */
		   false, /* desctype    */
		   false, /* varpl       */
		   false, /* varpr       */
		   false, /* formpara    */
		   false, /* hasdyn      */
		   false, /* parused     */
		   false, /* forvariable */
		   false, /* nodecl      */
		   false, /* noinit      */
       };

#ifdef LINT_ARGS
global idptr idcreate (  symptr sym,idkind kind)
#else
global idptr idcreate(sym, kind)
/* Allocates memory for an IDTAB-entry and initializes its members.     */
symptr sym;
idkind kind;
#endif
{       idptr id;
	id=idalloc();
	id->status=idfinit;
	id->sym=sym; id->csym=sym;
	id->kind=kind; id->level=blocklevel;
	id->st=id->with=NULL;
	return id;
} /*idcreate*/


#ifdef LINT_ARGS
global void idtabtraverse ( idptr root, void (*fkt)(idptr))
#else
global void idtabtraverse(root, fkt)
idptr root;
void (*fkt)();
#endif
{
  if (root)
  {     (*fkt)(root);
	idtabtraverse(root->idl,fkt);
	idtabtraverse(root->idr,fkt);
  }
  return;
} /* idtabtraverse */
						   /*---------------*/
#ifdef LINT_ARGS
global int idforw ( idptr root,int n)
#else
global int idforw(root,n)                          /*  i d f o r w  */
idptr root;
int n;
#endif
{
  if ( root) {
	if ( (root->kind==IDFUNCTION or root->kind==IDPROCEDURE) and
	     id_is (root,forward) ) {
	    errput (5211,binpos (root->bin),symtab (root->sym));
	    n--;
	}
	else
	if ( root->kind == IDLABEL and
	     id_is (root, used) and id_is(root, forward) ) {
	    errput (5212, binpos (root->bin), NULL);
		     /* Label has been referenced but not defined */
	    n--;
	}

	idforw(root->idl,n);
	idforw(root->idr,n);
  }
  return n;
} /* idforw */


#ifdef LINT_ARGS
local idptr idtreeins (  idptr *root,symptr sym,idkind kind,idptr ins)
#else
local idptr idtreeins(root,sym,kind,ins)
/* Inserts new identifier in IDTAB. Use idroutins()     */
/* to insert functions and procedures.                  */
idptr    *root;
symptr   sym;
idkind   kind;
idptr    ins;
#endif
{
	while ((*root)!=NULL)
	{
		if (sym<(*root)->sym) root= &(*root)->idl;
		else if (sym>(*root)->sym) root= &(*root)->idr;
	    /*    else if (kind==IDTYPE and
				       id_is(*root,forward) ) {



		      return *root;
		}*/ else
		if ( kind==IDFUNCTION or kind==IDPROCEDURE ) {
		    while ( (*root)!=NULL and sym==(*root)->sym) {
			if ( (*root)->kind!=IDFUNCTION and
			     (*root)->kind!=IDPROCEDURE and
			     (*root)->kind!=IDTYPE ) {
			     errput (5204, pos, symtab(sym));
			   /* Redeclaration */
			} else if ( (*root)->kind!=IDTYPE and
				    (*root)->kind!=kind ) {
			     if (kind==IDFUNCTION)
			       errput (5205, pos, symtab(sym));
			     else
			       errput (5206, pos, symtab(sym));
			} else
			if ((*root)->kind!=IDTYPE and
			    binparcompare (idparlist(ins),idparlist(*root)))
			{    if (not id_is(*root,forward) or
				 (*root)->kind!=kind) {
				     errput (5207, pos, symtab(sym));
			     } else
			     if (kind==IDFUNCTION and
				 unname(iddatyp(ins))!=unname(iddatyp(*root)))
			     {       errput (5208, pos, symtab(sym));
			     }
			     return *root;
			}
			root= &(*root)->idl;
		    } /* while: linear list of equal-named identifiers */

		} /* if: function or procedure */
		else {
		   errput (5209, pos, symtab(sym)) ;
		   return *root;
		}
	}

     /* identifier not found */
	if ( ins!=NULL ) *root=ins;
	else *root=idcreate(sym,kind);
	(*root)->idl=NULL; (*root)->idr=NULL;

	return *root;
} /*idtreeins*/


#ifdef LINT_ARGS
global idptr idins ( symptr sym,idkind kind)
#else
global idptr idins(sym,kind)                             /*  i d i n s  */
symptr sym;
idkind  kind;
#endif
BEGIN(idins)
 idptr id;

#ifdef TRACE
 printf("idins %s\n",symtab(sym));
#endif

 id=idtreeins (blkptrid(actblock), sym, kind, NULL);

#ifdef ID_CHECK
printf("\n ins %s %d",symtab(id->sym),id->level);
#endif

 RETURN(id);
END /*idins*/

#ifdef LINT_ARGS
local idptr idtreefnd (  idptr id,symptr sym)
#else
local idptr idtreefnd(id,sym)
/* Returns the first occurence of 'sym' in tree with root id. */
idptr id;
symptr  sym;
#endif
{

 if (id)
 {
	while (id)
	{
	     if (sym<id->sym) id=id->idl;
	     else if (sym>id->sym) id=id->idr;
	     else break;
	}
 } else id=NULL;
 return id;
} /*idtreefnd*/

#ifdef LINT_ARGS
global idptr idfnd (  symptr sym)
#else
global idptr idfnd(sym)                                 /*  i d f n d  */
/* Searches for identifier 'sym' with   */
/* scope in actual block.               */
symptr sym;
#endif
{    boolean innerused=false; /* Ident. is defined in the current block */
     idptr        id;
     blockrec *block;
     idkind kind;

	if (sym == symNIL)  return idBAD_ID ;

	block=actblock;

	/* Searches from current to exterior blocks */
	while (block and ((id=idtreefnd(blkid(block),sym))==NULL)) {
	  if ( not blk_is(block,iswith) ){
	    /* Defined somewhere in  the exterior block */
	    innerused=true;
	  }
	  block=blkfather(block);
	}

	if (id)
	{  idfset(id,used);
	   if (idglobdecl  and  not (id_is (id, is_global) or
		id_is (id, globalglobal) or id_is (id, usedglobal) ))
	   { /* travers datastructure recursively */
	     idfset(id,usedglobal);
	   }

#ifdef ID_CHECK
printf("\nsym and level: %s %d\n",symtab(id->sym),id->level);
#endif
	   if ( innerused and
		id->level>IDMAINLEVEL and
		((kind=idgetkind(id))==IDVAR or kind==IDPARAM or
		 kind==IDVALPARAM or kind==IDVARPARAM or
		 kind==IDCONST or kind==IDTYPE) ) {
	      idfset(id,innerused);      /* Identifier is used in */
					      /* inner block.          */

	      if (kind!=IDCONST and kind!=IDTYPE)  /* Denesting must search */
		 blkfset(block,innervar);     /* for variables.        */

	      if (id->level>MAXDENLEVEL) MAXDENLEVEL=id->level;
	   }
	}
#ifdef TRACE
 if (not id)
  begin
   errput (1213, pos, (char*)0) ;
  /* print (symtab(sym)) ;
   print (" is not declared.") ;
   printline (); */
  end ;
#endif
	return id;
} /*idfnd*/

#ifdef LINT_ARGS
global idptr idforfnd (  symptr sym)
#else
global idptr idforfnd(sym)                           /*  i d f o r f n d  */
/* Searches for identifier 'sym' with   */
/* scope in actual block.               */
symptr sym;
#endif
{
	idptr        id;
	blockrec *block;

	if (sym == symNIL)  return idBAD_ID ;

	block=actblock;

	while (block and ((id=idtreefnd(blkid(block),sym))==NULL))
	  block=blkfather(block);

	return id;
} /*idforfnd*/

						    /*-------------------*/
#ifdef LINT_ARGS
global idptr idtypfnd (  symptr sym)
#else
global idptr idtypfnd(sym)                          /*  i d t y p f n d  */
/* Searches for type-id 'sym' with   */
/* scope in actual block.            */
symptr sym;
#endif
{
	idptr    id=NULL;
	blockrec *block;

	if (sym == symNIL)  return idBAD_ID ;

	block=actblock;

	while (block!=NULL and ((id=idtreefnd(blkid(block),sym))==NULL or
				idgetkind(id)!=IDTYPE) ) {
	  id=NULL;
	  block=blkfather(block);
	}

	if (id)
	{  idfset(id,used);
	   if (idglobdecl  and  not (id_is (id, is_global) or
		id_is (id, globalglobal) or id_is (id, usedglobal) ))
	   { /* travers datastructure recursively */
	     idfset(id,usedglobal);
	   }

#ifdef ID_CHECK
printf("\nsym and level: %s %d\n",symtab(id->sym),id->level);
#endif
	}
	return id;
} /*idtypfnd*/

#ifdef LINT_ARGS
global idptr idfortyp (  symptr sym)
#else
global idptr idfortyp(sym)                     /*  i d f o r t y p  */
/* Searches for type-id 'sym' with   */
/* scope in actual block.               */
symptr sym;
#endif
{
	idptr    id=NULL;
	blockrec *block;

	if (sym == symNIL)  return idBAD_ID ;

	block=actblock;

	while (block!=NULL and ((id=idtreefnd(blkid(block),sym))==NULL or
				idgetkind(id)!=IDTYPE) ) {
	  id=NULL;
	  block=blkfather(block);
	}

	return id;
} /*idfortyp*/

#ifdef LINT_ARGS
global idptr idlclfnd (  symptr sym)
#else
global idptr idlclfnd(sym)                           /*  i d l c l f n d */
/* Searches for identifier 'sym' */
/* only in actual block, ignoring with-blocks. */
symptr sym;
#endif
{
	blockrec * block = actblock ;
	idptr        id;

	if  (sym == symNIL)   return idBAD_ID ;
	while (blk_is (block, iswith))   block = blkfather (block) ;

	id=idtreefnd (blkid (block),sym);

	if (id)
	{  idfset(id,used);
	   if (idglobdecl  and  not (id_is (id, is_global) or
		id_is (id, globalglobal) or id_is (id, usedglobal) ))
	   { /* travers datastructure recursively */
	      idfset(id,usedglobal);
	   }
	}

#ifdef ID_CHECK
printf("\nsym and level: %s %d\n",symtab(id->sym),id->level);
#endif
	return id;
} /*idlclfnd*/

#ifdef LINT_ARGS
global void idroutins ( binptr rout)
#else
global void idroutins(rout)                     /* i d r o u t i n s */
binptr rout;
#endif
{       idptr  id,idf;


#ifdef CHECK
	if (not sym_is [binsymc(rout)] .identifier)
	{       errput (9625, binpos(rout), (char*)0);
	      /*  print("Error in idroutins");
		printline(); */
	}
#endif

	if ( blocklevel>IDMAINLEVEL+1 )
	    blkfset(blkfather(actblock),innerrout);

	id=binid(rout);   /* id isn't yet linked to idtree! */

	idf=idtreeins(blkptrid(blkfather(actblock)),id->sym,id->kind,id);

	if (id!=idf) {                  /* id is definition,           */
					/* idf is forward-declaration. */
	   idfclr(idf,forward);
	   if (id_is(idf,is_global) or id_is(id,is_global))
	     idfset(idf,is_global) ;
	   if (idcurrf) {               /* delete all references on id */
	      idcurrf=idf;
	      blksetcf(actblock,idf);
	   }
	   binldelete(idparlist(id));
	   idfree(id);
	   binupid(rout,idf);
	   blksetfor (blkfather (actblock),false); /* Forward resolved, so     */
	}                                          /* decrease forward-counter */
	idsetbin (idf,rout);
} /*idroutins*/


#ifdef LINT_ARGS
global void idinit (  void)
#else
global void idinit()                                    /*  i d i n i t  */
/* Initialize idtab , esp. set  */
/* standard data types.         */
#endif
{
  idkndtext [IDNONE     ] = "unknown" ;
  idkndtext [IDPROGRAM  ] = "program" ;
  idkndtext [IDCONST    ] = "constant" ;
  idkndtext [IDTYPE     ] = "type" ;
  idkndtext [IDFUNCTION ] = "function" ;
  idkndtext [IDPROCEDURE] = "procedure" ;
  idkndtext [IDMODULE   ] = "module" ;
  idkndtext [IDRES1VAR  ] = "function" ;
  idkndtext [IDVAR      ] = "variable" ;
  idkndtext [IDPARAM    ] = "parameter" ;
  idkndtext [IDVALPARAM ] = "value parameter" ;
  idkndtext [IDVARPARAM ] = "variable parameter" ;
  idkndtext [IDRES2VAR  ] = "function" ;
  idkndtext [IDIMPORT   ] = "module" ;
  idkndtext [IDLABEL    ] = "label" ;

  actblock=NULL;
  idcurrf=NULL;
  blocklevel=IDPRELEVEL;
  actblock=blkmake();

  MAXDENLEVEL=IDMAINLEVEL;
  symresid=uniquename("re");
} /*idinit*/                                            /*  i d i n i t  */
							/*---------------*/


						/*-----------------------*/
#ifdef LINT_ARGS
global symptr uniquename ( const char *s)
#else
global symptr uniquename(s)                     /*  u n i q u e n a m e  */
const char *s;
#endif

#define SIZE 51                         /* Must be prime.       */
{       int h,i,j;
	char c;
	char name[7] ;

	static struct {
		char c1,c2;
		int  count;
		} hashtbl[SIZE];        /* Hashtable.           */

	static int aa_count = 0 ;
#ifdef CHECK
	if (s==NULL)   {
	   errput (9626, pos, (char*)0 ) ;
	 /* print("NULL-pointer assignment in call to function uniquename");
	   printline(); */
	   return (symNIL) ;
	}
#endif
	c= *(s+1);

	name[0] = *s ; name[1] = c ;
	if (not (islower(*s) or islower(c)) or
	    not isalpha(*s) or not (isalnum(c) or c=='_') or
	    (*s=='a' && c=='a'))
	{  name[0]= name[1]= 'a'; i=aa_count++;  }
	else
	{
		j=h=((*s<<4)+c)%SIZE;           /* Hashfunction. */

		i=0; c=true;
									 /* Search until  */
		while (hashtbl[j].count!=0 and not                       /* free place or */
		       (hashtbl[j].c1== *s and hashtbl[j].c2== *(s+1)) ) /* string found. */
		{
			if (c) { i++; j=(h+i*i)%SIZE; }
			else j=SIZE-j;
			if (i>SIZE/2)
				printf("Table overfloat in unique_name"), finish(-99);
			c=not c;
		}
		i=hashtbl[j].count++;        /* Increment occurency counter. */
		if (i==0)                    /* If no string found, */
		{ hashtbl[j].c1= *s; hashtbl[j].c2= *(s+1); }
	}				    /* insert new string.  */
	if (i>0xFFF) printf("Index overfloat in unique_name"), finish(-99);

	for (j=5; j>=3; j-- , i/=0x10 )
	{       c=i%0x10;                       /* Create unique name. */
		name[j]= c>9?'A'+c-10:'0'+c;    /* Format: "_%03x"     */
	 }
	name[2]='_';  name[6]='\0';
#undef SIZE
	return  symins (name) ;
} /*uniquename*/                                /*  u n i q u e n a m e  */
						/*-----------------------*/


local char  newname[FILENAME_MAX+3];

					/*-------------------------------------*/
#ifdef LINT_ARGS
global void initmoduniquename  ( void)
#else
global void initmoduniquename ()     /*  i n i t m o d u n i q u e n a m e  */
#endif
BEGIN (initmoduniquename)
  int i;

  strcpy (newname, prognam());

  if  (namelength > 0  and  namelength <= FILENAME_MAX)
    newname[namelength-2] = '\0';
  for (i=strlen(newname);i>0;i--)
    newname[i+2] = tolower(newname[i]);

  newname[0] = tolower(newname[0]);
  newname[1] = '0';
  newname[2] = '0';

  strcpy (initname, newname);

END /* initmoduniquename */          /*  i n i t m o d u n i q u e n a m e  */
				     /*-------------------------------------*/


					/*-----------------------------*/
#ifdef LINT_ARGS
global symptr moduniquename  ( void)
#else
global symptr moduniquename ()          /*  m o d u n i q u e n a m e  */
#endif
BEGIN (moduniquename)
  static  char sequence[37] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" ;
  static  byte    chr2 = 0;
  static  byte    chr3 = 1;

  newname[1] = sequence [chr2];
  newname[2] = sequence [chr3];

  if (++chr3 == 36) {
    chr3 = 0;
    if (++chr2 == 36) {
      errput (5220, pos, NULL);
      /*
       *  "too many names to rename with moduniquename."
       */
    }
  }

  return (symins(newname));

END /* moduniquename */                 /*  m o d u n i q u e n a m e  */
					/*-----------------------------*/


#ifdef IDDUMP
#ifdef LINT_ARGS
global void iddump (  void)
#else
global void iddump()
/* dumps the binary tree of identifiers requested from terminal */
#endif
{
  int i ;
  char name [128];             /* name read from terminal */
  idptr id ;                   /* pointer to  "  */
  static char typname [25] [20] ;      /* texts of idkind */
  static boolean typnameundef = true ;

  if (typnameundef) then               /* initialize */
   begin
    for (i = 0; i < 25; i++)
      typname [i][0] ='\0' ;
    strcpy (typname [ IDPROGRAM         ], "PROGRAM"        ) ;
    strcpy (typname [ IDCONST           ], "CONST"          ) ;
    strcpy (typname [ IDTYPE            ], "TYPE"           ) ;
    strcpy (typname [ IDFUNCTION        ], "FUNCTION"       ) ;
    strcpy (typname [ IDPROCEDURE       ], "PROCEDURE"      ) ;
    strcpy (typname [ IDMODULE          ], "MODULE"         ) ;
    strcpy (typname [ IDRES1VAR         ], "RES1VAR"        ) ;
    strcpy (typname [ IDVAR             ], "VAR"            ) ;
    strcpy (typname [ IDPARAM           ], "PARAM"          ) ;
    strcpy (typname [ IDVALPARAM        ], "VALPARAM"       ) ;
    strcpy (typname [ IDVARPARAM        ], "VARPARAM"       ) ;
    strcpy (typname [ IDRES2VAR         ], "RES2VAR"        ) ;
/*    strcpy (typname [ IDDEN1VAR         ], "DEN1VAR"        ) ;
    strcpy (typname [ IDDEN2VAR         ], "DEN2VAR"        ) ;
    strcpy (typname [ IDDEN3VAR         ], "DEN3VAR"        ) ;
    strcpy (typname [ IDRECKOMP         ], "RECKOMP"        ) ;*/
    typnameundef = false ;
   end ;   /* initialization */

 printf ("Id dump\n") ;
 do
 { fprintf (stderr, "id to be dumped? ") ;
   scanf ("%s", name) ;
   if  (not isletter(name[0]) ) break ;
   if  ((id=idfnd( symins (name)))!=NULL)
   {
     printf ("Structure of %s %s:\n", typname [id->kind],
				      symtab( symins( name))) ;
     dump (iddatyp(id)) ;
   } else printf ("%s not found\n", symtab ( symins (name)) ) ;
 } while (not isletter(name[0])) ;
} /*iddump*/
#endif


/*-----------------------------------------------*/
/*------------- Aendern -------------------------*/
/*-----------------------------------------------*/

#ifdef LINT_ARGS
global void idsetkind (  idptr id,idkind kind)
#else
global void idsetkind(id,kind)
/* Sets the type of 'id' to 'kind'.     */
idptr id;
idkind kind;
#endif
{
	if (id==idBAD_ID)  return ;  /* do not modify bad id */
	if (id) id->kind=kind;
	else
	{    errput (9624, pos, "idsetkind");
	   /*  print("Illegal use of idsetkind");
	     printline();  */
	}
} /*idsetkind*/

#ifdef LINT_ARGS
global void idsetwith ( idptr id,binptr with)
#else
global void idsetwith(id,with)
idptr id;
binptr with;
#endif
{
	if (id==idBAD_ID)  return ;  /* do not modify bad id */
	if (id and id->kind==IDVAR ) id->with=with;
	else
	{    errput (9621, pos, "idsetwith");
	   /*  print("Illegal use of idsetwith");
	     printline(); */
	}
} /*idsetwith*/

						/*-----------------------*/
#ifdef LINT_ARGS
global void idsetdatyp(idptr id,binptr type)    /*  i d s e t d a t y p  */
#else
global void idsetdatyp(id,type)
idptr id;
binptr type;
#endif
{       idptr typid = binid (type) ;

	if (id==idBAD_ID)  return ;  /* do not modify bad id */
	if (id)
	{       id->st=type;
		if  (typid)     /* copy flags from named data type */
		{
		   id->status.dynamic   = typid->status.dynamic ;
		   id->status.arraytype = typid->status.arraytype ;
		   id->status.desctype  = typid->status.desctype ;
		   id->status.hasdyn    = typid->status.hasdyn ;
		} else
		{  symctype code = binsymc (type) ;
		   id->status.arraytype = sym_is [code].arraytype ;
		   id->status.dynamic   =
		   id->status.desctype  = code==cDYNAMIC ;
		   /* hasdyn must be set by decl.c */
		}
	} else
	{    errput (9624, pos, "idsetdatyp");
	   /*  print("Null pointer in idsetdatyp");
	     printline();  */
	}

} /*idsetdatyp*/

					    /*---------------------------*/
#ifdef LINT_ARGS
global void idsetparlist ( idptr id,binptr parlist)
#else
global void idsetparlist(id,parlist)        /*  i d s e t p a r l i s t  */
idptr id;
binptr parlist;
#endif
{
	if (id==idBAD_ID)  return ;  /* do not modify bad id */
	if (id and
	    (id->kind==IDFUNCTION or id->kind==IDPROCEDURE))
	   id->with=parlist;
	else
	{    errput (9621, pos, "idsetparlist");
	   /*  print("Illegal use of idsetparlist");
	     printline();  */
	}
} /*idsetparlist*/

						/*-----------------------*/
#ifdef LINT_ARGS
global void idsetvalue ( idptr id,binptr value)
#else
global void idsetvalue(id,value)                /*  i d s e t v a l u e  */
idptr id;
binptr value;
#endif
{
	if (id==idBAD_ID)  return ;  /* do not modify bad id */
	if (id and id->kind==IDCONST) id->with=value;
	else
	{    errput (9621, pos, "idsetvalue");
	   /*  print("Illegal use of idsetvalue");
	     printline(); */
	}
} /*idsetvalue*/

					      /*---------------------*/
#ifdef LINT_ARGS
global void idsetcsym  (  idptr id ,symptr csym )
#else
global void idsetcsym (id,csym)               /*  i d s e t c s y m  */
/* sets the C-symbol of the current routine to sym */
/* used for external specification with runtime name */
idptr id ;
symptr csym ;
#endif
{
   if (id==idBAD_ID)  return ;  /* do not modify bad id */
   if (id) id->csym = csym ;
   else
   {    errput (9624, pos, "idsetcsym");
      /*  print("NULL pointer in idsetcsym");
	printline(); */
   }
} /*idsetcsym*/

					      /*-------------------*/
#ifdef LINT_ARGS
global void idsetbin  ( idptr id,binptr bin)
#else
global void idsetbin (id,bin)                 /*  i d s e t b i n  */
idptr id;
binptr bin;
#endif
{
   if (id==idBAD_ID)  return ;  /* do not modify bad id */
   if (id) id->bin = bin;
   else
   {    errput (9624, pos, "idsetbin");
      /*  print("NULL pointer in idsetbin");
	printline();  */
   }
} /*idsetbin*/


/*-----------------------------------------------*/
/*----------- Zugriff ---------------------------*/
/*-----------------------------------------------*/

#ifdef LINT_ARGS
global idflags *idflag ( idptr id,boolean set)
#else
global idflags *idflag(id,set)
idptr id;
boolean set;
#endif
{       static idflags dummy ;
	idflags *ret;

	if (id) ret= &(id->status);
	else
	{       if (set)
		{    errput (9622, pos, "idflag");
		   /*  print("NULL-Pointer assignment in idflag");
		     printline(); */
		}
		dummy = idfinit ;
		ret= &dummy;
	}
	return ret;
} /*idflag*/

#ifdef LINT_ARGS
global shortint idlevel ( idptr id)
#else
global shortint idlevel(id)
idptr id;
#endif
{       if (id) return id->level;
	else
	{
#ifdef ID_CHECK
      errput (9624, pos, "idlevel");
  /*  print("Null pointer in idlevel");
      printline();  */
#endif
		return IDNOLEVEL;
	}
} /*idlevel*/

#ifdef LINT_ARGS
global symptr idsym (  idptr id)
#else
global symptr idsym(id)
/* Return C-symbol of 'id'.     */
idptr id;
#endif
{       symptr sym;

	if (id) sym=id->sym;
	else
	{
#ifdef ID_CHECK
  errput (9624, pos, "idsym");
   /* print("Null pointer in idsym");
  printline();  */
#endif
		sym=symNIL;
	}
	return sym;
} /*idsym*/

#ifdef LINT_ARGS
global symptr idcsym (  idptr id)
#else
global symptr idcsym(id)
/* Return Pascal-symbol of 'id'.        */
idptr id;
#endif
{       symptr csym;

	if (id) csym=id->csym;
	else
	{
#ifdef CHECK
  errput (9624, pos, "idcsym");
  /* print("Null pointer in idcsym");
  printline(); */
#endif
		csym=symNIL;
	}
	return csym;
} /*idcsym*/

#ifdef LINT_ARGS
global idkind idgetkind (  idptr id)
#else
global idkind idgetkind(id)
/* Return the type of 'id'.     */
idptr id;
#endif
{       if (id) return id->kind;
	else
	{
#ifdef  ID_CHECK
  errput (9624, pos, "idgetkind");
  /*  print("Null pointer in idgetkind");
    printline(); */
#endif
		return IDNONE;
	}
} /*idgetkind*/

#ifdef LINT_ARGS
global binptr iddatyp (  idptr id)
#else
global binptr iddatyp(id)
/* Returns data type or result type of 'id'.     */
idptr id;
#endif
{
	if (id) return  id->st;
	else    return  anytype ;
} /*iddatyp*/

#ifdef LINT_ARGS
global binptr idbin ( idptr id)
#else
global binptr idbin(id)
idptr id;
#endif
{       binptr bin;

	if (id) bin=id->bin;
	else
	{
#ifdef CHECK
  errput (9624, pos, "idbin");
  /* print("Null pointer in idbin");
  printline(); */
#endif
		bin=NULL;
	}
	if (not bin and id)     /* missing idsetbin */
	{
#ifdef ID_CHECK
	    errput (9627, pos, symtab (idsym (id)));
		      /* idsetbin missing for @ */
#endif
	    bin = binidcreate (cIdent, id) ;
	    id->bin = bin ;
	}
	return bin;
} /*idbin*/

#ifdef LINT_ARGS
global binptr idparlist (  idptr id)
#else
global binptr idparlist(id)
/* Return formal parameter list of 'id'.        */
idptr id;
#endif
{       binptr st;

	if (id)
	{       if (id->kind==IDFUNCTION or id->kind==IDPROCEDURE)
			st=id->with;
		else st=NULL;
	} else
	{
#ifdef CHECK
  errput (9624, pos, "idparlist");
  /* print("Null pointer in idparlist");
  printline(); */
#endif
		st=NULL;
	}
	return st;
} /*idparlist*/

#ifdef LINT_ARGS
global binptr idwith (  idptr id)
#else
global binptr idwith(id)
/* Return pointer to with-expression of 'id'.   */
idptr id;
#endif
{       binptr st;

	if (id)
	{       if (id->kind==IDVAR /*or id->kind==IDDEN1VAR*/) st=id->with;
		else st=NULL;
	} else
	{
#ifdef CHECK
  errput (9624, pos, "idwith");
  /*  print("Null pointer in idwith");
  printline();  */
#endif
		st=NULL;
	}
	return st;
} /*idwith*/

#ifdef LINT_ARGS
global binptr idvalue (  idptr id)
#else
global binptr idvalue(id)
/* Return pointer to value of constant. */
idptr id;
#endif
{       binptr st;
	if (id)
	{       if (id->kind==IDCONST) st=id->with;
		else st=NULL;
	} else
	{
#ifdef CHECK
  errput (9624, pos, "idvalue");
  /*  print("Null pointer in idvalue");
  printline(); */
#endif
		st=NULL;
	}
	return st;
} /*idvalue*/




/* looks for userdef. type conversion function with given name, parameter
   and result type
*/
#ifdef LINT_ARGS
global idptr idfuncfnd ( symptr sym,idptr par_type , idptr res_type)
#else
global idptr idfuncfnd(sym, par_type, res_type )   /* i d f u n c t f n d */
  symptr sym;
  idptr par_type , res_type;
#endif
{       idptr        id;
	blockptr     block;

	block=actblock;

	while (block)
	{   id=blkid(block);
	    do
	    {   id=idtreefnd(id,sym);

		while (id and sym==id->sym) {   /* search in linear list */
		  IF id->kind != IDTYPE and
		    /* */
		    (par_type == binid(idparlist(id)) and
		     res_type == binid(iddatyp(id))    and
		     binright(idparlist(id))== NIL /* one parametr */
		     )
		  THEN
		     {  /* printf("\n return %s",symtab(id->sym));*/
		     return id;                             }
		  ELSE id=id->idl;
		  FI
		/*printf("\n %s found",symtab(id->sym)); */
		}
	    } while (id);   /* next linear list */

	    block=blkfather(block);
	}
   /*     printf("\n return NULL");*/
	return NULL;
} /*idfuncfnd*/


/*------------------------------------------------------------------------*/
/*  b i n p a r c o m p a r e */
#ifdef LINT_ARGS
global boolean binparcompare  (  binptr listf, binptr lista )
#else
global boolean binparcompare ( listf, lista )
 /* see idtab.dok */
  binptr listf, lista ;
#endif
BEGIN(binparcompare)
  binptr f_left, a_left ;
  WHILE listf and lista and
	 (binid (listf)  == binid  (lista))
       or
	 (  (binsymc(listf) == cFUNCTION or binsymc(listf) == cPROCEDURE)
	  and
	    binsymc(listf) == binsymc(lista)
	 )
  DO
    IF   binsymc(listf) == cFUNCTION  and
	 /*Paramlists or result types  do not coincide */
	 not (
	      binparcompare(binleft(f_left = binleft(listf)),
			    binleft(a_left = binleft(lista)))
	    and
	      binid(binright(f_left)) == binid(binright(a_left))
	     )
       or
	 binsymc(listf) == cPROCEDURE and
	  /*Paramlists do not coincide */
	 not  binparcompare(binleft(listf),binleft(lista))
    THEN
      return false;
    FI
    listf = binright (listf) ;
    lista = binright (lista) ;
  OD
  return (listf == NIL  and  lista == NIL) ;
END /* binparcompare */




						/*---------------------*/
						/*  i d r o u t f n d  */
#ifdef LINT_ARGS
global idptr idroutfnd  (idkind cc, symptr sym, binptr actparlist,
			 boolean with_coers)
#else
global idptr idroutfnd (cc, sym, actparlist,with_coers )
/*
  Searches with the  scope in actual block,
  for either function or procedure "sym",
  depending on the par. "cc"
  with parameter list "actparlist"
  either using coersions or not, depending on the par. "with_coers"
*/
  idkind cc;  /* callclass */
  symptr sym;
  binptr actparlist;
  boolean with_coers;
#endif
{
  idptr        id;
  idkind kind;
  blockptr     block;

  idptr temp_id = NULL ;
  int n_coers = NOCOERS ;
  boolean monosem = false ;
  int i;
  boolean innerused=false; /* Identifier is defined in the current block */

#define SET_INNERUSED(id)                      \
 IF  innerused and                             \
   /* The routine is a formal parametr */      \
    id_is(id,formpara)    and                  \
    id->level>IDMAINLEVEL                      \
 THEN                                          \
   /* Identifier is used in interior block */  \
    idfset(id,innerused);                      \
 FI

/*        printf("\n Search for %s",symtab(sym));*/
	block=actblock;

	/* Searches from current to exterior blocks */
	while (block)
	{  id = blkid(block) ;
	    do
	    {   id=idtreefnd(id,sym);
		/*printf("\n %s found",symtab(id->sym));*/
		IF id == NULL and not blk_is(block,iswith) THEN
		  /* Defined somewhere in  the exterior block */
		    innerused = true;
		FI

		while (id and sym==id->sym) {   /* search in linear list */
		   kind=idgetkind(id);
		   IF (kind != IDTYPE) and (kind == cc) THEN
		     IF not with_coers THEN
			IF binparcompare(idparlist(id),actparlist)THEN
			  SET_INNERUSED(id);
			  return id;
			FI
		     ELSE
		       i = binncoers(actparlist,idparlist(id)) ;
		       IF i == 0 THEN
			 SET_INNERUSED(id);
			 return id;
		       ELIF i == n_coers and i != NOCOERS THEN
			 IF not binparcompare(idparlist(id),
					      idparlist(temp_id))
			 THEN
			   monosem = false;
			 FI
		       ELIF i < n_coers  THEN
			 temp_id = id;
			 n_coers = i;
			 monosem = true;
		       FI
		     FI
		   FI
		   id=id->idl;
		/*printf("\n %s found",symtab(id->sym)); */
		}
	    } while (id);   /* next linear list */

	    block=blkfather(block);
	}
	IF temp_id and (not monosem) THEN
	  /* Two or more subprograms conform to the palist */
	  errput (5210, pos, (char*)0);
	 /* print("Ambiguous parameter types in  subprogram call");
	  printline(); */
	FI

	IF with_coers THEN
	  id = temp_id;
	FI
	SET_INNERUSED(id);
	return id;
} /*idroutfnd*/

/* Is the function a type identifier */
#ifdef LINT_ARGS
global idptr idistypeid ( binptr exp)
#else
global idptr idistypeid(exp)
 binptr exp;
#endif
begin
 idptr idp ;
 if  (not binid (exp))    return (idptr)0;
 idp = idtypfnd (idsym(binid(exp))) ;
 IF  idp and idgetkind (idp) == IDTYPE
 THEN
   return idp;
 ELSE
   return (idptr)0;
 FI
end






