/*
 *  MODULE  : optab.c
 *  Operator table
{*  last modification:  28.04.92  18:01   }

 *  uli 14.11.90: bincoers: The actual type may be a userdefined string type
 *  uli 03.01.91: opfnd: opfset = true
 *  Dima 21.01.91: opcoers: The  subtypes of the same base-type
		   are not compatible now.
		   See binncoers in idtab.c
 *  uli 04.03.89 : type optabptr added
 *  uli 05.03.89 : new-style headers
 *  uli 06.03.91 : stdio.h added.
 *  Dima 23.04.91: opcoers:
		   By VAR-par subtype is compatible to base-type
		   and vice versa
 *  uli 14.06.91 : checkerror substituted by errput
 * Dima 07.08.91 : opcoers: PTRCHAR added
 * Dima 22.11.91 : Type management functions added
 * Dima 09.12.91 : sub_or_base_of : One of the types must be a subrange
 *  uli 13.12.91 : compatible : array of char  doesn't require name compat.
 * Dima 15.12.91 : sub_or_base_of : corrected
 * Dima 16.12.91 : coerse: Cast "*(type *)&" by structures.
 * Dima 22.01.92 : op&binncoers: unname&stct_compat are added
 * Dima 29.01.92 : coerse: Comma will be deleted in ELSE case
 *  uli 18.02.92 : INT_MAX replaced by NOCOERS .
 * Dima 28.04.92 : opcoers : arrays
 *Dima 10.12.92  : type_conv: Pointer to pinter cast is allowed.
*/

#define CHECK

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

#include           "impor.t"
#include "error.h"
#include "option.h"
#include "scan.h"           /* import pos */
#include "symtab.h"
#include "idtab.h"
#include "blktab.h"
#include "std.h"
#include "arrx.h"

#include           "expor.t"
#include "optab.h"

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

/*
#ifdef LINT_ARGS
extern void exit(int);
#else
extern void exit();
#endif
*/

#include           "implemen.t"

#include "runtime.h"

#ifdef LINT_ARGS
local boolean sub_or_base_of  ( binptr atype, binptr ftype);
local boolean str_compatible  ( binptr act_type );
local boolean name_compatible ( binptr ltyp, binptr rtyp );
local boolean stct_compatible ( binptr ltyp, binptr rtyp );
local boolean ds_compatible   ( binptr dyntyp, binptr stattyp );
#else
local boolean sub_or_base_of  ();
local boolean str_compatible  ();
local boolean name_compatible ();
local boolean stct_compatible ();
local boolean ds_compatible   ();
#endif

#ifdef LINT_ARGS

local int   opcoers (binptr, idptr);
local opptr opfnd1  (symctype, symptr, binptr, binptr);
local boolean opcomp (opptr, opptr);

#else

local int   opcoers ();
local opptr opfnd1  ();
local boolean opcomp ();

#endif

local idflags opfinit=
       {           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    */
       };

#if 1
#ifdef LINT_ARGS
global void opdump ( optabptr oplist)
#else
global void opdump(oplist)
optabptr        oplist;
#endif
{
   opptr           rlist;
   struct opllist *llist;

   if ( oplist==NULL ) return;

   for (; oplist!=NULL; oplist= oplist->next)

      for (llist= (oplist)->llist; llist!=NULL; llist= (llist)->next)

	 for (rlist=(llist)->rlist; rlist!=NULL; rlist= (rlist)->next)
	 {
	       char *op_name;
	       if ( rlist->op->psym!=symNIL )
		  op_name=symtab (rlist->op->psym);
	       else
		  op_name=symptext[rlist->op->symc];
	       printf("\n%s   %p   %p",op_name,rlist,rlist->restyp);
	 }
}
#endif

local optabptr    oparray[IDMAINLEVEL-IDPRELEVEL+1][cMonop-cAssign+1];


							/*-------------*/
#ifdef LINT_ARGS
global opptr opins (symctype symc, symptr psym, symptr csym,
  binptr restyp, binptr typlbin, binptr typrbin, boolean varpl, boolean varpr)
#else
global opptr opins(symc, psym, csym,                    /*  o p i n s  */
		   restyp, typlbin, typrbin, varpl, varpr)
