/*
 *  MODULE:  bintab.c
 *  binary tree operations
{*  last modification:	17.08.92  15:40   }


 *  Uli 13.11.90: idSTRING added in unname,
 *                request for symbol nodes deleted in unname
 *  Uli 19.11.90: cTemptype added in unname and baptize,
 *  Uli 10.12.90: baptize calls moduniquename
 *  Uli 07.01.91: binldelete accepts cPROCEDURE and cFUNCTION
 *  Dima 08.01.91: binparcompare and binncoers
		   accept cPROCEDURE and cFUNCTION
 *  Uli 15.01.91: FREECHECK added

 *  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
 *  Uli 23.01.91: bintdelete does not delete freed trees.
		  binappend and binlside accept q==NIL.
 *  Uli 28.01.91: bintdelete checks for leftexpr.
 *  Uli 12.02.91: binget: binqueue added.
 * Dima 13.02.91:  binparcompare & binncoers moved to idtab
		   compatible is named typ_compatible and made global
 *  Uli 19.02.91: bininsert appends right of q, if it cannot append left
 *  Uli 22.02.91: new style headers
 *  uli 30.04.91 : binend, binf_stm added
 *  uli 06.05.91 : bincpool added
 *  uli 08.05.91 : rconstype added.
 *  Uli 15.05.91: bintdelete does not delete rightside types (rightexpr!).
 *  Dima 13.06.91: bini_stm & binf_stm deleted; binlist added
 *  Dima 17.06.91 : tlist, tlistend added
 *  uli 05.07.91 : typ_compatible : handle of symbol nodes corrected.
 *  Dima 09.07.91 : typ_compatible : sub_or_base_of added
		    subtypes are not compatible to each other now
 * Dima 15.07.91 : binlist made void
 *  uli 22.07.91 : binlist: old style header corrected.
 *  uli 03.09.91 : bincopy returns NIL, if arg is NIL.
 *  uli 28.10.91 : binget: fat added to remove node.
 * Dima 22.11.91 : typ_compatible moved to optab
 *  uli 28.11.91 : binupsym no longer checks its parameter sym.
 *  uli 28.11.91 : binget: reconstruct bad id , if symNIL in binqueue.
 *  uli 29.11.91 : binchanges checks cNosym now.
 *  uli 21.02.92 : strtoint added
 *  uli 24.02.92 : bincompare : strcmp added. symc added, binleft replaced.
 *  uli 23.06.92 : errno no longer used.
 *  PJ  08.07.92 : tempid in binproc for LINT_ARGS changed to sym
 *  PJ  31.03.95 : Casts for ANSI compatibility added.
*/

#define CHECK

#define FREECHECK
			/* nodes to be freed are not added to freelist, */
			/* but marked as freed (cNosym). Each access    */
			/* to a node checks for nodes freed by mistake. */

#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <limits.h>
/* #include <errno.h> no longer used */
/* extern  int errno ; */

#include            "impor.t"
#include "error.h"
#include "scan.h"
#include "symtab.h"
#include "idtab.h"
#include "optab.h"
#include "blktab.h"

#include            "expor.t"
#include "bintab.h"

#include            "implemen.t"


binptr  tlist = NIL ;
binptr  tlistend =  NIL ;
binptr  bincurr  = NIL ;
binptr  binprev  = NIL ;
binptr  binqueue = NIL ;
binptr  binstm   = NIL ;
binptr  binend   = NIL ;
binptr  bincpool = NIL ;
binptr  freelist = NIL ;

local   int     MAX_ALLOC = 127;  /* konstante mit define ???? */
				/* number of bintab nodes allocated at once */

#ifdef LINT_ARGS
#ifdef FREECHECK
local void freecheck (binptr p) ;
#endif
local long strtoint (char * s) ;
local binptr  binalloc   (void);
#else
local long strtoint () ;
local binptr  binalloc   ();
#endif


							/*-------------------*/
#ifdef LINT_ARGS
local long strtoint ( char * s )			/*  s t r t o i n t  */
  /* converts a string to long int, */
  /* atol doesn't check overflow! */
#else
local long strtoint ( s )
  char * s ;
#endif
BEGIN(strtoint)
  long val = 0 ;

  while (*s)
    begin
      if  ((LONG_MAX-(*s-'0')) / 10 < val)
        begin
          errput (5001, pos, NULL) ;
          break ;
        end ;
       val = val*10 + *s - '0' ;
       s++ ;
    end ;
  return val ;
END /* strtoint */					/*  s t r t o i n t  */
							/*-------------------*/


#ifdef FREECHECK

#ifdef LINT_ARGS
local void freecheck  ( binptr p )
#else
local void freecheck (p)                             /*  f r e e c h e c k  */
  binptr p ;
#endif
BEGIN(freecheck)
  if  (p and p->symc == cNosym)   errput (9559, p->pos, (char*)0) ;
END /* freecheck */                                  /*  f r e e c h e c k  */
							/*---------------------*/
#else
#define freecheck(p)
#endif


							/*-------------------*/
#ifdef LINT_ARGS
local binptr  binalloc ( void)
#else
local binptr  binalloc()                                /*  b i n a l l o c  */
#endif
{
  binptr temp;
  int i;

  if (not freelist) {
    freelist = (binptr) calloc(MAX_ALLOC, sizeof(struct bin));
    while (not freelist) {
      MAX_ALLOC /= 2;
      freelist =  ((binptr) calloc(MAX_ALLOC, sizeof(struct bin)));
      if (MAX_ALLOC < 2)  memerror (pos) ;
    }
    temp = freelist;
    for (i=1;i<MAX_ALLOC;i++) {
      temp->right = temp + 1 ;
      temp += 1;
    }
  }

  temp = freelist;
#ifdef CHECK
  if  (temp->symc != cNosym)
    begin
      errput (9501, temp->pos, symptext [temp->symc]) ;
     /* print ("binalloc: Undeleted node in freelist: ");
      print (symptext [temp->symc]) ;
      printline () ; */
    end
#endif
  freelist = freelist->right;
  temp->right = NIL;
  temp->father = NIL;
  return(temp);
}                                                       /*  b i n a l l o c  */
							/*-------------------*/


						/*---------------------*/
#ifdef LINT_ARGS
global binptr  bincreate ( symctype symc)
#else
global binptr  bincreate(symc)                  /*  b i n c r e a t e  */
symctype symc;
#endif
{
    binptr  temp;

    if ((temp= binalloc()) != NULL) {
	temp->father  = NIL;
	temp->pt.left = NIL;
	temp->symc    = (byte)symc;
	temp->pos     = pos;
    }  else  memerror (pos) ;
    return(temp);
}                                               /*  b i n c r e a t e  */
						/*---------------------*/


							/*---------------*/
#ifdef LINT_ARGS
global void binget (  void)
#else
global void binget()                                    /*  b i n g e t  */
  /* gets the next symbol from the look ahead queue, */
  /*  if the queue is not empty or */
  /* reads the next symbol using getsym */
  /* creates a symbol table entry sym, if neccessary */
  /* and checks end of file situation. */
  /* creates a bintab-node containing the symbol */
