/***   coercion.c   ***/

#include "Algol.h"
#include "coercion.h"
#include "routine_call.h"
   /***  ERRORS: 132,511,526-7,541,651-6  ***/

/*------------------------------------------------------------------------*/
/* mode equivalence */

#define max_asp	   50

static int assumptions, VASP[max_asp], WASP[max_asp];

#define init_mode_equivalence()  assumptions=0
static bool mode_equivalence(int,int);
static bool union_member(int,int);

static bool mode_equivalence(v,w) int v,w;
{int aold,av,bv,bw,n,i;
	aold=assumptions;
start:	av=A[v];
	if(v==w || av==ROW && w==row_mode)return(TRUE);
	if(av!=A[w]){assumptions=aold; return(FALSE);}
	if(recursive(v) || recursive(w)){
	    i=0; while(i<assumptions){
		i++;
		if(v==VASP[i] && w==WASP[i])return(TRUE);
		if(w==VASP[i] && v==WASP[i])return(TRUE);
	    }
	    must(assumptions++ <= max_asp,132);
	    VASP[assumptions]=v; WASP[assumptions]=w;
	}
	switch(av){
	    case REF:	 v=B[v]; w=B[w]; goto start;
	    case STRUCT: if((n=C[v])!=C[w]){assumptions=aold; return(FALSE);}
		 bv=B[v]; bw=B[w]; i=0;
			 while(i<n && C[bv+i]==C[bw+i] &&
			     mode_equivalence(B[bv+i],B[bw+i]))i++;
			 if(i<n){assumptions=aold; return(FALSE);}
			 return(TRUE);
	    case ROW:	 bv=B[v]; bw=B[w];
			 if(A[bv]!=A[bw]){assumptions=aold; return(FALSE);}
	    			v=B[bv]; w=B[bw]; goto start;
	    case UNION:	 bv=B[v]; bw=B[w]; n=C[bv]; i=0;
	    		 while(i<n && union_member(B[bv+i],bw))i++;
			 if(i==n){n=C[bw]; i=0;
				while(i<n && union_member(B[bw+i],bv))i++;
			 }
			 if(i<n){assumptions=aold; return(FALSE);}
			 return(TRUE);
	    case PROC:	 bv=B[v]; bw=B[w];
			 if((n=C[v])!=C[w]){assumptions=aold; return(FALSE);}
			 i=0; n += 1;
			 while(i<n && mode_equivalence(B[bv+i],B[bw+i]))i++;
			 if(i<n){assumptions=aold; return(FALSE);}
			 return(TRUE);
	}
	return(TRUE);
}

static bool union_member(u,v) int u,v;
{int n,i;
	n=C[v]; i=0;
	while(i<n && !mode_equivalence(u,B[v+i]))i++;
	return(i<n);
}

bool equivalent_or_union_member(u,v) int u,v;
{	init_mode_equivalence();
	return(A[v]==UNION?union_member(u,B[v]):mode_equivalence(u,v));
}

/*------------------------------------------------------------------------*/
/* coercions */

static void decollateration(int,int*);
static bool dereferencing(int*);