symctype       symc;
symptr         psym,csym;
binptr         restyp,typlbin,typrbin;
boolean        varpl, varpr;
#endif
{
   optabptr      *oplist;
   struct opllist **llist;
   opptr           *rlist;
   idptr typl,typr;
   shortint level;

   typl=binid(typlbin); typr=binid (typrbin);

   if ( blocklevel>IDMAINLEVEL ) {         /* actblock is body of Operator. */
      level=blocklevel-1;                  /* Operator is declared on next  */
      oplist=blkop (blkfather (actblock)); /* higher level.                 */
   } else {
      level=blocklevel;
      oplist=blkop (actblock);
   }
#ifdef CHECK
   if ( level<IDPRELEVEL ) {
      errput (9643,pos,NULL); return NULL;
   } else
#endif
   if ( level>IDMAINLEVEL )        /* Operator is local subprogram */
      blkfset(blkfather(actblock),innerrout);

  /* Search Operator symbol. */
   if ( psym==symNIL ) {        /* standard Operator */
#ifdef CHECK
      if ( symc<cAssign or symc>cMonop ) {
	 errput (9643,pos,NULL); return NULL;
      }
#endif
      if ( level<=IDMAINLEVEL ) {
	 oplist = oparray[level-IDPRELEVEL]+symc-cAssign;
      } else
      for (; *oplist!=NULL; oplist= &(*oplist)->next)
	 if ( (*oplist)->psym==symNIL and symc==(*oplist)->symc )
	    break;
   } else {                     /* userdefined */
      for (; *oplist!=NULL; oplist= &(*oplist)->next)
	if ( psym==(*oplist)->psym ) break;
   }

   if ( *oplist!=NULL ) {    /* Operator symbol found. */
      for (llist= &(*oplist)->llist; *llist!=NULL; llist= &(*llist)->next)
	 if ( typl==(*llist)->typl ) break;

      if ( *llist!=NULL )
      for (rlist= &(*llist)->rlist; *rlist!=NULL; rlist= &(*rlist)->next)
	 if ( typr==(*rlist)->typr ) break;
   }

   if ( *oplist==NULL ) {
      *oplist=(optabptr  ) malloc (sizeof(**oplist));
      if (not *oplist) memerror (pos) ;
      (*oplist)->llist=NULL;
      (*oplist)->symc=symc;
      (*oplist)->psym=psym;
      (*oplist)->next=NULL;
      llist= &(*oplist)->llist;
   }

   if ( *llist==NULL ) {
      *llist=(struct opllist*) malloc (sizeof(**llist));
      if (not *llist) memerror (pos) ;
      (*llist)->rlist=NULL;
      (*llist)->typl=typl;
      (*llist)->next=NULL;
      rlist= &(*llist)->rlist;
   }
   if ( *rlist==NULL ) {
      symctype code;
      opptr           temp;

      *rlist=temp=(opptr) malloc (sizeof(**rlist));
      if (not temp) memerror (pos) ;
      temp->status=opfinit;            /* initialize flags */
      temp->typr=typr;
      temp->csym=csym;
      temp->restyp=restyp;
      if ( ((code=binsymc(unname(restyp)))==cARRAY) or code==cSET )
	  opfset(*rlist,arraytype);
      else if ( code==cDYNAMIC )
	  opfset(*rlist,dynamic);
  /*    temp->level=level; */
      temp->status.varpl= varpl;
      temp->status.varpr= varpr;
      temp->bin=NULL;
      temp->op= *oplist;
      temp->next=NULL;
   } else
   if ( op_is (*rlist,forward) ) {
      opfclr (*rlist,forward);
      blksetfor (blkfather (actblock),false); /* Forward resolved, so     */
					      /* decrease forward-counter */

   } else {
      char *op_name;
      if ( psym!=symNIL )
	 op_name=symtab (psym);
      else
	 op_name=symptext[symc];
      errput (5301, pos, op_name) ;   /* Redeclaration of Operator */
   }

#ifdef CHECK
   if (*rlist) {idptr l = optypl(*rlist); } ;
#endif
   return *rlist;

} /*opins*/

					       /*---------------*/
#ifdef LINT_ARGS
global int opforw ( optabptr oplist,int n)
#else
global int opforw(oplist,n)                    /*  o p f o r w  */
optabptr   oplist;
int             n;
#endif
{
   opptr           rlist;
   struct opllist *llist;

   if ( n==0 or oplist==NULL ) return 0;

   for (; oplist!=NULL; oplist= oplist->next)

      for (llist= (oplist)->llist; llist!=NULL; llist= (llist)->next)

	 for (rlist=(llist)->rlist; rlist!=NULL; rlist= (rlist)->next)
	    if ( rlist->status.forward==true ) {
	       char *op_name;
	       if ( rlist->op->psym!=symNIL )
		  op_name=symtab (rlist->op->psym);
	       else
		  op_name=symptext[rlist->op->symc];

	       errput (5303, binpos (rlist->bin), op_name);
	     /* Unsatisfied forward reference on Operator */
	       n--; if ( n==0 ) return 0;
	    }
   return n;
} /* opforw */

							/*---------------*/
#ifdef LINT_ARGS
global void opinit ( void)
#else
global void opinit()                                    /*  o p i n i t  */
#endif
{
#define valpar false        /* value operand */
#define opi(symc,restyp,typl,typr)    \
	      opins(symc,symNIL,symNIL,restyp,typl,typr,valpar,valpar);

 opi(cPlus   ,integertype,integertype,integertype);
 opi(cMinus  ,integertype,integertype,integertype);
 opi(cMult   ,integertype,integertype,integertype);
 opi(cDIV    ,integertype,integertype,integertype);
 opi(cMOD    ,integertype,integertype,integertype);

 opi(cMPlus  ,integertype,notype     ,integertype);
 opi(cMMinus ,integertype,notype     ,integertype);

 opi(cAssign ,realtype  ,realtype    ,integertype);

 opi(cPlus   ,realtype  ,realtype  ,realtype  );
 opi(cMinus  ,realtype  ,realtype  ,realtype  );
 opi(cMult   ,realtype  ,realtype  ,realtype  );
 opi(cDiv    ,realtype  ,realtype  ,realtype  );

 opi(cMPlus  ,realtype  ,notype    ,realtype   );
 opi(cMMinus ,realtype  ,notype    ,realtype   );

 opi(cNOT    ,booleantype,notype     ,booleantype);
 opi(cAND    ,booleantype,booleantype,booleantype);
 opi(cOR     ,booleantype,booleantype,booleantype);

 opi(cLT     ,booleantype,realtype ,realtype   );
 opi(cLE     ,booleantype,realtype ,realtype   );
 opi(cGT     ,booleantype,realtype ,realtype   );
 opi(cGE     ,booleantype,realtype ,realtype   );
 opi(cEQ     ,booleantype,realtype ,realtype   );
 opi(cNE     ,booleantype,realtype ,realtype   );

#undef valpar
#undef opi
/*opdump(*blkop(actblock));  */

} /*opinit*/                                          /*  o p i n i t  */



/*-----------------------------------*/
/*  writing access to optab entries  */