#endif
BEGIN(binget)
 char * tempstring ;
 static boolean posteof = false ;

  if  (binqueue)  then          /* look ahead queue is not empty */
    begin   binptr fat = binqueue->father ;

      if  (bincurr)   binkill (bincurr) ;
      bincurr = binqueue ;              /* get symbol from look ahead queue */
      binqueue = binqueue->right ;
      if  (binqueue)   binqueue->father = fat ;
      if  (fat)    fat->right = binqueue ;     /* remove node from queue */
      bincurr->right = NIL ;
      bincurr->father   = NIL ;
      pos = bincurr->pos ;
      if  ((symctype) bincurr->symc == cCsymbol)
       begin                            /* has been identifier */
	 sym = bincurr->pt.sym ;
	 if  (sym == symNIL)  then
	   symc = cIdent ;              /* bad identifier */
	 else
	   symc = symsymc (sym) ;       /* get symc from symtab */
	 if  (symc == cCsymbol)   symc = cIdent ;
	 bincurr->symc = (byte) symc ;
	 bincurr->pt.id = (idptr) NIL ;
	 return ;
       end
      else
       if  (sym_is [bincurr->symc].value)      /* update symvalue */
	  symvalue = bincurr->pt.value ;
       else
       if  (sym_is [bincurr->symc].userdefined)
	 if  (not sym_is [bincurr->symc].symbol)
	  begin
	    symstring = bincurr->pt.charp ;       /* string or real */
	    symvalue = strlen(symstring) ;
	  end
	 else ;
       else
       if  (sym_is [bincurr->symc].leftbin)
	   bincurr->pt.left = NIL ;

       /* PJ 31.03.95  cast to symctype added */
       symc = (symctype) bincurr->symc ;
       return ;
    end /* look ahead queue was not empty */
    /* else get symbol from source file */


  symc = getsym (&symstring) ;                  /* read symbol */

  if  (bincurr)  then                           /* use old node */
   begin
#ifdef CHECK
     if ( bincurr->right or bincurr->father)
       begin
	 errput (9502, pos, (char*)0) ;
	/* print ("Node to be overwritten is found in tree.");
	 printline () ; */
       end
     else ;
#endif
     binchange   (bincurr, symc) ;
     bincurr->pt.left = NIL ;
     bincurr->father  = NIL ;
     bincurr->right   = NIL ;
  end
  else
     bincurr = bincreate (symc) ;               /* create new node */
  binuppos (bincurr, pos) ;

  if  (symstring)  then
    switch (symc)
     begin
      case cIcon :
	begin
	  symvalue = strtoint (symstring) ;	/* convert integer constant */
	  binupvalue (bincurr, symvalue) ;
          /* atol replaced by strtoint 21.02.92 
	  if  (errno==ERANGE)  then
	    begin
	      errput (5001, pos, (char*)0) ;
	     / * print ("Integer constant exceeds integer range.") ;
	      printline () ; * /
	    end ;
	   */
					   break ;
	end ;
      case cCcon :
	begin					/* assign char constant */
	  symvalue = (long int) symstring [0] ;
	  binupvalue (bincurr, symvalue) ;
					   break ;
	end ;
      case cScon : ;                            /* store string or */
      case cRcon :                              /*       real constant */
	begin
	  symvalue = strlen(symstring) ;
	  tempstring = (char*) malloc ((size_t) symvalue +1) ;
	  if (not tempstring) then   memerror (pos) ;
	  strcpy (tempstring, symstring) ;
	  symstring = tempstring ;
	  binupcharp (bincurr, symstring) ;
					   break ;
	end ;
      default :                                 /* enter into symtab */
	sym= symcins (symstring, &symc) ;
	binchange (bincurr, symc) ;
      /*  if  (sym_is[symc].identifier) then NIL */
	if  (sym_is[symc].symbol)  then
	  binupsym (bincurr, sym) ;             /* assign sym */
     end /* switch symc */ ;

 if (symc==cEndofSrc and not posteof) then   /* End of File situation */
  begin
   errput (5002, pos, (char*)0) ;
  /* print ("Unexpected EOF") ;
   printline () ; */
   posteof= true ;
  end

 binuppos (bincurr, pos) ;
END /* binget */                                        /*  b i n g e t  */
							/*---------------*/

					       /*------------------------*/
#ifdef LINT_ARGS
global binptr  binidcreate ( symctype symc ,idptr id)
#else
global binptr  binidcreate(symc, id)           /* b i n i d c r e a t e  */
  symctype symc ;
  idptr id;
#endif
BEGIN (binidcreate)
  binptr temp;

#ifdef CHECK
    if (not sym_is [symc] .identifier) {
	errput (9503, pos, symptext[symc]);
       /* print ("binidcreate : symc = ");
	print (symptext[symc]) ;
	printline (); */
    }
#endif

  if ((temp=binalloc()) != NULL) {
    temp->symc   = (byte) symc;
    temp->pt.id  = id;
    temp->pos    = pos;
    temp->father = NIL;
  }  else  memerror (pos) ;

  return (temp);
END  /* binidcreate */                         /* b i n i d c r e a t e  */
					       /*------------------------*/

					       /*------------------------*/
#ifdef LINT_ARGS
global binptr  binsycreate ( symptr sym)
#else
global binptr  binsycreate(sym)                /* b i n s y c r e a t e  */
symptr sym;
#endif
BEGIN (binsycreate)
binptr temp;

    if ((temp=binalloc()) != NULL) {
      temp->symc   = (byte) cCsymbol;
      temp->pt.sym = sym;
      temp->father = NIL;
      temp->pos    = pos;
    }  else  memerror (pos) ;

  return (temp);
END  /* binsycreate */                         /* b i n s y c r e a t e  */
					       /*------------------------*/


/*-----------------------------------------------*/
/*------------Baumoperationen--------------------*/
/*-----------------------------------------------*/

/* binsuffix : installiert *bincurr als rechtes Blatt von binprev,
	   binprev->right sollte nil sein.
	   binprev zeigt danach auf den neu installierten Knoten,
	   bincurr zeigt auf NIL.
*/
#ifdef LINT_ARGS
global void binsuffix ( void)
#else
global void binsuffix()
#endif
{
#ifdef CHECK
    if (binprev == NIL) {
      errput (9504, pos, "binsuffix");
     /* print ("binsuffix : binprev == NIL.");
      printline (); */
      return ;
    }
    if (bincurr == NIL) {
      errput (9505, pos, "binsuffix");
     /* print ("binsuffix : bincurr == NIL.");
      printline (); */
      return ;
    }
    if (binprev->right != NIL) {
      errput (9515, binpos(binprev), "binsuffix");
			       /* binsuffix : binprev->right != NIL. */
    }
    if (not sym_is [binprev->symc].rightbin) {
      errput (9557, binpos(binprev), "binsuffix");
			       /* binsuffix : not right-son node. */
      return ;
    }
    if (bincurr->father != NIL) {
      errput (9508, pos, "binsuffix");
			     /* binsuffix : bincurr->father != NIL. */
    }
    if (bincurr->right != NIL) {
      errput (9509, pos, "binsuffix");
			    /* binsuffix : bincurr->right != NIL */
    }
    if (sym_is [binsymc(bincurr)].leftbin and bincurr->pt.left != NIL)
      begin
      errput (9510, pos, "binsuffix") ;
			  /* binsuffix : bincurr->pt.left != NIL */
      end
#endif
    freecheck (binprev) ; freecheck (bincurr) ;

    bincurr->father = binprev;

    bincurr->right  = binprev->right;
    binprev->right  = bincurr;

    binprev         = bincurr;
    bincurr         = NIL;
}

