/*     
      TYPE CHECKING of MAGMA . Magma 1.0 . 1996 . Sylvain HUET

         typmagm.cpp : module de type checking de magma
*/
// Modification history:
//
//$ FA(13/04/2001): Use specials table defined in readmagm.cpp. TCreadstd()
//                  has been modified accordingly
//$ FA(03/05/2001): Promote to C++ file
//$ FA(03/05/2001): Use new lexer interface (lexer.h)
//$ FA(04/05/2001): Integrate floating-point syntax
//$ BB(11/03/2010): Add manlyz in several functions to add error message in manlyz structure buffer

#include <stdio.h>
#include <string.h>
#include "loadpak.h"
#include "compiler/lexer.h"
extern "C"
{
#   include "scolMMemory.h"
#   include "vm/mbytec.h"
#   include "mbytec2.h"
#   include "listlab.h"
#   include "compiler/typmisc.h"
int Mismagstd(const char *name);
}
#include "scolSpecialsFunctions.h"

//
int TCreada(mmachine m,manlyz z,int ind);
int TCreadt(mmachine m,manlyz z,int ind);
extern ScolSpecialFunction specials[SCOL_SPECIAL_FUNCTIONS_NUMBER];

/* lecture d'une variable */
int TCvar(mmachine m,manlyz z,int ind)
{
  int k,n,i;
  char buf[MAXSIZETOKEN+1];

  while(1)
    {
      if (Mreadtok(z)) return 0;
      if (z->tok[0]!='.')
        {
          z->giveback=1;
          return 0;
        }
//$ FA(04/05/2001): Tell lexer not to detect floating-point constants here
      z->lex.setMode(Lexer::kModeDotAddressing);
//
      if (MMpush(m,NIL)) return MERRMEM;
      if (Mpushstring(m,"#tup")) return MERRMEM;
      if (MMpush(m,m->top[m->pp+2])) return MERRMEM;
      if (Mreadtok(z))
        {
          sprintf(z->mess,"expression expected");
          return MERRTYP;
        }
      n=TYPVAR;
      if (z->lex.current().is(Token::kIdent))
        {
          sprintf(buf,"l%s",z->tok);
          i=TPsearchtype(m,m->top[ind+PKGLOC],buf);
          if (i==NIL)
            {
              i=Msearchvar(m,m->top[ind+PKGVAR],z->tok);
              if (i==NIL)
                i=Msearchinpak(m,m->top[ind+PKGLP],z->tok);
              if (i!=NIL)
                n=m->tape[i+SizeHeader+OFFVTYP]>>1;
            }
        }
      if (n==TYPFIELD)
        {
          if (MMpush(m,m->tape[i+SizeHeader+OFFVSTYP])) return MERRMEM;
          if (k=TPtypgraph(m)) return k;
          m->top[m->pp+4]=m->top[m->pp];
          m->pp++;
          if (MMpush(m,(1+SIZETYP)*2)) return MERRMEM;
          if (k=MBdeftab(m)) return k;
          if (k=TPunionfun(m,z)) return k;          
        }
      else
        {
          if (k=TCreadt(m,z,ind)) return k;
          if (MMpush(m,(2+SIZETYP)*2)) return MERRMEM;
          if (k=MBdeftab(m)) return k;
          if (Mpushstring(m,"fun [tab u0 I] u0")) return MERRMEM;
          if (k=TPtypgraph(m)) return k;
          m->top[m->pp+2]=m->top[m->pp];
          m->pp++;
          if (k=TPunionfun(m,z)) return k;
        }
//$ FA(04/05/2001): Switch back to plain mode
        z->lex.setMode(Lexer::kModePlain);
//
    }
}

int TCfindvar(mmachine m,manlyz z,int ind,int *typ)
{
  char buf[MAXSIZETOKEN+1];
  int i,k;

  sprintf(buf,"l%s",z->tok);
  i=TPsearchtype(m,m->top[ind+PKGLOC],buf);
  if (i!=NIL)
    {
      MMpush(m,i);
      if (k=TCvar(m,z,ind)) return k;
      *typ=TYPVAR;
      return 0;
    }

  i=Msearchvar(m,m->top[ind+PKGVAR],z->tok);
  if (i==NIL)
    i=Msearchinpak(m,m->top[ind+PKGLP],z->tok);
  if (i==NIL)
    {
/*      sprintf(z->mess,"'%s' unknown\n",z->tok);*/
      return MERRLINK;    /* linkage impossible */
    }
  *typ=m->tape[i+SizeHeader+OFFVTYP]>>1;
  if (MMpush(m,m->tape[i+SizeHeader+OFFVSTYP])) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if ((*typ)==TYPVAR) return TCvar(m,z,ind);
  return 0;
}