bool strong_coercion(goal, Q) int goal,*Q;
{int how,new_g,u,v,n,i; inta bits;
#if DEBUG
	fprintf(O,"strong_coercion, Q=%c, P=%d, goal=%d, Z=%d\n",
			*Q==G?'G':*Q==H?'H':'F',P,goal,Z);
#endif
	if(*Q != G)return(TRUE);
	u=A[Z]; v=A[goal];
	if(v==VOID){void_coercion(Q); emp(); void_result(); return(TRUE);}
	if(u==VOID){emp(); Z=actual_instance(goal); return(TRUE);}
	if(u==REF && B[Z]==0){
	    must(v==REF,511); emp();
	    Z=actual_instance(goal); C[Z]=0; return(TRUE);
	}
	if(u==COLL){decollateration(goal,Q); return(TRUE);}
	if(firmly_coerceable(Z,goal,&how))
	    {firm_coercion(goal,how,Q); return(TRUE);}
	if(v==ROW){
	  new_g=unfold(goal);
	  if(strong_coercion(B[B[new_g]],Q)){
	      if(*Q == G){
		  u=ask();n=A[B[new_g]];A[u]=ROW;v=B[u]=askn(n+1);C[u]=1;
		  for(i=1;i<=n;i++){A[v+i]=B[v+i]=C[v+i]=1;}
		  A[v]=n; B[v]=Z; C[v]=1; Z=u;
	      }
	      relax(new_g);return(TRUE);
	  }
	  relax(new_g);
	  if(A[B[B[goal]]]==BOOL){
	      meek_coercion(Q);
	      if(A[Z]==BITS){
		  bits=get_bits(Z); emp(); Z=askn(3); A[Z]=ROW; B[Z]=Z+1;
		  C[Z]=1; A[Z+1]=C[Z+2]=1; v=B[Z+1]=askn(C[Z+1]=32);
		  A[Z+2]=0; B[Z+2]=31;
		  for(i=31;i>=0;i--){
			A[v+i]=BOOL; B[v+i]=(int)(bits&1); bits >>= 1;}
		  return(TRUE);
	      }
	  }
	  return(*Q !=G);
	}
	if(v==REAL){
	  meek_coercion(Q);
	  if(A[Z]==INT){
	    re1=get_int(Z); emp(); put_real(re1); return(TRUE);}
	  return(*Q !=G);
	}
	if(v==STRUCT && get_complex(goal)){
	  meek_coercion(Q);
	  if(get_real(Z)){ emp(); put_complex(re1, 0.0 ); return(TRUE);}
	  return(*Q != G);
	}
	return(FALSE);
}

static void decollateration(g,Q) int g, *Q;
{int u,v,w,n,Bu,goal,Bgoal,i,j,dim,new_goal,ml;
	goal=unfold(g); u=Z; n=C[u];Bu=B[u];Bgoal=B[goal];
	if(A[goal]==STRUCT){
	  must(C[goal]==n,652); A[u]=STRUCT;
	  for(i=0;i<n;i++){
		Z=B[Bu+i]; must(strong_coercion(B[Bgoal+i],Q),653);
		B[Bu+i]=Z; C[Bu+i]=C[Bgoal+i];
	  }
	  Z=u; if(*Q !=G){emp(); void_result();}
	  relax(goal);return;
	}
	must(A[goal]==ROW,651); dim=A[B[goal]];
	if(dim==1){more_instance(new_goal=B[Bgoal]);}
	else{
	  new_goal=ask(); A[new_goal]=ROW; B[new_goal]=v=askn(dim);
	  C[new_goal]=1; A[v]=dim-1; more_instance(B[v]=B[Bgoal]); C[v]=0;
	  for(i=v+1;i<v+dim;i++){A[i]=C[i]=1; B[i]=0;}
	}
	for(i=Bu;i<Bu+n;i++){
	    Z=B[i]; must(strong_coercion(new_goal,Q),654); B[i]=Z;
	}
	relax(new_goal);
	if(*Q != G){relax(u); relax(goal); void_result(); return;}
	Z=u;A[Z]=ROW;B[Z]=v=askn(dim+1);C[Z]=1;A[v]=dim;
	if(dim==1){
	   B[v]=Bu;C[v]=n;A[++v]=1;B[v]=n;C[v]=1;
	   for(i=Bu;i<Bu+n;i++){w=B[i];move(TRUE,w,i);relax(w);}
	   relax(goal); return;
	}
	ml=B[B[Bu]];
	if(C[ml]){B[v]=destination=askn(C[v]=n*C[ml]);}
	else{C[v]=0; more_instance(B[v]=B[ml]);}
	A[++v]=1;B[v]=n;
	for(i=1;i<dim;i++){A[v+i]=A[ml+i];B[v+i]=B[ml+i];}
	for(i=0;i<n;i++){
	   ml=B[B[Bu+i]];
	   for(j=1;j<dim;j++){
	      must(A[ml+j]==A[v+j],655);must(B[ml+j]==B[v+j],656);
	   }
	   spelling_row(ml,move_to_destination);
	   relax(B[Bu+i]);
	}
	freen(Bu,n);C[v+dim-1]=1;
	for(i=v+dim-1;i>v;i--)C[i-1]=(B[i]-A[i]+1)*C[i];
	relax(goal); return;
}