/*-----------------------------------------------*/
/* bininfix : *binprev sollte ein rechter Sohn sein;
	  bininfix setzt *bincurr an die Stelle von *binprev und
	  *binprev als linken Sohn von *bincurr, das heisst,
	  der Baum wird von binprev aus nach rechts fortgesetzt.
	  Nach dieser Operation zeigt binprev auf bincurr
	  und bincurr auf NIL.
*/
#ifdef LINT_ARGS
global void bininfix ( void)
#else
global void bininfix()
#endif
{
    binptr fat ;

    freecheck (binprev) ; freecheck (bincurr) ;
#ifdef CHECK
    if (binprev == NIL) {
      errput (9504, pos, "bininfix");
		 /* bininfix : binprev == NIL. */
      return ;
    }
    if (bincurr == NIL) {
      errput (9505, pos, "bininfix");
		 /* bininfix : bincurr == NIL. */
      return ;
    }
#endif
    fat = binprev->father ;
#ifdef CHECK
    if (fat == NIL) {
      errput (9506, binpos(binprev), "bininfix");
		  /* bininfix : father == NIL. */
      return ;
    }
    if (fat->right != binprev) {
      errput(9507, pos, "bininfix");
		   /* bininfix : binprev != rechter Sohn */
    }
    if (bincurr->father != NIL) {
      errput(9508, pos, "bininfix");
		   /* bininfix : bincurr->father != NIL */
    }
    if (bincurr->right != NIL) {
      errput(9509, pos, "bininfix");
		   /* bininfix : bincurr->right != NIL */
    }
    if (bincurr->pt.left != NIL) {
      errput(9510, pos, "bininfix");
		   /* bininfix : bincurr->pt.left != NIL */
    }
#endif

    bincurr->father  = fat;
    fat->right = bincurr;
    binprev->father  = bincurr;
    bincurr->pt.left = binprev;

    binprev          = bincurr;
    bincurr          = NIL;
} /* bininfix */