#ifdef LINT_ARGS
global void opsetcsym ( opptr op,symptr csym )
#else
global void opsetcsym(op,csym)
 opptr op;
 symptr csym ;
#endif
{
 if  (op)  op->csym = csym ;
} /*opsetcsym*/

					      /*-------------------*/
#ifdef LINT_ARGS
global void opsetbin  ( opptr op,binptr bin)
#else
global void opsetbin (op,bin)                 /*  o p s e t b i n  */
opptr op;
binptr bin;
#endif
{  if (op) op->bin = bin;
   else
       errput (9622, pos, "opsetbin");
		  /* NULL pointer in opsetbin */
} /*opsetbin*/


/*-----------------------------------*/
/*  reading access to optab entries  */

						/*---------------*/
#ifdef LINT_ARGS
global idflags *opflag ( opptr op,boolean set)
#else
global idflags *opflag(op,set)                  /*  o p f l a g  */
opptr op;
boolean set;     /* set==false:reading only */
#endif
{       static idflags dummy;
	idflags *res;

	if (op) res= &(op->status);
	else
	{       if (set)
		   errput(9641, pos, (char*)0);
		   /*  NULL-Pointer access in opflag */
		res= &dummy;
	}
	return res;
} /*opflag*/


						/*---------------*/
#ifdef LINT_ARGS
global idptr optypl  (  opptr op)
#else
global idptr optypl (op)                        /*  o p t y p l  */
  /* returns the left operand type of op */
opptr op;
#endif
{
 if (op) {
   struct opllist * lp = op->op->llist ;
   opptr rp ;

   while  (lp) {                        /* search for Operator op */
      rp = lp->rlist ;
      while  (rp and rp != op)   rp = rp->next ;
      if  (rp)  break ;
      lp = lp->next ;
   }                                    /* search returns left list ptr */
#ifdef CHECK
   if (not lp)
   {
     errput (9644, pos, symptext[op->op->symc]) ;
     return ( NULL );
   } else
#endif
   return ( lp->typl );
 }  /* op exists */
 else return ( NULL );
} /*optypl*/
						/*---------------*/
#ifdef LINT_ARGS
global idptr optypr  ( opptr op)
#else
global idptr optypr (op)                        /*  o p t y p r  */
opptr op;
#endif
{
 return ( op ? op->typr : NULL );
} /*optypr*/
						/*---------------*/
#ifdef LINT_ARGS
global symctype opsymc  ( opptr op)
#else
global symctype opsymc (op)                     /*  o p s y m c  */
opptr op;
#endif
{
 return ( op ? op->op->symc : cNosym );
} /*opsymc*/

						/*---------------*/
#ifdef LINT_ARGS
global symptr oppsym ( opptr op)
#else
global symptr oppsym(op)                        /*  o p p s y m  */
opptr op;
#endif
{
 return  op ? op->op->psym : symNIL ;
} /*oppsym*/

						/*---------------*/
#ifdef LINT_ARGS
global symptr opcsym ( opptr op)
#else
global symptr opcsym(op)                        /*  o p c s y m  */
opptr op;
#endif
{
 return  op ? op->csym : symNIL ;
} /*opcsym*/

						/*-----------------------*/
#ifdef LINT_ARGS
global shortint oppriority ( opptr op)
#else
global shortint oppriority(op)                  /*  o p p r i o r i t y  */
opptr op;
#endif
{
 return  op ? symprio (op->op->symc) : -1 ;
} /* oppriority */

						/*-------------------*/
#ifdef LINT_ARGS
global binptr opresult ( opptr op)
#else
global binptr opresult(op)                      /*  o p r e s u l t  */
opptr op;
#endif
{
  return op ? op->restyp : NIL ;
} /* opresult */

						/*-----------------*/
#ifdef LINT_ARGS
global boolean opfunct ( opptr op)
#else
global boolean opfunct(op)                      /*  o p f u n c t  */
opptr op;
#endif
{
 return op ?  op->csym != symNIL : true ;
} /*opfunct*/

#ifdef LINT_ARGS
global binptr opbin ( opptr op)
#else
global binptr opbin(op)
opptr op;
#endif
{       binptr bin;

	if (op) bin=op->bin;
	else
	{
		bin=NULL;
	}
	return bin;
} /*opbin*/

						/*---------------*/
#ifdef LINT_ARGS
local boolean opcomp  ( opptr op1,opptr op2)
#else
local boolean opcomp (op1,op2)                  /*  o p c o m p  */
opptr op1,op2;
#endif
{
     if ( op1->typr == op2->typr and
	  optypl (op1) == optypl (op2) )
	return true;
     else return false;
} /* opcomp */


local boolean twice;
local int     n_coers;
							  /*-------------*/