int TCreadset(mmachine m,manlyz z,int ind)
{
  int k,n;

  if (Mpushstring(m,"fun [u0 u0] u0")) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;

  if ((Mreadtok(z))||(!z->lex.current().is(Token::kIdent)))
    {
      sprintf(z->mess,"variable expected");
      return MERRTYP;
    }
  if ((k=TCfindvar(m,z,ind,&n))||(n!=TYPVAR))
    {
      sprintf(z->mess,"variable expected (not function)");
      if (k) return k;
      return MERRTYP;
    }
  if ((Mreadtok(z))||(strcmp(z->tok,"=")))
    {
      sprintf(z->mess,"= expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;
  if (MMpush(m,(2+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;
  if (k=TPunionfun(m,z)) return k;

  return 0;
}

int TCreadif(mmachine m,manlyz z,int ind)
{
  int k;

  if (Mpushstring(m,"fun [I u0 u0] u0")) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;

  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing condition");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture condition */
  if ((Mreadtok(z))||(strcmp(z->tok,"then")))
    {
      sprintf(z->mess,"then expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing True condition");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture True */

  if (Mreadtok(z)) return MERRTYP;
  if (strcmp(z->tok,"else"))
    {
      sprintf(z->mess,"else expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing False condition");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture False */
  if (MMpush(m,(3+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;
  if (k=TPunionfun(m,z)) return k;
  return 0;
}

int TCreadwhile(mmachine m,manlyz z,int ind)
{
  int k;

  if (Mpushstring(m,"fun [I u0] u0")) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;

  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture condition */
  if ((Mreadtok(z))||(strcmp(z->tok,"do")))
    {
      sprintf(z->mess,"do expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture Corps */
  if (MMpush(m,(2+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;
  if (k=TPunionfun(m,z)) return k;

  return 0;
}

int TCletn;

int TCreadlet2(mmachine m,manlyz z,int ind)
{
  int k,n;
  char buf[MAXSIZETOKEN+1];

  if (z->tok[0]=='[')
    {
      if (MMpush(m,NIL)) return MERRMEM;
      if (Mpushstring(m,"#tup")) return MERRMEM;
      n=0;
      while(1)
        {
          if (Mreadtok(z))
            {
              sprintf(z->mess,"missing element");
              return MERRTYP;
            }
          if (z->tok[0]==']')
            {
              if (MMpush(m,(n+SIZETYP)*2)) return MERRMEM;
              if (k=MBdeftab(m)) return k;
              return 0;
            }
          if (!strcmp(z->tok,"_"))
            {
              if (k=TPnil(m)) return k;
            }
          else if (k=TCreadlet2(m,z,ind)) return k;
          n++;
        } 
    }
  if (!z->lex.current().is(Token::kIdent))
    {
      sprintf(z->mess,"element expected");
      return MERRTYP;
    }
  sprintf(buf,"l%s",z->tok);
  if ((k=TPaddlabel(m,ind+PKGLOC,buf))<0) return k;
  if (MMpush(m,k)) return MERRMEM;
  TCletn++;

  return 0;
}

int TCreadlet(mmachine m,manlyz z,int ind)
{
  int k,n;

  if (Mpushstring(m,"fun [u0 u0 u1] u1")) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture expression */

  if ((Mreadtok(z))||(strcmp(z->tok,"->")))
    {
      sprintf(z->mess,"-> expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing element");
      return MERRTYP;
    }
  TCletn=0;
  if (k=TCreadlet2(m,z,ind)) return k;
  n=TCletn;
  if ((Mreadtok(z))||(strcmp(z->tok,"in")))
    {
      sprintf(z->mess,"in expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture expression */

  if (MMpush(m,(3+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;
  if (k=TPunionfun(m,z)) return k;
  TPdelnlabel(m,ind+PKGLOC,n);
  return 0;
}

int TCreadmatch(mmachine m,manlyz z,int ind)
{
  int k,n,nm,i,typ;

  if (MMpush(m,NIL)) return MERRMEM; /* place pour le type de la fonction */

  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture expression */

  if ((Mreadtok(z))||(strcmp(z->tok,"with")))
    {
      sprintf(z->mess,"with expected");
      return MERRTYP;
    }

  nm=0;
  do
    {
      if ((Mreadtok(z))||(strcmp(z->tok,"(")))
        {
          sprintf(z->mess,"( expected");
          return MERRTYP;
        }
      if (Mreadtok(z))
        {
          sprintf(z->mess,"missing constructor");
          return MERRTYP;
        }

      if (!strcmp(z->tok,"_"))
        {
          if (k=TPnil(m)) return k;
          n=-1;
        }
      else
        {
          if ((k=TCfindvar(m,z,ind,&typ))||((typ!=TYPCONS)&&(typ!=TYPCONS0)))
            {
              sprintf(z->mess,"constructor expected");
              return MERRTYP;
            }
          if (MMpush(m,NIL)) return MERRMEM;
          if (Mpushstring(m,"#tup")) return MERRMEM;
          TCletn=0;
          if (typ!=TYPCONS0)
            {
              if (Mreadtok(z))
                {
                  sprintf(z->mess,"missing element");
                  return MERRTYP;
                }
              if (k=TCreadlet2(m,z,ind)) return k;
              n=TCletn;
              if (MMpush(m,(1+SIZETYP)*2)) return MERRMEM;
            }
          else
            {
              if (MMpush(m,SIZETYP*2)) return MERRMEM;
              n=0;
            }
          if (k=MBdeftab(m)) return k;
          if (k=TPunionfun(m,z)) return k;
        }
      if ((Mreadtok(z))||(strcmp(z->tok,"->")))
        {
          sprintf(z->mess,"-> expected");
          return MERRTYP;
        }
      if (Mreadtok(z))
        {
          sprintf(z->mess,"missing expression");
          return MERRTYP;
        }
      if (k=TCreada(m,z,ind)) return k;   /* lecture expression */
      if (n>0) TPdelnlabel(m,ind+PKGLOC,n);
      nm++;
      if ((Mreadtok(z))||(strcmp(z->tok,")")))
        {
          sprintf(z->mess,") expected");
          return MERRTYP;
        }
      if (Mreadtok(z))
        {
          sprintf(z->mess,"; or ;; or | expected");
          return MERRTYP;
        }
      if (strcmp(z->tok,"|")) z->giveback=1;
      else if (n==-1)
        {
          sprintf(z->mess,"unreachable code");
          return MERRTYP;
        }
    }
  while(!strcmp(z->tok,"|"));

  if (MMpush(m,(nm*2+1+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;
  strcpy(MMbuf,"fun[u0");
  for(i=0;i<nm;i++) strcat(MMbuf," u0 u1");
  strcat(MMbuf,"] u1");
  if (Mpushstring(m,MMbuf)) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  m->top[m->pp+2]=m->top[m->pp];
  m->pp++;
  if (k=TPunionfun(m,z)) return k;
  return 0;
}

int TCreadmutate(mmachine m,manlyz z,int ind)
{
  int k,n;

  if (Mpushstring(m,"fun [u0 u0] u0")) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing expression");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture expression */

  if ((Mreadtok(z))||(strcmp(z->tok,"<-")))
    {
      sprintf(z->mess,"<- expected");
      return MERRTYP;
    }
  if ((Mreadtok(z))||(strcmp(z->tok,"[")))
    {
      sprintf(z->mess,"[ expected");
      return MERRTYP;
    }

  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;
  n=0;
  while(1)
    {
      if (Mreadtok(z))
        {
          sprintf(z->mess,"] or element expected");
          return MERRTYP;
        }
      if (z->tok[0]==']')
        {
          if (MMpush(m,(n+SIZETYP)*2)) return MERRMEM;
          if (k=MBdeftab(m)) return k;
          if (MMpush(m,(2+SIZETYP)*2)) return MERRMEM;
          if (k=MBdeftab(m)) return k;
          if (k=TPunionfun(m,z)) return k;
          return 0;
        }
      if (!strcmp(z->tok,"_"))
        {
          if (k=TPnil(m)) return k;
        }
      else if (k=TCreada(m,z,ind)) return k;
      n++;
    }
}

int TCrecurs(mmachine m,manlyz z,int ind)
{
  int i,n,k,f,s,t;

  n=TPnbarg(m,m->top[ind+PKGNOD]);
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;
  for(i=0;i<n;i++)
    {
      if (Mreadtok(z))
        {
          sprintf(z->mess,"expression expected");
          return MERRTYP;
        }
      if (k=TCreada(m,z,ind)) return k;
    }
  if (MMpush(m,(n+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;

  s=MMpull(m);
  f=m->top[ind+PKGNOD]>>1;
  t=m->tape[f+SizeHeader+SIZETYP];
  if (k=TPunif(m,z,s,t)) return k;

  if (MMpush(m,TPsearchtype(m,m->top[ind+PKGLOC],"@"))) return MERRMEM;
  return 0;
}

extern int MGnarg[];
extern char *(MGtype[]);


int TCreaduser(mmachine m, manlyz z, int ind, int n)
{
  int i, k;

  if (n < 0)
  {
    if ((n == TYPCONS) || (n == TYPSTRUC)) n = 1;
    if (n == TYPCONS0) n = 0;
    if (n == TYPCOM) n = 1;
    if (n == TYPCOMV) n = 2;
  }
  
  if (n < 0)
  {
    sprintf(z->mess, "bad term");
    return MERRTYP;
  }
    
  if (MMpush(m, NIL)) return MERRMEM;
  if (Mpushstring(m, "#tup")) return MERRMEM;
  
  for(i = 0; i < n; i++)
  {
    if (Mreadtok(z))
      {
        sprintf(z->mess, "expression expected");
        return MERRTYP;
      }
    if (k = TCreada(m, z, ind)) return k;
  }
  
  if (MMpush(m, (n+SIZETYP)*2)) return MERRMEM;
  if (k = MBdeftab(m)) return k;
  if (k = TPunionfun(m,z)) return k;
  
  return 0;
}


//$ FA(13/04/2001): 'i' is an index into 'specials' table
int TCreadstd(mmachine m,manlyz z,int ind,int i)
{
  int k;

  if (Mpushstring(m,specials[i].type)) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  return TCreaduser(m,z,ind,specials[i].arity);
}
//

int TCreadexec(mmachine m,manlyz z,int ind)
{
  int k;

  if (Mpushstring(m,"fun [fun u0 u1 u0] u1")) return MERRMEM;
  if (k=TPtypgraph(m)) return k;
  if (MMpush(m,NIL)) return MERRMEM;
  if (Mpushstring(m,"#tup")) return MERRMEM;

  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing function");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture fonction */
  if ((Mreadtok(z))||(strcmp(z->tok,"with")))
    {
      sprintf(z->mess,"with expected");
      return MERRTYP;
    }
  if (Mreadtok(z))
    {
      sprintf(z->mess,"missing arguments");
      return MERRTYP;
    }
  if (k=TCreada(m,z,ind)) return k;   /* lecture arguments */

  if (MMpush(m,(2+SIZETYP)*2)) return MERRMEM;
  if (k=MBdeftab(m)) return k;
  if (k=TPunionfun(m,z)) return k;
  return 0;
}

int TCreadlab(mmachine m, manlyz z, int ind)
{
  int i,k,n;
  char *c;

  if (!strcmp(z->tok,"set")) return TCreadset(m,z,ind);
  if (!strcmp(z->tok,"if")) return TCreadif(m,z,ind);
  if (!strcmp(z->tok,"while")) return TCreadwhile(m,z,ind);
  if (!strcmp(z->tok,"let")) return TCreadlet(m,z,ind);
  if (!strcmp(z->tok,"match")) return TCreadmatch(m,z,ind);
  if (!strcmp(z->tok,"mutate")) return TCreadmutate(m,z,ind);
  if (!strcmp(z->tok,"exec")) return TCreadexec(m,z,ind);

/*  if ((i=Mismagstd(z->tok))!=-1) return TCreadstd(m,z,ind,i);*/

  c=(char*)&m->tape[(m->top[ind+PKGNAM]>>1)+SizeHeader];
  if (!strcmp(c,z->tok)) return TCrecurs(m,z,ind);

  if (k=TCfindvar(m,z,ind,&n))
  {
	  if (k!=MERRLINK) return k;
	  if ((i=Mismagstd(z->tok))!=-1) return TCreadstd(m,z,ind,i);
	  sprintf(z->mess,"'%s' unknown\n",z->tok);
	  return k;
  }

  if (n==TYPVAR) return 0;
  return TCreaduser(m,z,ind,n);
}