/*-----------------------------------------------*/
/* binopinfix : *bincurr ist ein benutzerdefinierter Operator.
	  *binprev sollte ein rechter Sohn sein;
	  binopinfix setzt *bincurr an die Stelle von *binprev,
	  einen Dummyknoten gleicher Prioritaet als linken Sohn,
	  und *binprev als linken Sohn des Dummys, das heisst,
	  der Baum wird von binprev aus nach rechts fortgesetzt.
	  Nach dieser Operation zeigt binprev auf bincurr
	  und bincurr auf NIL.
*/
#ifdef LINT_ARGS
global void binopinfix ( void)
#else
global void binopinfix()
#endif
{
    binptr fat   = binprev->father ;
    /* PJ 31.03.95  Cast to symctype added */
    binptr dummy = bincreate( (symctype) ( binsymc(bincurr)
                                           + ( cReldmy - cRelop ) ) );

    freecheck (binprev) ; freecheck (bincurr) ;
#ifdef CHECK
    if (binprev == NIL) {
      errput (9504, pos, "binopinfix");
		      /* binopinfix : binprev == NIL. */
    }
    if (bincurr == NIL) {
      errput (9505, pos, "binopinfix");
		      /* binopinfix : bincurr == NIL. */
    }
    if (fat->right != binprev) {
      errput(9507, pos, "binopinfix");
		      /* binopinfix : binprev != rechter Sohn */
    }
    if (bincurr->father != NIL) {
      errput(9508, pos, "binopinfix");
		      /* binopinfix : bincurr->father != NIL */
    }
    if (bincurr->right != NIL) {
      errput(9509, pos, "binopinfix");
		      /* binopinfix : bincurr->right != NIL */
    }
#endif

    bincurr->father  = fat;
    fat->right = bincurr;
    binprev->father  = dummy;
    bincurr->right   = dummy;
    dummy->father    = bincurr;
    dummy->pt.left   = binprev;

    binprev          = dummy;
    bincurr          = NIL;

END  /* binopinfix */

/*-----------------------------------------------*/
/* binprefix : binprev->pt.left muss NIL sein;
	   binprefix haengt den rechten Teilbaum nach links.
*/
#ifdef LINT_ARGS
global void binprefix ( void)
#else
global void binprefix()
#endif
{
    freecheck (binprev) ; freecheck (bincurr) ;
#ifdef CHECK
    if (binprev == NIL) {
      errput (9504, pos, "binprefix");
		     /* binprefix : binprev == NIL. */
      return ;
  }
    if (binprev->pt.left != NIL) {
      errput(9511, pos, "binprefix");
		     /* binprefix : binprev->pt.left != NIL */
    }
    if (not sym_is [binprev->symc].leftbin) {
      errput (9558, binpos(binprev), "binprefix");
			       /* binprefix : not left-son node. */
      return ;
    }
#endif

    binprev->pt.left  = binprev->right;
    binprev->right    = NIL;
}

/*--------------------------------------------------------------------------*/
/* binexchange :                                 /*  b i n e x c h a n g e  */
/*         exchanges the left and right son of p.
*/
#ifdef LINT_ARGS
global void binexchange  ( binptr p )
#else
global void binexchange (p)
  binptr p ;
#endif
{
  register binptr q ;

    freecheck (p) ;
#ifdef CHECK
    if (p == NIL) {
      errput (9512, binpos(p), "binexchange");
		       /* binexchange: p == NIL. */
      return ;
    } else
    if (not sym_is [p->symc] .leftbin) {
      errput (9513, binpos(p), NULL);
		       /* binexchange: left is not binptr. */
    } else
    if (not sym_is [p->symc] .rightbin) {
      errput (9514, binpos(p), NULL);
		       /* binexchange: right is not binptr. */
    } else
#endif
    {
    q = p->pt.left ;
    p->pt.left  = p->right ;
    p->right    = q ;
    }
}

/*-----------------------------------------------*/
/* binpostfix : binprev->right muss NIL sein;
	binpostfix haengt den linken Teilbaum nach rechts.
*/
#ifdef LINT_ARGS
global void binpostfix ( void)
#else
global void binpostfix()
#endif
{
    freecheck (binprev) ; freecheck (bincurr) ;
#ifdef CHECK
    if (binprev == NIL) {
      errput (9504, pos, "binpostfix");
			/* binpostfix : binprev == NIL. */
      return ;
    }
    if (binprev->right != NIL) {
      errput (9515, pos, "binpostfix");
			/* binpostfix : binprev->right != NIL */
    }
    if (not sym_is [binprev->symc].rightbin) {
      errput (9557, binpos(binprev), "binpostfix");
			       /* binpostfix : not right-son node. */
      return ;
    }
#endif

    binprev->right   = binprev->pt.left;
    binprev->pt.left = NIL;
}

/*-----------------------------------------------*/
/* bininsert : installiert p links von q (wenn q innerer Knoten)
	       oder rechts von q (wenn q Identifier oder Symbol Knoten)
	       und haengt q anstelle von p an der Vater von p */
#ifdef LINT_ARGS
global binptr bininsert ( binptr p, binptr q )
#else
global binptr bininsert(p,q)
  binptr p, q ;
#endif
{
    freecheck (p) ; freecheck (q) ;
#ifdef CHECK
    if (p == NIL) {
      errput (9512, binpos (p), "bininsert");
			  /* bininsert : p == NIL. */
      return q ;
    }
    if (p->father == NIL) {
      errput (9506, binpos (p), "bininsert");
			  /* bininsert : father == NIL. */
      return q ;
    }
    if (q == NIL) {
      errput (9516, binpos (p), "bininsert");
			  /* bininsert : q == NIL. */
      return q ;
    }
    if (q->father != NIL) {
      errput(9517, binpos (p), "bininsert");
			 /* bininsert : q->father != NIL */
      return q ;
    }
    if (q->right != NIL) {
      errput(9518, binpos (p), "bininsert");
			 /* bininsert : q->right != NIL */
    }
    if (binleft(q) != NIL) {
      errput(9519, binpos (p), "bininsert");
			 /* bininsert : q->pt.left != NIL */
    }
#endif

    q->father = p->father;
    p->father = q;
    if (q->father->right == p) {
      q->father->right = q;
    }
    else {
#ifdef CHECK
    if (q->father->pt.left != p) {
      errput(9520, pos, NULL);
		 /* Fehler bei bininsert ! */
    }
#endif
    q->father->pt.left = q;
    }
    if  (sym_is [q->symc].leftbin)
	       q->pt.left = p;
    else       q->right = p;

    return q ;
}


/*-----------------------------------------------*/
/* binkill : loescht den Knoten p durch Einketten
	   in die freelist; der linke und der rechte Teilbaum muss leer
	   sein. Der Vater soll NIL sein.
*/

#ifdef LINT_ARGS
global void binkill  ( binptr p)
#else
global void binkill (p)
binptr p;
#endif
{
    freecheck (p) ;
#ifdef CHECK
    if  (binsymc (p) == cNosym)  then
      begin
	errput (9512, binpos(p), "binkill") ;
			/* binkill: node doesn't exist. */
	return ;
      end
#endif

  if  (binfather(p)  or  binleft(p)  or binright (p))  (void) bindelete (p);
  else  {
#ifndef FREECHECK
    p->right = freelist;                          /* free node */
    p->pt.left = NIL ;
    freelist = p;
#endif
    p->symc = cNosym ;
  }
} /* binkill */


/*-----------------------------------------------*/
/* bindelete : loescht den Knoten *binprev aus dem Baum und haengt ihn
	   in die freelist; der linke oder der rechte Teilbaum muss leer
	   sein.
*/

#ifdef LINT_ARGS
global binptr bindelete  ( binptr p)
#else
global binptr bindelete (p)
binptr p;
#endif
{
  binptr  fat, son;

    freecheck (p) ;
#ifdef CHECK
    if  (binsymc (p) == cNosym)  then
      begin
	errput (9521, binpos(p), NULL) ;
			/* bindelete: node doesn't exist. */
	return p ;
      end
#endif

  fat = binfather(p) ;

#ifdef CHECK
    if  (not fat)  then
      begin
	errput (9522, binpos(p), NULL) ;
			  /* Father node must exist in bindelete. */
      end
#endif

  son = binleft(p) ;
  if  (son)  then
#ifdef CHECK
    if  (binright(p))  then
      begin
	errput (9523, binpos(p), symptext [binsymc(p)]) ;
		  /* Cannot delete node symptext [binsymc(p)] */
      end
    else
#endif
    ;
  else  son = binright(p) ;

  if (p == binleft(fat))  fat->pt.left = son ;
  else
   begin
#ifdef CHECK
     if  (p != binright(fat))
      begin
	errput (9524, binpos(p), NULL) ;
			 /* Father not found in bindelete. */
      end
#endif
     if  (p == binright(fat))
	fat->right   = son ;
   end ;

  if (p == binprev and fat) then   binprev = fat ;      /* update binprev */

#ifndef FREECHECK
  p->right = freelist;                          /* free node */
  p->pt.left = NIL ;
  freelist = p;
#endif
  p->symc = cNosym ;

  if  (son)  then
       son->father = fat ;

  return fat ;
} /* bindelete */



/*-----------------------------------------------*/
/* bintdelete : deletes a whole bintab tree.     */
						/*-----------------------*/
#ifdef LINT_ARGS
global void   bintdelete  ( binptr * p)
#else
global void   bintdelete (p)                    /*  b i n t d e l e t e  */
  binptr * p;
#endif
{
    register binptr q = * p; /* traverses right chained list */
    register binptr l ;      /* previous q */

    if  (q == NIL  or  not sym_is [q->symc].rightexpr)  then    return ;

     repeat
	if  (sym_is[q->symc].leftexpr )
	  bintdelete (& q->pt.left) ;            /* delete left son */
/* #ifndef FREECHECK */
	q->pt.left = NIL ;
/* #endif */
	l = q ;
	q = binright (q) ;
	l->symc = cNosym ;
    until (q == NIL  or  not sym_is [q->symc].rightexpr) ;

/* #ifndef FREECHECK */
    l->right = freelist ;
    freelist = * p ;                   /* chain right list to freelist */
/* #endif */
    * p = NIL ;

} /* bintdelete */


#ifdef LINT_ARGS
global void   binldelete  ( binptr p)
#else
global void   binldelete (p)                    /*  b i n l d e l e t e  */
  binptr p;
#endif
{
  register binptr q = p;

  if  (not p)   return ;
  freecheck (p) ;
#ifdef CHECK
     while (q->right)
      begin
	if  (not sym_is[q->symc] .list and q->symc != cVAR
	     and q->symc != cPROCEDURE and q->symc != cFUNCTION)  then
	  begin
	    errput (9525, binpos(q), NULL) ;
		      /* binldelete: Not a list node. */
	  end ;
	if  (binleft (q) and binfather(binleft(q)) == q)  then
	  begin
	    errput (9526, binpos(q), NULL) ;
		      /* binldelete: Unlinking left son. */
	  end ;
	q->pt.left = NIL ;
	q->symc = cNosym ;
	q = q->right ;
      end ;
     if  (not sym_is[q->symc] .list and q->symc != cVAR
	   and q->symc != cPROCEDURE and q->symc != cFUNCTION)  then
       begin
	 errput (9525, binpos(q), NULL) ;
		      /* binldelete: Not a list node. */
       end

#else
     while (q->right)
      begin
	q->symc = cNosym ;
	q = q->right ;
      end
#endif
     q->symc = cNosym ;
#ifndef FREECHECK
     q->pt.left = NIL ;
     q->right = freelist ;
     freelist = p ;                     /* chain whole list to freelist */
#endif
} /* binldelete */


/*-----------------------------------------------*/
/* dump    : Ausgeben der Baumstructur auf listfile;
*/
#ifdef LINT_ARGS
global void  dump  ( binptr p)
#else
global void  dump (p)
binptr p;
#endif
BEGIN(dump)
  if (p!=NIL)
    begin
       if  (sym_is[p->symc].identifier)  then
	 begin

	   print (symptext [p->symc]) ;            /* write node */
	   print (" ") ;
	   if  (p->pt.id)  then
	    begin
	      print (symtab(idsym(p->pt.id))) ;     /* write P identifier */
	      print (" ") ;
	      print (symtab(idcsym(p->pt.id))) ;    /* write C identifier */
	    end
	   else print ("no id") ;
	 end
       else
       if  (sym_is[p->symc].symbol)  then
	 begin
	   print (symptext [p->symc]) ;            /* write node */
	   print (" ") ;
	   print (symtab(p->pt.sym)) ;             /* write symbol */
	 end
       else
	switch (p->symc)
	 begin
	   case cIcon : { printint ( p->pt.value) ;           break; }
	   case cRcon : { print (p->pt.charp ) ;              break; }
	   case cCcon : { printchar ( (char) p->pt.value) ;
							      break; }
	   case cScon : { print ("\"") ;
			  print ( p->pt.charp) ;
			  print ("\"") ;                      break; }

	   case cOpptr: { opptr oppt = p->pt.op ;

			  print (symptext [p->symc]) ;
			  print (" ") ;
			  if  (oppt )  then
			   begin
			     if (oppsym (oppt) != symNIL)  then
			      print (symtab(oppsym(oppt))); /* write P symbol */
			     else
			     print (symptext [opsymc(oppt)]) ;
			     print (" ") ;
			     print (symtab(opcsym(oppt))) ; /* write C symbol */
			   end
			  else print ("no op") ;              break; }

	   default:
		if (sym_is [p->symc].leftbin) then
		  begin
		    incspaces() ; incspaces() ;
		    dump (p->pt.left);                  /* recursive call */
		    decspaces() ; decspaces() ;
		  end;
		print ( symptext [p->symc]) ;      /* write node */
	 end /* switch symc */ ;

       print ("  line ") ; printint ((long int) p->pos.line) ;
       print (", col ") ; printint ((long int) p->pos.col) ;
#if 0
       if  (p->father)  then
	  print("    father: ") ,
	  print(symptext[binsymc(p->father)]) ;
#endif
       printline () ;

       if (sym_is [p->symc].rightbin and p->right) then
	begin
	  if (not( sym_is [p->right->symc].list and
		   p->symc==p->right->symc))
	    incspaces() , incspaces() ;
	  dump (p->right);                              /* recursive call */
	  if (not( sym_is [p->right->symc].list and
		   p->symc==p->right->symc))
	    decspaces() , decspaces() ;
	end ;
    end /* p != NIL */
END /* dump */



/*-----------------------------------------------*/
/* binappend : installiert q als rechtes Blatt von p
	   (entspricht binsuffix() mit Parametern)
*/
#ifdef LINT_ARGS
global binptr  binappend ( binptr p,binptr q)
#else
global binptr  binappend(p, q)
binptr p;
binptr q;
#endif
{

  freecheck (p) ; freecheck (q) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binappend");
		   /* binappend : p == NIL. */
	return q ;
    }
    if (not sym_is [p->symc].rightbin) {
      errput (9557, binpos(p), "binappend");
			       /* binappend : not right-son node. */
      return q ;
    }
    if (binright(p)) {
	errput (9556, binpos(p), NULL);
		      /* binappend : right son already exists. */
    }
#endif

    if  (q)   q->father = p;
    p->right  = q;

    return q;
}