#ifdef LINT_ARGS
local opptr opfnd1 ( symctype symc,symptr psym,binptr typl,binptr typr)
#else
local opptr opfnd1(symc,psym,typl,typr)                   /* o p f n d 1 */
symctype    symc;
symptr      psym;
binptr       typl,typr;
#endif
{
   opptr           rlist,opfound=NULL;
   struct opllist *llist;
   optabptr        oplist;
   blockrec       *block;
   shortint       blevel,oplevel;
   int            n_left;

   n_coers=3;  twice=false;

#ifdef TRACE
 print("Suche Operator "); print(symtab(psym)); print(" fuer Typen ");
 binprint(typlbin); print(" "); binprint(typrbin); printline();
#endif

   block=actblock;
   blevel=blocklevel;
   while ( block!=NULL ) {
       oplist= *blkop (block);

      /* Search Operator symbol. */
       if ( psym==symNIL ) {        /* standard Operator */
#ifdef CHECK
	  if ( symc<cAssign or symc>cMonop ) {
	     errput (9642,pos,NULL); return NULL;
	  }
#endif
	  if ( blevel<=IDMAINLEVEL ) {
	     oplist = *(oparray[blevel-IDPRELEVEL]+symc-cAssign);
	  } else
	  for (; oplist!=NULL; oplist= oplist->next)
	     if ( oplist->psym==symNIL and symc==oplist->symc )
		break;
       } else {                     /* userdefined */
	  for (; oplist!=NULL; oplist=oplist->next)
	    if ( psym==oplist->psym and symc==oplist->symc  ) break;
       }

       if ( oplist ) {                    /* Operator symbol found. */
	  for (llist = oplist->llist;     /* Scan left operands.    */
	       llist!=NULL; llist= llist->next) {
	     n_left = opcoers (typl,llist->typl);

	     if ( n_left < 2 )               /* Left operand type found. */
		for (rlist=llist->rlist;     /* Scan right operands.     */
		     rlist!=NULL; rlist=rlist->next) {
		   int n_act=opcoers (typr,rlist->typr);

		   IF  (n_left ==1 and op_is (rlist,varpl) and
			not sub_or_base_of(typl, iddatyp(llist->typl)) )
		      or
			(n_act ==1 and op_is (rlist,varpr) and
			not sub_or_base_of(typr, iddatyp(rlist->typr)) )
		   THEN
		     continue;
		   FI

		   n_act += n_left;
		   if ( n_act == 0 ) {
		      n_coers=0;
		      return rlist;
		   }
		   else if ( n_act <= 2 ) {
		      if ( n_act < n_coers ) {
			 twice=false;
			 opfound=rlist;
			 oplevel=blevel;
			 n_coers=n_act;
		      } else
		      if ( n_act == n_coers ) {
			 if ( blevel == oplevel or
			      not opcomp (rlist,opfound) )
			    twice=true;
		      }
		   }
		} /* scan right operands */

	  } /* scan left operands */
       } /* Operator symbol found */
       block=blkfather (block);  blevel--;
   }

   return opfound;
} /*opfnd1*/

							 /*-----------*/
#ifdef LINT_ARGS
global opptr opfnd (symctype symc,symptr psym,
		    binptr typlbin,binptr typrbin,postype oppos )
#else
global opptr opfnd(symc,psym,typlbin,typrbin,oppos)      /* o p f n d */
symctype    symc;
symptr      psym;
binptr      typlbin,typrbin;
postype     oppos ;
#endif
{
   opptr           opfound;


   opfound=opfnd1(symc,psym,typlbin,typrbin);

   if ( n_coers > 2 ) opfound= NULL;
   else {
      if ( twice == true )
	 errput (5302, oppos, NULL);
      opfset (opfound,used) ;
      if (idglobdecl  and  not (op_is (opfound, is_global) or
	   op_is (opfound, globalglobal) or op_is (opfound, usedglobal) ))
	opfset(opfound,usedglobal) ;
   }
#ifdef CHECK
   if (opfound) {idptr l = optypl(opfound); } ;
#endif
   return opfound;
} /*opfnd*/


/*----------------------------------------------------------------------
 Next functions perform different type- management
 And later belong to the modul coers.c
-----------------------------------------------------------------------*/
/* Transform the type to a standard numeric type:
   RVECTOR..CIMATRIX, if possible
*/
#ifdef LINT_ARGS
global binptr stdtyp ( binptr loctyp)
#else
global binptr stdtyp( loctyp )
  binptr loctyp;
#endif
{
  idptr id;
  boolean matrix = false ;
  binptr p;

  IF  binsymc(loctyp) != cDYNAMIC
     or (binsymc(loctyp) >= cRVECTOR  and binsymc(loctyp) <= cCIMATRIX)
  THEN
    /* loctyp is already standard
       or is not coersible
    */
    return loctyp;
  FI

  p = binright(loctyp);
  switch ( binsymc(p) ){
    case cRVECTOR  : return  rmatrixtype;
    case cCVECTOR  : return  cmatrixtype;
    case cIVECTOR  : return  imatrixtype;
    case cCIVECTOR : return  cimatrixtype;
    default:
      IF binsymc(p = unname(p))==cDYNAMIC THEN
	matrix = true;
	p = binright(p);
      ELSE
	p = binright(loctyp); /* restore p */
      FI
    }


   id = binid(p);
   IF id == idREAL THEN
     return  (matrix )? rmatrixtype : rvectortype ;
   ELIF id == idINTERVAL THEN
     return  (matrix )? imatrixtype : ivectortype ;
   ELIF id == idCOMPLEX THEN
     return  (matrix )? cmatrixtype : cvectortype ;
   ELIF id == idCINTERVAL THEN
     return  (matrix )? cimatrixtype : civectortype ;
   FI

   return loctyp;
}
/*--------------------------------------------------------------------*/
/*  s u b _ o r _ b a s e _ o f */
#ifdef LINT_ARGS
local boolean sub_or_base_of (binptr atype, binptr ftype)
#else
local boolean sub_or_base_of (atype,  ftype)
binptr atype, ftype ;
#endif
/* Is the atype a subtype of ftype or vice versa ? */
/* Strong name-compatibility 08.07.91 */
{
 boolean b1,b2;
 binptr b_atype, b_ftype;   /* Base type of subrange */

 atype = unname(atype);
 ftype = unname(ftype);

 /* One of the types must be a subrange */
 IF (binsymc(atype) != cTill) and (binsymc(ftype) != cTill) THEN
   return false;
 FI

 b_atype = unname(subtype(atype));
 b_ftype = unname(subtype(ftype));

 b1 = (binid(b_atype))? binid(b_atype)== binid(ftype): b_atype==ftype;
 b2 = (binid(b_ftype))? binid(b_ftype)== binid(atype): b_ftype==atype;

 return b1 or b2;
}                                       /*  s u b _ o r _ b a s e _ o f */