bool deproceduring(Q) int *Q;
{int v;
	if(*Q != G || A[Z]!=PROC || C[Z]) return(FALSE);
	v=Z; call_proc(Q); relax(v); return(*Q == G);
}

static bool dereferencing(Q) int *Q;
{int v;
	if(deproceduring(Q))return(TRUE);
	if(*Q != G || A[Z]!=REF)return(FALSE); 
	must(C[Z]>0,526);v=Z;Z=new_instance(B[v]);relax(v);return(TRUE);
}

bool firmly_coerceable(apriori,aposte,how) int apriori,aposte,*how;
{int u,v,i,n;
	u=apriori; init_mode_equivalence(); *how=1;
back:	if(mode_equivalence(u,aposte))return(TRUE);
	if(A[u]==REF){u=B[u];goto back;}
	if(A[u]==PROC && C[u]==0){u=B[B[u]]; goto back;}
	if(A[aposte]!=UNION)return(FALSE);
	u=apriori; v=B[aposte]; *how=2;
back2:	if(union_member(u,v))return(TRUE);
	if(A[u]==REF){u=B[u];goto back2;}
	if(A[u]==PROC && C[u]==0){u=B[B[u]]; goto back2;}
	if(A[u]!=UNION)return(FALSE);
	u=B[u]; n=C[u];
	for(i=0;i<n;i++){
	  if(!union_member(B[u+i],v))return(FALSE);
	}
	*how=3; return(TRUE);
}

void firm_coercion(goal,how,Q) int goal,how,*Q;
{int u,v;
	if(how==1){
	    while(!mode_equivalence(Z,goal) && dereferencing(Q));
	    return;
	  }
	if(how==3){meek_coercion(Q);}
	else{while(!union_member(Z,B[goal]) && dereferencing(Q));}
	if(*Q == G){
	    u=Z;v=C[goal];C[goal]=0;Z=new_instance(goal);C[goal]=v;
	    C[Z]=new_instance(how==2?u:C[u]); relax(u);
	}
}

void meek_coercion(Q) int *Q;
{int u;
start:	if(*Q != G) return;
	u=Z;
	while(A[Z]==REF){must(C[Z]>0,527); Z=B[Z];}
	if(A[Z]==PROC && C[Z]==0){call_proc(Q); relax(u); goto start;}
	if(u!=Z){Z=new_instance(Z); relax(u);}
}


bool weak_coercion(Q) int *Q;
{int u,v;
start:	if(*Q != G) return(FALSE);
	u=v=Z;
	while(A[Z]==REF && C[Z]>0)Z=B[v=Z];
	if(A[Z]==PROC && C[Z]==0){call_proc(Q); relax(u); goto start;}
	if(A[Z]==ROW || A[Z]==STRUCT)Z=v;
	if(u!=Z){Z=new_instance(Z); relax(u);}
	return(TRUE);
}

inta meek_integer(Q) int *Q;
{inta i;
	meek_coercion(Q); if(*Q!=G)return(1);
	must(A[Z]==INT,541);
	i=get_int(Z); emp(); return(i);
}

int short_meek_integer(Q) int *Q;
{inta i;
	i=meek_integer(Q); must(short_integer(i),542);
	return((int)i);
}