/*-----------------------------------------------*/
/* binlside : installiert q als linkes Blatt von p
*/
#ifdef LINT_ARGS
global binptr  binlside ( binptr p,binptr q)
#else
global binptr  binlside(p, q)
binptr p;
binptr q;
#endif
{
  freecheck (p) ; freecheck (q) ;

#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binlside");
		     /* binlside : p == NIL. */
	return q ;
    }
    if (not sym_is [p->symc].leftbin) {
      errput (9558, binpos(p), "binlside");
			       /* binlside : not left-son node. */
      return q ;
    }
    if (binleft(p)) {
	errput (9527, binpos(p), NULL);
		      /* binlside : left son already exists. */
    }
#endif

    if  (q)   q->father  = p;
    p->pt.left = q;

    return q;
}


/*-----------------------------------------------*/
/* binfunc : wandelt Operator in Funktion
*/
#ifdef LINT_ARGS
global void binfunc  ( binptr p,symptr sym)
#else
global void binfunc (p, sym)
binptr p;
symptr sym;
#endif
BEGIN (binfunc)
binptr temp;

  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binfunc");
		     /* binfunc : p == NIL. */
	return ;
    }
    if (sym == symNIL) {
	errput (9528, binpos(p), "binfunc");
		      /* binfunc : sym == NIL. */
    }
  /*  if (sym_is [binsymc(p)].Operator) { */
#endif

    if (sym_is [binsymc(p)].userdefined) {
	p->symc    = (byte) cCall;
	p->pt.sym  = sym;
	(p->right)->symc = (byte) cComma;
    }
    else {
      if ((temp=binalloc ()) != NULL)   {
	temp->symc    = (byte) cComma;
	temp->pt.left = p->pt.left;
	temp->right   = p->right;
	temp->pos     = p->pos ;
	temp->father  = p ;
	(p->right)->father   = temp;
	(p->pt.left)->father = temp;

	p->symc       = (byte) cCall;
	p->right      = temp;
	p->pt.sym     = sym;
      }  else  memerror (pos) ;
    } /* standard op symbol */
END /* binfunc */


#ifdef OLD
/*-----------------------------------------------*/
/* binproc : wandelt Funktion in Prozedur
*/
#ifdef LINT_ARGS
global binptr binproc  ( binptr p,symptr sym)
#else
global binptr binproc (p,sym)    /* sym was tempid before !!   PJ 08.07.92 */
binptr p;
symptr sym;
#endif
{
    binptr temp;

    freecheck (p) ;
    if (sym_is [p->symc].Operator)
    begin
    if ((temp=binalloc()) == NULL)  memerror (pos) ;
    else begin
	temp->symc    = (byte)cComma ;
	temp->pt.left = p->pt.left;
	temp->right   = p->right;
	(p->right)->father   = temp;
	(p->pt.left)->father = temp;

	p->symc       = (byte)cCall;
	p->right      = temp;
	p->pt.sym     = sym;
	end
    end
  return temp ;
}
#endif


/*-----------------------------------------------*/
/*------------- Aendern -------------------------*/
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binchange  ( binptr p,symctype symc)
#else
global void binchange (p, symc)
binptr p;
symctype symc;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (symc == cNosym) {
	errput (9560, binpos(p), NULL);
			   /* binchange called with Nosym. */
	return ;
    }
    if (not(p)) {
	errput (9512, binpos(p), "binchange");
			   /* binchange : p == NIL. */
    }
#endif

    if (p)    p->symc = (byte) symc;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binuppos  ( binptr p,postype pos)
#else
global void binuppos ( p, pos)
binptr p;
postype pos;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binuppos");
			     /* binuppos : p == NIL. */
    }
#endif

    if (p)    p->pos = pos;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binllink  (  binptr p, binptr q)
#else
global void binllink ( p, q)                            /*  b i n l l i n k  */
  /* sets the left pointer of p to q */
binptr p, q;
#endif
{
  freecheck (p) ; freecheck (q) ;
#ifdef CHECK
    if (not(p) or not sym_is [p->symc] .leftbin /* or p->pt.left */ ) {
	errput (9529, binpos(p), "binllink");
		       /* binllink : cannot link. */
    }
    else p->pt.left = q ;
#else
    if (p)   p->pt.left = q ;
#endif
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binrlink  (  binptr p, binptr q)
#else
global void binrlink ( p, q)                            /*  b i n r l i n k  */
  /* sets the right pointer of p to q */
binptr p, q;
#endif
{
  freecheck (p) ; freecheck (q) ;
#ifdef CHECK
    if (not(p) or not sym_is [p->symc] .rightbin /* or p->pt.right */ ) {
	errput (9529, binpos(p), "binrlink");
			     /* binrlink : cannot link. */
    }
    else p->right = q ;
#else
    if (p)   p->right = q ;
#endif
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binupsym  ( binptr p,symptr sym)
#else
global void binupsym (p, sym)
binptr p;
symptr sym;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binupsym");
		      /* binupsym : p == NIL. */
    }
    else if (not(sym_is [binsymc(p)].symbol)) {
	errput(9530, binpos(p), NULL);
		      /* binupsym : Knoten kein Symbolknoten ! */
    }
#endif

    if (p and (sym_is [p->symc].symbol))     p->pt.sym = sym;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binupid  ( binptr p,idptr id)
#else
global void binupid (p, id)
binptr p;
idptr id;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binupid");
		      /* binupid : p == NIL. */
    }
    else if (not(sym_is [binsymc(p)].identifier))  {
	errput(9531, binpos(p), NULL);
		      /* binupid : no identifier node. */
    }
#endif

    if ((p) and (sym_is [p->symc].identifier))    p->pt.id  = id;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binupblk  ( binptr p,blockptr blk)
#else
global void binupblk (p, blk)
binptr p;
blockptr blk;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binupblk");
			/* binupblk : p == NIL. */
    }
    else if (binsymc(p) != cBlkptr)  {
	errput(9532, binpos(p), NULL);
			/* binupblk : Knoten kein Block-knoten ! */
    }
    if (not(blk)) {
	errput (9533, binpos(p), NULL);
			 /* binupblk : blk == NIL. */
    }