/*------------------------------------------------------------------------*/
/*  s t r _ c o m p a t i b l e */
#ifdef LINT_ARGS
local boolean str_compatible  (  binptr act_type )
#else
local boolean str_compatible (act_type)
  /* checks type compatibility of data type with a string-type */
  binptr act_type ;
#endif
{
  return
     /* string := string  */
       (binid(act_type)== idSTRING or
     /* string :=  "str_const" */
	binsymc(act_type)== cScon  or
     /* string := array of char  */
	 unname (binright (act_type)) == chartype);
}

/*------------------------------------------------------------------------*/
/*  n a m e _ c o m p a t i b l e */
#ifdef LINT_ARGS
local boolean name_compatible  (  binptr ltyp, binptr rtyp )
#else
local boolean name_compatible (ltyp, rtyp)
 /* checks name compatibility of data types */
  binptr ltyp, rtyp ;
#endif
{
  return    ltyp == rtyp                      /* same var declaration*/
	 or  sym_is [binsymc (ltyp)] .identifier  and
	     binid (ltyp) == binid (rtyp);       /* name compatible */
}


/*------------------------------------------------------------------------*/
/* s t c t _ c o m p a t i b l e*/
#ifdef LINT_ARGS
local boolean stct_compatible  (  binptr ltyp, binptr rtyp )
#else
local boolean stct_compatible (ltyp, rtyp)
 /* checks structure compatibility of data types */
  binptr ltyp, rtyp ;
#endif
{
  symctype lsymc = binsymc (ltyp) ;
  IF lsymc != binsymc(rtyp) or /* Structure compatible */
     lsymc == cTill            /*Subtypes are not compatible*/
  THEN
    return false;
  ELIF sym_is [lsymc] .symbol THEN  /* Temporal types */
    return
      binsym (ltyp) == binsym (rtyp)  and
      typ_compatible (binright(ltyp), binright(rtyp));
  ELSE
    return
      typ_compatible (binleft (unname(ltyp)), binleft (unname(rtyp)))
     and
      typ_compatible (binright(unname(ltyp)), binright(unname(rtyp)));
  FI
}

/*------------------------------------------------------------------------*/
#ifdef LINT_ARGS
global boolean typ_compatible  (  binptr ltyp, binptr rtyp )
#else
global boolean typ_compatible (ltyp, rtyp)  /*  t y p _ c o m p a t i b l e  */
  /* checks type compatibility of data types */
  /* used in tempdecl */
  binptr ltyp, rtyp ;
#endif
BEGIN(typ_compatible)

  return
	name_compatible(ltyp,rtyp)
      or /* not strong type checking */
	unname(ltyp) == unname(rtyp)
      or /* Is the ltyp a subtype of rtyp or vice versa ? */
	sub_or_base_of(ltyp, rtyp )
      or /* Structure compatible */
	stct_compatible (ltyp, rtyp )
  ;
END /* typ_compatible */		    /*  t y p _ c o m p a t i b l e  */

/*------------------------------------------------------------------------*/
/*  c o m p a t i b l e */ /* Version  07.11.91 */
#ifdef LINT_ARGS
global boolean compatible  (  binptr left, binptr right )
#else
global boolean compatible (left, right)
  /* checks assignment type compatibility of data types (PXSC p 44-46.)*/
  binptr left, right ;
#endif
BEGIN(compatible)
int ret = 0;

IF  left == anytype or right == anytype THEN
   return true ;
FI

IF name_compatible(left,right) THEN
   /* Strong name-compatibility  */
   return true ;
ELIF  sym_is [binsymc (left)] .identifier and
    /* Arrays require name-compatibility */
    (binsymc(unname(left))==cDYNAMIC or          /* dynamic arrays */
     binsymc(unname(left))==cARRAY and           /* static arrays  */
     unname(binright(unname(left)))!=chartype)   /* except char array */


THEN
  return false;
FI

IF sub_or_base_of(left, right ) THEN
  /* Is the left a subtype of right or vice versa ? */
  return true ;
FI

/* Structure compatibility */

left  = unname (left) ;
right = unname (right) ;

/* STRINGS */
IF binid(left) == idSTRING  THEN
     /* string := string         */
     /* string :=  "str_const"   */
     /* string := array of char  */
  return str_compatible(right);
ELIF binsymc(left)==cARRAY  and unname (binright (left)) == chartype
THEN /* array of char := "str_const" */
  ret = binsymc(right)== cScon               and
  rangesize (binleft (left)) == (long) strlen (bincharp(right));
  return ret;
FI

/* Other types */

if  (binsymc (left) != binsymc (right))
  return false ;

/* Temporal types !*/
IF sym_is[binsymc(left)].symbol THEN
  ret = binsym(left)==binsym(right) and
	compatible(binright(left),binright(right));
  return ret;
FI

switch  (binsymc (left))
 begin
  case cRECORD : case cLParent :   return left == right ;
  case cSET    : case cDYNAMIC :
  case cFILE   : case cArrow :
		   ret = compatible (binright(left),
				      binright(right)) ;
		   return ret;
  case cARRAY  :
		   ret =  rangesize (binleft(left)) ==
			   rangesize (binleft(right))   and
			   compatible (binright(left),binright(right)) ;
		   return ret;
  default :        return  left == right ;
 end ;

END

/*-------------------------------------------------------------------------*/
/*  b i n n c o e r s  */
#ifdef LINT_ARGS
global int binncoers  ( binptr lista, binptr listf )
#else
global int binncoers ( lista, listf )
  binptr lista, listf  ;