#endif

    if (p and p->symc == cBlkptr)    p->pt.blk  = blk;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binupvalue  ( binptr p,long int value)
#else
global void binupvalue (p, value)
binptr p;
long int value;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binupvalue");
		   /* binupvalue : p == NIL. */
    }
    else if (not(sym_is [binsymc(p)].value))  {
	errput (9534, binpos(p), NULL);
		   /* binupvalue : Knoten kein Value-knoten ! */
    }
#endif

    if ((p) and (sym_is [p->symc].value))    p->pt.value = value;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binupcharp  ( binptr p,char * charp)
#else
global void binupcharp (p, charp)
binptr p;
char * charp;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binupcharp");
			/* binupcharp : p == NIL. */
    }
    else if (binsymc(p) != cScon  and  binsymc(p) != cRcon)  {
	errput (9535, binpos(p), NULL);
		/* binupcharp : Knoten keine String- /Real-konstante */
    }
    if (not(charp)) {
	errput (9536, binpos(p), NULL);
		 /* binupcharp : charp == NIL. */
    }
#endif

    if (p and ((p->symc == cScon) or (p->symc == cRcon)))
	p->pt.charp = charp;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void binupop  ( binptr p,opptr op)
#else
global void binupop (p, op)
binptr p;
opptr op;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binupop");
			/* binupop : p == NIL. */
    }
    else if (binsymc (p) != cOpptr)   {
	errput (9537, binpos(p), NULL);
			/* binupop : Knoten kein Opptr-knoten ! */
    }
    if (not(op)) {
	errput (9538, binpos(p), NULL);
			/* binupop : op == NIL. */
    }
#endif

    if (p and p->symc == cOpptr)    p->pt.op = op;
}