#endif
{
  int n_coers = 0;
  binptr act_par , uf_par ;
  boolean b1= false ,b2= false,b3= false,b4= false, b5= false;
   /* A FORMAL parameter has ALWAYS a NAMED data type */

  FOR ;listf and lista; listf = binright (listf),lista = binright (lista) DO

    IF binid(lista) and (binid(listf) == binid(lista))
    THEN
       continue;

    ELIF binsymc(listf) == cVarparam THEN /* binid(listf) != binid(lista)*/
      IF binsymc(lista) == cFUNCTION   or     /* Here was listf 08.08.91*/
	 binsymc(lista) == cPROCEDURE or
	 binid (unname(lista)) == idSTRING or
	 binid (lista) == idPTRCHAR
      THEN
	return NOCOERS;
      ELIF not  sym_is[binsymc(lista)].identifier THEN
	IF binid(listf) == binid(subtype(binleft(lista))) THEN
	  ++n_coers;
	ELSE
	  return NOCOERS;
	FI
      ELIF binid(listf) != binid(lista) THEN
	/* The condition is not always true, both idptr-s can be NULL*/
	IF (binid(listf) == binid(subtype(lista))) THEN
	   ++n_coers;
	 ELSE
	   return NOCOERS;
	 FI
      ELSE
	return NOCOERS;
      FI
    ELIF   binsymc(listf) == cFUNCTION  THEN
	 /*Paramlists and result types  must coincide */
	 binptr f_left , a_left ;
	 IF   binparcompare(binleft(f_left = binleft(listf)),
			    binleft(a_left = binleft(lista)))
	   and
	      binid(binright(f_left)) == binid(binright(a_left))
	 THEN
	     continue;
	 ELSE
	    return NOCOERS;
	 FI

    ELIF  binsymc(listf) == cPROCEDURE THEN
	 /*Paramlists  must coincide */
	 IF binparcompare(binleft(listf),binleft(lista))
	 THEN
	     continue;
	 ELSE
	    return NOCOERS;
	 FI

    ELIF binid (listf) == idPTRCHAR THEN
       /* ptr to char is compatible with string constant as in C */
       boolean act_id= sym_is[binsymc(lista)].identifier;
       act_par = unname ((act_id)? lista: binleft(lista)) ;
       IF   binsymc (act_par) == cScon  /* string constant */
       THEN
	 ++n_coers;
       ELSE
	 return NOCOERS;
       FI
    ELIF binid (unname(listf)) == idSTRING THEN
       boolean act_id= sym_is[binsymc(lista)].identifier;
       act_par = unname ((act_id)? lista: binleft(lista)) ;
       IF  str_compatible (act_par)
	 or
	  /* There is a user type-transfer function*/
	    (act_id             and
	    idfuncfnd(idsym(binid(listf)),binid(lista),binid(listf)) )
       THEN
	 ++n_coers;
       ELSE
	 return NOCOERS;
       FI

    ELIF not sym_is[binsymc(lista)].identifier THEN  /* unnamed type */
      act_par = binleft(lista), uf_par = unname(listf);
      /* NIL */
	b1=  (act_par == pointertype  and binsymc (uf_par) == cArrow);

      /* Structure compatible */
       b2=  stct_compatible (uf_par, act_par );

      /* not strong type checking */
       b3 =  (uf_par == unname(act_par));

      /* Is the ltyp a subtype of rtyp or vice versa ? */
       b4=  sub_or_base_of(act_par, listf);

      IF  b1 or b2 or b3 or b4
      THEN
	++n_coers;
      ELSE
	return NOCOERS;
      FI
    ELIF binid(listf) != binid(lista) THEN

      b1= (binid(lista)== idINTEGER and binid(listf)== idREAL );

      /* Structure compatible */
       b2=  stct_compatible (unname(listf) , lista );

      /* not strong type checking */
       b3 =  (unname(listf) == unname(lista));

      /* Is the lista a subtype of listf or vice versa ? */
      b4=  sub_or_base_of(lista, listf);

     /* There is a user type-transfer function*/
     b5= (idfuncfnd(idsym(binid(listf)),binid(lista),binid(listf)) != NULL);

      IF b1 or b2 or b3 or b4 or b5
      THEN
	++n_coers;
      ELSE
	return NOCOERS;
      FI
    FI
  OD
  return (listf == NIL  and  lista == NIL)? n_coers : NOCOERS  ;

} /* binncoers */                               /*  b i n n c o e r s  */

/*-------------------------------------------------------------------------*/
/*  o p c o e r s  */
#ifdef LINT_ARGS
local int opcoers  (binptr binatyp, idptr ftyp)
#else
local int opcoers (binatyp, ftyp)
binptr binatyp;
idptr  ftyp;
#endif
{   binptr binftyp;
    idptr atyp, idp;
    int n_coers = 0;
    binptr p;

    atyp= ( binatyp == NULL )?NULL: binid(binatyp);

    if ( ftyp == NULL ) {
       n_coers= ( atyp == NULL )?0: 3 ;
    } else
    if ( ftyp != atyp ) {

      binftyp = iddatyp(ftyp);
      if ( strong_comp )
	n_coers=3;
      else
      if ( (binid(unname(binftyp)) == idSTRING and
	     str_compatible(binatyp))

	 or
	   /* There is a user type-transfer function*/
	    idfuncfnd(idsym(ftyp), atyp , ftyp )

	 ) n_coers=1;

       else if ( ftyp == idPTRCHAR )
	 /* ptr to char is compatible with string constant as in C */
	 return (binsymc (binatyp) != cScon)? 3 : 1 ;

       else if ( (atyp == idINTEGER and ftyp == idREAL)
	  or
	    /* Is the ltyp a subtype of rtyp or vice versa ? */
	      sub_or_base_of (binatyp, binftyp )
    or  ( p= unname(binftyp) ,
       /* Arrays require name-compatibility */
        ((binsymc(p) != cDYNAMIC and      /* dynamic arrays */
        binsymc(p) != cARRAY)            /* static arrays  */
        or
        unname(binright(p))!=chartype)   /* except char array */
        and
      /* Structure compatible */
        stct_compatible (p , binatyp )
        )
    or
	    /* not strong type checking */
	      (unname(binftyp) == unname(binatyp))
	  or
	    /* NIL */
	     (binatyp == pointertype  and binsymc (binftyp) == cArrow )
	  or
	    /* There is a user type-transfer function*/
	     idfuncfnd(idsym(ftyp), atyp , ftyp ) )
	n_coers=1;
      else n_coers=3;
    }
  return n_coers ;
} /* opcoers */

/*--------------------------------------------------------------------------*/
/*  c o e r s e */
/*Performs a coersion from actual to formal type, if necessary*/
#ifdef LINT_ARGS
global void coerse  ( binptr lista, binptr listf , binptr clist )
#else
global void coerse ( lista, listf, clist )
  binptr lista, listf , clist ;
#endif
{
  idptr id;
  binptr t, cpar;

  IF binsymc (lista) == cFUNCTION or binsymc (lista) == cPROCEDURE THEN
    return;
  FI

  IF not sym_is [binsymc (lista)] .identifier THEN
    lista = binleft (lista) ;    /* act. param has unnamed data type */
  FI

  IF  binid(listf) == binid(lista)
    or
      (binleft(lista) == pointertype  and   /* NIL -> any ptr. */
       binsymc (unname(listf)) == cArrow)
    or
      binsymc (listf) == cVarparam   /* 19.04.91. DS */
  THEN return ;
  FI

  id= idfuncfnd(idsym(binid(listf)),binid(lista),binid(listf)) ;
  cpar = (binsymc(clist)==cComma)?binleft(clist):clist;
  t = bininsert(cpar,bincreate(cComma)); /* cComma for binexchange */
  binexchange(t);

  IF id THEN
    /* userdefined Type transfer function is found*/
    binchange(t,cRout);
    binupid(t,id);

  ELIF binid(unname(listf)) == idSTRING  and
       binid(unname(lista)) != idSTRING THEN /* Treats string coersions */
    binchange (t, cCall) ;
    binupsym  (t, symins ("s_stat")) ;
    t = bininsert (binright (t), bincreate (cComma)) ;
    binappend (t, bincreate (cIcon)) ;
    IF binsymc (lista) == cScon THEN
      binupvalue (binright (t), (long) strlen (bincharp (lista))) ;
    ELSE
      binupvalue (binright (t), (long) rangesize (binleft(unname (lista))));
    FI

  ELIF  not sym_is [binsymc(unname(listf))] .arraytype THEN /* Other cases */
    boolean struct_res;
    symctype symc = binsymc (listf);
    idptr idp = binid(unname(listf));
    binchange (t, cRParent) ;        /* create cast Operator */
    binllink  (t, NIL) ;             /* destroy left binptr */

    IF id_is(idp,dynamic) or symc == cSTRING  THEN  /* "*(type *)&"  */
       binptr p;
       binlside  ( t, bincreate( cArrow));
       p = binleft(t);
       binappend (p,
	      binidcreate ( (symc==cRout ? cIdent : symc), idp)) ;
       binuppos( binright(p), binpos (t)) ;
       /*insert  "*"*/
       p =bininsert( t, bincreate(cArrow));
       binexchange(p);
       varexp(binright(t), lista ); /* Varexp inserts "&"*/
     ELSE
       binlside (t, binidcreate ( cIdent ,binid(listf) )) ;
     FI
  ELSE
    bindelete (t) ; /* delete Comma  29.1.92 */
  FI
}                                        /* c o e r s e */

/*-----------------------------------------------------------------------*/
					    /*  d s _c o m p a t i b l e*/
#ifdef LINT_ARGS
local boolean ds_compatible  (  binptr dyntyp, binptr stattyp )
#else
local boolean ds_compatible (dyntyp, stattyp)
 /* checks type compatibility for the transformation of
      stat. arr. to  dyn. one  */
  binptr dyntyp, stattyp ;
#endif
BEGIN(ds_compatible)

  IF   binsymc(unname (stattyp)) != cARRAY  or
       binsymc(unname (dyntyp))  != cDYNAMIC   THEN
    return false ;
  FI

  WHILE ( binsymc( unname (stattyp)) == cARRAY and
	  binsymc( unname (dyntyp))  == cDYNAMIC )
  DO
    dyntyp = binright(unname(dyntyp));
    stattyp = binright(unname(stattyp));
  OD

  return name_compatible(dyntyp, stattyp);
END /* ds_compatible */                       /* d s _ c o m p a t i b l e */

/*-----------------------------------------------------------------------*/
#ifdef LINT_ARGS
global binptr type_conv  (                     /* t y p e _ c o n v */
  binptr exp, binptr act_type ,
  boolean *not_found )
#else
global binptr type_conv (exp, act_type,  not_found )
  /* IF the routine call exp() with the
	argument act_type (PA list) is a type conversion function
     THEN handles it and returns target_type
     ELSE returns anytype;
     FI
  */
  binptr exp, act_type ;
  boolean *not_found;