/*-----------------------------------------------*/
/*----------- Aendern von binprev ---------------*/
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void gofather  ( void)
#else
global void gofather ()
#endif
{
#ifdef CHECK
    if (not(binprev)) {
	errput (9504, binpos(binprev), "gofather");
			 /* gofather : binprev == NIL. */
	return ;
    }
    else if (binprev->father == NIL) {
	errput (9540, binpos(binprev), NULL);
			/* gofather : binprev->father == NIL. */
    }
#endif

  if (binprev->father)
    binprev = binprev->father;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void goleft  ( void)
#else
global void goleft ()
#endif
{
#ifdef CHECK
    if (!(sym_is[binsymc(binprev)].leftbin)) {
      errput (9541, binpos(binprev), NULL);
		 /* goleft : binprev->pt.left kein binptr. */
    }
    else if (not(binprev->pt.left)) {
      errput (9542, binpos(binprev), NULL);
		/* goleft : binprev->pt.left == NIL. */
    }
#endif

  if ((sym_is[binprev->symc].leftbin) and (binprev->pt.left))
    binprev = binprev->pt.left;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global void goright  ( void)
#else
global void goright ()
#endif
{
#ifdef CHECK
    if (!(sym_is[binsymc(binprev)].rightbin)) {
      errput (9543, binpos(binprev), NULL);
	      /* goright : binprev->right kein binptr. */
    }
    else if (not(binprev->right)) {
      errput (9544, binpos(binprev), NULL);
	       /* goright : binprev->right == NIL. */
    }
#endif

  if (binprev and (sym_is[binprev->symc].rightbin) and (binprev->right))
    binprev = binprev->right;
}
/*-----------------------------------------------*/
/*----------- Zugriff ---------------------------*/
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global binptr  binfather ( binptr p)
#else
global binptr  binfather(p)
binptr p;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (p == NIL) {
      errput (9545, pos, NULL);
			 /* binfather : NIL pointer */
      return (p);
    }
    else
#endif

    return ( p ? p->father : NIL );
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global binptr  binleft ( binptr p)
#else
global binptr  binleft(p)
binptr p;
#endif
{
  freecheck (p) ;

    if (p and sym_is [p->symc].leftbin)
	return (p->pt.left);
    else return (NIL);
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global binptr  binright ( binptr p)
#else
global binptr  binright(p)
binptr p;
#endif
{
  freecheck (p) ;

    if (p and sym_is [p->symc].rightbin)
	return (p->right);
    else return (NIL);
}


/*-----------------------------------------------*/
#ifdef LINT_ARGS
global binptr  bincont ( binptr p)
#else
global binptr  bincont(p)
binptr p;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(sym_is [binsymc(p)].list)) {
      errput (9548, binpos(p), NULL);
		/* bincont : no list node. */
    }
#endif

    if (p and sym_is [p->symc].leftbin)
	return (p->pt.left);
    else return (NIL);
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global binptr  binnext ( binptr p)
#else
global binptr  binnext(p)
binptr p;
#endif
{
  freecheck (p) ;
#ifdef CHECK
    if (not(sym_is [binsymc(p)].list)) {
      errput (9549, binpos(p), NULL);
		     /* binnext : kein 'next'-knoten */
    }
#endif

    if (p and sym_is [p->symc].rightbin)
	return (p->right);
    else return (NIL);
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global symctype    binsymc ( binptr p)
#else
global symctype    binsymc(p)
binptr p;
#endif
{
    freecheck (p) ;
    return ( p ? (symctype) p->symc : cNosym);
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global postype binpos ( binptr p)
#else
global postype binpos(p)
binptr p;
#endif
{
  freecheck (p) ;
  return ( p ? p->pos : pos );
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global symptr  binsym ( binptr p)
#else
global symptr  binsym(p)
binptr p;
#endif
{
  freecheck (p) ;
    if (p and sym_is [p->symc].symbol)
	return (p->pt.sym);
    else return (symNIL) ;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global idptr   binid ( binptr p)
#else
global idptr   binid(p)
binptr p;
#endif
{
  freecheck (p) ;
    if (p and sym_is [p->symc].identifier)
	return (p->pt.id);
    else return (idptr)0 ;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global blockptr   binblk ( binptr p)
#else
global blockptr   binblk(p)
binptr p;
#endif
{
  freecheck (p) ;
    if (p and p->symc == cBlkptr)
	return (p->pt.blk);
    else return (blockptr)0 ;
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global long int binvalue ( binptr p)
#else
global long int binvalue(p)
binptr p;
#endif
{ symctype symc = binsymc (p) ;
  boolean     m = (symc == cMMinus) ;

  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "binvalue");
			/* binvalue : p == NIL. */
    }
#endif

    if  (symc == cMPlus or symc == cMMinus)
      {  p = binright (p) ;   freecheck (p) ;  }
    p = unname (p) ;
#ifdef CHECK
    if (not sym_is [binsymc(p)].value ) {
	errput (9550, binpos(p), NULL);
			  /* binvalue : No Value-node ! */
    }
#endif
  return (p and sym_is [p->symc].value ? (m ? -p->pt.value : p->pt.value)
				       : (long int)0);
}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global char *  bincharp ( binptr p)
#else
global char *  bincharp(p)
binptr p;
#endif
{

  freecheck (p) ;
#ifdef CHECK
    if (not(p)) {
	errput (9512, binpos(p), "bincharp");
			  /* bincharp : p == NIL. */
    }
    else if (not(binsymc(p)==cScon  or  binsymc(p)==cRcon)) {
	errput (9551, binpos(p), NULL);
		   /* bincharp : keine String- /Real-konstante */
    }
#endif

    if (p and (p->symc == cScon or p->symc == cRcon))
	return ((char*) p->pt.charp);
    else return (char*)0;

}
/*-----------------------------------------------*/
#ifdef LINT_ARGS
global opptr   binop ( binptr p)
#else
global opptr   binop(p)
binptr p;
#endif
{
  freecheck (p) ;
    if (p and p->symc == cOpptr)
	return (p->pt.op);
    else return (opptr)0 ;
}
/*-----------------------------------------------*/
/*-----------------------------------------------*/
/*-----------------------------------------------*/


							/*-----------------*/
#ifdef LINT_ARGS
global void  baptize  ( register binptr typ )
#else
global void  baptize (typ)                              /*  b a p t i z e  */
  register binptr typ ;
#endif
BEGIN(baptize)
  binptr p = typ ;
  binptr q ;
  freecheck (p) ;
#ifdef CHECK
    if (p == NIL) {
      errput (9512, binpos (p), "baptize");
			  /* baptize : p == NIL. */
      return ;
    }
    if (p->father == NIL) {
      errput(9506, binpos (p), "baptize");
			 /* baptize : father == NIL */
      return ;
    }
    q = p->father ;
    if (binright(q) != p and binleft (q) != p) {
      errput(9554, binpos (p), "baptize");
			 /* baptize : invalid father */
    }
#endif

  if  (blocklevel <= IDMAINLEVEL  and binsymc(binroot) == cMODULE)  then
    q = binsycreate (moduniquename ()) ;
  else
    q = binsycreate (uniquename ("tt")) ;       /* create temp type name */
  q->symc = (byte) cTemptype ;
  q->father = p->father ;
  q->right = p ;                                /* link temp node */
  p->father = q ;
  if  (q->father->right == p)          q->father->right = q ;
  else  if (binleft(q->father)==p)     q->father->pt.left = q ;
  q->pos = p->pos ;

  p = q->father ;                       /* search start of declaration */
  freecheck (p) ;
  while  (p and binsymc (p) != cVAR and binsymc (p) != cTYPE)
    { p = p->father ;   freecheck (p) ; }

#ifdef CHECK
  if  (p==NIL)
   begin
     errput (9555, binpos(q), NULL) ;
     return ;
   end ;
#endif
						/* insert type definition */
  p = bininsert (p, bincreate (cSemicolon)) ;
  p = binappend (p, bincreate (cTYPE)) ;
  typ->father = p ;
  binexchange (binfather (p)) ;
  binllink (p, q) ;
  binrlink (p, binright (q)) ;
END /* baptize */                                       /*  b a p t i z e  */
							/*-----------------*/



							/*---------------*/
#ifdef LINT_ARGS
global binptr unname  ( register binptr p )
#else
global binptr unname (p)                                /*  u n n a m e  */
  register binptr p ;
  /* if p is a type identifier then unname returns the data type */
  /*      or the standard data type defined in idtab.h           */
  /* if p is a constant identifer then unname returns the value */
  /* else unname returns p. */

#endif
BEGIN(unname)
  register binptr res ;
  register idptr  idp ;

  freecheck (p) ;
  res = p ;
  if  (sym_is[binsymc(p)] .identifier)  then
   begin
     idp = binid (p) ;
     if  (idgetkind (idp) == IDTYPE)  then
      if (idp == idSTRING and binsymc (p) == cSTRING)  then
	/* don't lose string length  */ ;
      else
	res = iddatyp (idp) ;
     else
     if  (idgetkind (idp) == IDCONST)  then   res = idvalue (idp) ;
#ifdef OLD
     if  (sym_is [binsymc (res)] .symbol)  then
      switch (binsymc (p))
       begin
	case cINTEGER : res = integertype ;       break ;
	case cCHAR    : res = chartype ;          break ;
	case cBOOLEAN : res = booleantype ;       break ;
	case cREAL    : res = rconstype ;         break ;
	default       : res = p ;
       end ;
#endif
   end
  else
   if (binsymc(p) == cTemptype or binsymc(p) == cCsymbol)  res = binright (p) ;
  freecheck (res) ;
  RETURN (res) ;
END  /* unname */                                       /*  u n n a m e  */
							/*---------------*/


						/*-----------------*/
#ifdef LINT_ARGS
global binptr subtype  (  binptr t )
#else
global binptr subtype (t)                       /*  s u b t y p e  */
  /* returns the base type of a subrange or */
  /* returns unname(t), if not a subrange. */
  /* The result may be a named subrange type. */
  binptr t ;
#endif
BEGIN(subtype)
  symctype symc ;  /* symbol code of low bound value */
  binptr      p ;  /*  traverses the subrange tree */

  t = unname (t) ;
  if  (binsymc (t) == cTill)  then              /* subrange */
   begin
     p = binleft (t) ; /* low bound */
     if  (binsymc (p) == cMMinus)  then
	p = binright (p) ;                      /* skip "-" */

     if  (sym_is [symc = binsymc(p)] .identifier)  then
       t = iddatyp (binid (p)) ;                /* named constant */
     else   /* unnamed constant */
       switch (symc)                            /* unnamed constant */
	begin
	 case cNIL :  t = pointertype ;   break ;
	 case cIcon:  t = integertype ;   break ;
	 case cCcon:  t = chartype ;      break ;
	 case cRcon:  t = rconstype ;     break ;
	 case cBcon:  t = booleantype ;   break ;
	 case cScon: /* ; case cS2con : ; case cS3con : ; case cS4con : */
		      t = p           ;    break ;
	 default : ;
	end ;
   end /* subrange */
  freecheck (t) ;
  RETURN (t) ;
END /* subtype */



#ifdef LINT_ARGS
global void chkvarparam  ( binptr actpar, postype pos )
#else
global void chkvarparam (actpar, pos)
  binptr actpar ;  /* data type of the actual parameter, */
		   /* includes storage class */
  postype pos ;    /* position of actual parameter */
#endif
{
  IF not( binsymc(actpar)==cVarparam or binsymc(actpar)==cVAR ) THEN
    errput (5003, pos, (char*)0) ;
   /* print ("This parameter must be a variable.") ;
    printline () ; */
  FI
}


						/*-----------------------------*/
#ifdef LINT_ARGS
global boolean binisvariable  ( register binptr p )
#else
global boolean binisvariable (p)             /*  b i n i s v a r i a b l e  */
  register binptr p ;
#endif
BEGIN(binisvariable)
  register symctype symc = binsymc (p) ;
  return  (sym_is [symc] .identifier ? (idgetkind (binid(p)) >= IDRES1VAR) :
	   sym_is [symc] .variable) ;
END /* binisvariable */


							/*---------------*/
#ifdef LINT_ARGS
global binptr bintemp  (  binptr p,symptr tempsym)
#else
global binptr bintemp (p, tempsym)                      /* b i n t e m p */
  /* ersetzt den Ausdruck, auf den p zeigt, durch die */
  /* temporaere Variable tempsym und fuegt oberhalb von */
  /* binstm eine Zuweisung an tempsym ein. */
  binptr p;
  symptr  tempsym;
#endif
BEGIN (bintemp)
  binptr temp1;  /* node of temporary replacing expression */
  binptr assgn;  /* assignment node */
  binptr fat;    /* father of expression */

#ifdef CHECK
    if (not(p)) {
	errput (9512, pos, "bintemp");
	return NIL ;
		    /* bintemp : p == NIL. */
    }
    if (tempsym == symNIL) {
	errput (9552, binpos(p), NULL);
		   /* bintemp : tempsym == NIL. */
    }
#endif

  freecheck (p) ;
    assgn = bincreate (cAssign);
    assgn->pos = p->pos ;

    if  (binstm)  then
     begin
       binptr semic = bincreate (cSemicolon);
       semic->pos = p->pos ;
       semic->pt.left = binstm ;
       binstm->father = semic ;         /* Semicolon inserted above binstm */
       binstm = semic ;

       semic->right = assgn ;           /* assignment appended */
       assgn->father = semic ;
     end
    else
       binstm = assgn ;                 /* new binstm is assignment */

    assgn->right = p;

    fat = p->father;
    temp1 = binsycreate(tempsym);
    temp1->pos = p->pos ;
    temp1->father = fat ;
    if (binright (fat) == p)   fat->right = temp1 ;
			else   fat->pt.left = temp1 ;

    p->father = assgn ;
    assgn->pt.left = binsycreate (tempsym);
    assgn->pt.left->father = assgn;

  freecheck (temp1) ;
  return (temp1) ;
END  /* bintemp */                                      /* b i n t e m p */
							/*---------------*/


							/*-------------------*/
#ifdef LINT_ARGS
global binptr tempdecl  (  char prefix [2] ,binptr datyp )
#else
global binptr tempdecl (prefix, datyp)                  /*  t e m p d e c l  */
  /* finds or inserts a declaration of a temporary Variable */
  /* with data type datyp and first 2 chars prefix at */
  /* the position bindecl and returns the pointer to the declaration. */
  char prefix [2] ;
  binptr datyp ;
#endif
BEGIN(tempdecl)
  postype posdecl; /* position for merge */
  binptr root ;    /* of temporary declarations */
  binptr p ;       /* walking thru declarations */
  binptr symp ;    /* pointer to Symbol-node */
  boolean unfound = true ;

  posdecl= binpos (bindecl) ;
  if  (binsymc (bindecl) == cBlkptr)  then   root = bindecl->right ;
#ifdef CHECK
  else if (binsymc (bindecl) != cBEGIN)  then
    {   errput (9553, binpos(bindecl), symptext [binsymc(bindecl)] );
	/* tempdecl : Illegal bindecl symptext [binsymc(bindecl)] */
	root = NIL ;
    }
#endif
				else   root = bindecl->pt.left->right ;
   p = root ;

   while (unfound and binsymc (p) == cSemicolon)
    begin
      symp = binright (p) ;
      unfound =  not (
	      sym_is [binsymc(symp)].symbol  and
	      typ_compatible (datyp, binright (symp))  and
	      prefix[0] == *symtab (binsym(symp))  and
	      prefix[1] == *(symtab (binsym(symp)) + 1) and
	      binsymc (symp) != cCsymbol /* currently unused */ ) ;
      if  (unfound)  then  p = binleft (p) ;  else p = symp ;
    end

   if (unfound)  then
    begin
      if  (binsymc (datyp) == cIdlist or binsymc (datyp) == cVarparam)
       begin  /* datyp-node is a palist element, which will be deleted */
	 binptr son ;
	 binptr typ = binidcreate (cIdent, binid (datyp)) ;
	      /* therefore create a new node */
	 binuppos (typ, binpos (datyp)) ;
	 son= binright (datyp) ;
	 if  (son  and  binfather (son) == datyp)
	   binappend (typ, son) ;
	 else
	   binrlink (typ, son) ;
	 datyp = typ ;
       end ;

      if  (root)  then
	p= bininsert (root, bincreate (cSemicolon)) ;       /*  insert or  */
      else
	if  (binsymc (bindecl) == cBlkptr)  then            /*   append:   */
	  p = binappend (bindecl, bincreate (cSemicolon)) ;
	else                                                /* cBlkptr     */
	  p = binappend (binleft (bindecl),                 /*  \          */
			 bincreate (cSemicolon)) ;          /*   |;|       */
      binuppos (p, posdecl) ;                               /*  /   \      */
      p= binappend (p, binsycreate (uniquename (prefix))) ; /*    |cCsym|  */
      binuppos (p, posdecl) ;                               /*    ,-'   \  */
      binrlink (p, datyp) ;                                 /*       datyp */
    end
   else   binchange (p, cCsymbol) ; /* mark as used */
  return p ;
END /* tempdecl */                                      /*  t e m p d e c l  */
							/*-------------------*/

							/*-----------------*/
#ifdef LINT_ARGS
global void binlift  ( binptr p )
#else
global void binlift (p)                                 /*  b i n l i f t  */
  binptr p ; /* node to be lifted */
#endif
BEGIN(binlift)                    /*         fat        */
  binptr fat   = p->father ;      /*        /   \       */
  binptr left  = p->pt.left ;     /*       p     right  */
  binptr midd  = p->right ;       /*      / \           */
  binptr right = fat->right ;     /*  left   midd       */

  freecheck (p) ;
  left->father  = fat ;
  fat->pt.left  = left ;          /*     fat            */
  fat->right    = p ;             /*     /   \          */
  p->pt.left    = midd ;          /*  left    p         */
  right->father = p ;             /*         / \        */
  p->right      = right ;         /*     midd    right  */
END /* binlift */                                       /*  b i n l i f t  */
							/*-----------------*/


							/*-----------------*/
#ifdef LINT_ARGS
global binptr bincopy  ( binptr p)
#else
global binptr bincopy (p)                               /*  b i n c o p y  */
binptr p;
#endif
BEGIN (bincopy)
binptr q;

  if (p) {
    q = bincreate(binsymc(p));
    q->pos = binpos(p);
    if (sym_is [binsymc(p)].leftbin and binleft(p))
      binlside  (q, bincopy(binleft(p)));
    else
      q->pt.left = p->pt.left;
    if (sym_is [binsymc(p)].rightbin and binright(p))
      binappend (q, bincopy(binright(p)));
    else
      q->right = p->right;
    return (q);
  }
  return (NIL);

END  /* bincopy */                                      /*  b i n c o p y  */
							/*-----------------*/

						/*-----------------------*/
#ifdef LINT_ARGS
global boolean bincompare  ( binptr p,binptr q)
#else
global boolean bincompare (p,q)                 /*  b i n c o m p a r e  */
binptr p;
binptr q;
#endif
BEGIN (bincompare)
boolean equal;   symctype symc = binsymc(p) ;

  equal = (symc==binsymc(q));
  if (p!=NIL and q!=NIL) {
    if (equal) {
      if (sym_is [symc].leftbin and p->pt.left)
	equal = bincompare(p->pt.left, q->pt.left);
      else if (binleft(q))
	equal = false;
      else { /* not binptr */
        if (sym_is [symc].constant  and  not sym_is [symc].value
	    and  p->pt.charp and q->pt.charp)
		equal = strcmp (p->pt.charp, q->pt.charp) == 0 ;
        else
		equal = (p->pt.left == q->pt.left);
	}
    }
    if (equal) {
      if (sym_is [symc].rightbin and p->right)
	equal = bincompare(p->right,q->right);
      else if (binright(q))
	equal = false;
      else
	equal = (p->right == q->right);
    }
  }
  else   equal = p == q ; /* both must be NIL */

  return (equal);

END  /* bincompare */                           /*  b i n c o m p a r e  */
						/*-----------------------*/

						/*-------------------*/
#ifdef LINT_ARGS
global void binlist (binptr exp, binptr *root)   /*  b i n l i s t  */
#else
global void binlist (exp, root)
  /* Adds exp to the list of statements or creates this list */
  /* Used to generate untemp & freeing routines. */
  binptr exp;
  binptr *root;
#endif
{
  binptr p;
  IF *root  THEN
    for( p = *root; binsymc(p) == cSemicolon; p = binright(p));
    IF p != *root THEN
      p = bininsert(p , bincreate(cSemicolon));
      binappend(p,exp);
    ELSE
      *root = bincreate(cSemicolon);
      binlside( *root, p );
      binappend( *root, exp);
    FI
  ELSE
    *root = exp;
  FI
}                                               /*  b i n l i s t  */
						/*-------------------*/