#endif
BEGIN(type_conv )
  binptr source_type = act_type ;
  binptr target_type ;
  binptr restyp = anytype;
  int  parcount = 0 ;
  symctype symc = binsymc (exp) ;
  binptr p;
  idptr idp = idistypeid(exp) ;

  boolean text = (symc == cTEXT);
    /*Param of type text can be only a variable*/
  boolean struct_res = false;

  IF not idp THEN
    return restyp;
  FI
  /*-----------------------------*/
  /*  TYPE conversion functions  */
  /*-----------------------------*/

  if  (source_type  and  not sym_is [binsymc (source_type)] .identifier)
    source_type = binleft (source_type); /* Param has unnamed data type */

  *not_found = false;

  restyp = idbin(idp);

  p = binright (exp) ;
  IF  p  THEN
     ++parcount ;
     IF binsymc(p)==cComma THEN
       ++parcount;
     FI
  FI

  IF  parcount != 1  THEN
    illroutine(exp,act_type,not_found);
    return (strong_comp)?anytype:restyp;
  FI

   target_type = iddatyp (idp) ;

   IF binid (unname(target_type)) == idSTRING and
      binid (unname(source_type)) != idSTRING
   THEN
     if   (                                      /* parameter must be */
	  binsymc (source_type) == cScon or        /* string constant */
	  binsymc (unname (source_type)) == cARRAY and /* or array of char */
	  binsymc (unname (binright (unname (source_type)))) == cCHAR
	 )  then
      begin                                  /* convert static string */
	binchange (exp, cCall) ;             /*  to dynamic string */
	binupsym  (exp, symins ("s_stat")) ;
	ins_sizeof (binright (exp), source_type) ;
	return (target_type) ;                      /*  and exit */
      end
    else
      begin
       illroutine (exp,act_type,not_found);
       return (strong_comp)?anytype: restyp;
      end
/*
   ELIF
      binsymc (source_type) == cScon and
      compatible (target_type, source_type)
   THEN
	return (target_type) ;
   ELSE
       illroutine (exp,act_type,not_found);
       return (strong_comp)?anytype: restyp;
*/
   FI

   IF not (compatible (target_type, source_type)  or
	  subtype (target_type) == subtype (source_type))
   THEN   /* Check if it is a legal conversion ? */
     IF (binsymc(unname(source_type))== cArrow and
         binsymc(unname(target_type))== cArrow )
        or
        (sym_is [binsymc(unname(source_type))] .scalartype and
        (idp == idREAL or sym_is [binsymc(unname(target_type))] .scalartype))
     THEN
	; /* It's  a legal conversion , go further */
     ELIF  text and
	   binsymc(unname(source_type)) == cFILE and
	   binsymc(unname(target_type)) == cFILE
     THEN
       errput (172, binpos(binright(exp)), namestring(source_type));
	/*Warning: Type @ is not compatible with TEXT */
     ELIF  ds_compatible ( target_type, source_type)  THEN
       /* Preconversion from a static to dynamic array*/
	 target_type = stdtyp(target_type);
	 stattodyn( binright(exp), target_type, source_type);
     ELSE  /* Wrong type conversion */
       illroutine(exp,act_type,not_found);
       return (strong_comp)?anytype:restyp;
     FI
   FI

   IF  sym_is [binsymc(unname( target_type))] .arraytype or
       binsymc(unname(source_type))==cScon
   THEN
     /* No cast Operator for array types */
     postype pos ;
     pos = binpos (exp) ;
     IF binleft(exp) THEN
       binllink (exp, NIL) ; /* destroy left binptr */
     FI
     bindelete(exp);
     restyp = binidcreate ( (symc==cRout ? cIdent : symc), idp);
     binuppos ( restyp, pos) ;
   ELSE

     /* Insert (type *) after "*" if it hangs below  already Eg. y_suba */
     /* Cast Operator *(type *)&  for text and structures      */
     /* Since casting with structures is impossible            */
     /* ELSE Cast Operator (type )                             */

     /* dynamic array  or string */
     /*Param of any other structured type can be also function result */
     struct_res = id_is(idp,dynamic)  or symc == cSTRING ;

     p = binright(exp);
     IF binsymc(p)==cArrow THEN    /* "*" -> *(type *)      */
       binchange (exp, cArrow) ;   /* "*()" Eg. y_suba      */
       binllink(exp,NIL );         /* destroy left binptr   */
       binchange (p, cPCast) ;     /* "*(? *)()"            */
       binllink  (p, NIL) ;        /* destroy left binptr   */
       binllink (p, idbin (idp)) ; /* "*(type *)()"         */
       restyp = binleft (p) ;

     ELIF struct_res or text  THEN        /* *(type *)&           */
       binchange (exp, cRParent) ;        /* create cast Operator */
       binllink  (exp, NIL) ;              /* destroy left binptr */
       binlside  ( exp, bincreate( cArrow));
       p = binleft(exp);
       binappend (p,
	      binidcreate ( (symc==cRout ? cIdent : symc), idp)) ;
       binuppos( binright(p), binpos (exp)) ;
       restyp =binright(p) ;  /* return type */
       /*insert  "*"*/
       p =bininsert( exp, bincreate(cArrow));
       binexchange(p);
       IF struct_res THEN /* Varexp inserts "&"*/
	 varexp(binright(exp),act_type);
       FI
       IF text THEN   /*insert "&"*/
	 p =bininsert( binright(exp), bincreate(cAdres));
	 binexchange(p);
       FI

     ELSE   /* (type) */
       binchange (exp, cRParent) ;        /* create cast Operator */
       binllink  (exp, NIL) ;              /* destroy left binptr */
       binllink (exp, idbin (idp)) ;
       restyp = binleft (exp) ;
     FI

   FI
   return restyp;

END /*  t y p e _ c o n v  */
