/*     
      PACKAGE LOADER . Magma 1.0 . 1996 . Sylvain HUET

         loadpak.cpp : routine de chargement de package
*/
// Modification history:
//
//$ FA(13/04/2001): Introduce PKhardpak2 function for loading packages using
//                  new interface
//$ FA(03/05/2001): Promote to C++ file
//$ FA(03/05/2001): Use new lexer interface (lexer.h)
//$ FA(19/06/2001): Debugger integration: add support for package id and size
//$ FA(22/06/2001): Debugger integration: add support for function trace
//$ FA(26/06/2001): Debugger integration: add link to function definition in PB
//$ FA(17/07/2001): Replace MAXSIZETOKEN by MAXSIZETOKEN+1 in buffer definitions
//$ FA(31/08/2001): Debugger integration: add support for source position (BPTs)
//$ FA(07/09/2001): Allocate in PKloader() Manlyz instance and buffers in the heap
//$ FA(12/11/2001): Runtime information for VARs and packages is include
//    if RELEASE_DEVELOPER is defined
//

#include <stdio.h>
#include <string.h>
#include "debug.h"
#include "loadpak.h"
#include "lexer.h"
#include "macros.h"
extern "C" {
#include "mmemory.h"
#include "mbytec.h"
#include "listlab.h"
#include "typmisc.h"
}
/*  verification de type d'un fichier .pkg */
int TCtypecheck(mmachine m, manlyz z, int ind);

/* seconde passe : lit le package et fait le linkage */
int PKcompile(mmachine m, manlyz z, int ind);

/* routine ajoutant un package a une liste de packages
  en 1: liste ancienne
  en 0: nouveau package
 retourne en 0: nouvelle liste
*/
int PKaddpak(mmachine m)
{
  int s;

  s=MMmalloc(m,SIZELIST,TYPETAB); if (s==NIL) return MERRMEM;
  m->tape[s+SizeHeader+OFFLVAL]=m->top[m->pp];
//$ FA(29/11/2000): Notify debugger that a new package has been loaded
#if defined(INCLUDE_DEBUGGER)
  SECHECK(SEDUP(m));
  int res;
  if (res = DBGNotifyPackageLoaded(m))
    return res;
#endif
//
  m->tape[s+SizeHeader+OFFLNEXT]=m->top[m->pp+1];
  m->pp++;
  m->top[m->pp]=s+s+1;

  return 0;
}


int PKtestproto(mmachine m,manlyz z,int i)
{
  while(i!=NIL)
    {
      i>>=1;
	  MMechostr(MSKDEBUG,"obj %s %d\n",
		  (char*)&m->tape[(m->tape[i+SizeHeader+OFFVNAME]>>1)+SizeHeader],
		m->tape[i+SizeHeader+OFFVVAL]);
/*
          (m->tape[i+SizeHeader+OFFVTYP]>=0))
        {
          sprintf(z->mess,"'%s' : prototype not defined",
                  (char*)&m->tape[(m->tape[i+SizeHeader+OFFVNAME]>>1)
                                 +SizeHeader]);
          return MERRTYP;
        }*/
      i=m->tape[i+SizeHeader+OFFVNEXT];
    }
  return 0;
}


//$ FA(08/11/2000)
static void PKLinkToPackage(mmachine m, SEWORD first, SEWORD pkg)
{
  //MMechostr(MSKTRACE, "PKLinkToPackage: Patch to '%s'\n", SECSTR(m, SEW2P(SEFETCH(m, SEW2P(pkg), OFFPKNAME))));
  SEPTR p;
  for (SEWORD l = first; l != NIL; l = SEFETCH(m, p, OFFVNEXT)) {
    p = SEW2P(l);
	  //MMechostr(MSKTRACE, "PKLinkToPackage: Patching '%s'\n", SECSTR(m, SEW2P(SEFETCH(m, p, OFFVNAME))));
    SESTORE(m, p, OFFVPKG, pkg);
  } // for
}


int PKloader2(mmachine m,manlyz z,char *name)
{
  int ind,i,l,s;

  ind=m->pp+1;
  if (MMpush(m,NIL)) return MERRMEM;
  if (MMpush(m,NIL)) return MERRMEM;
  if (MMpush(m,NIL)) return MERRMEM;
//$ FA(24/11/2000): Push empty BPT
#if defined(RELEASE_DEVELOPER)
  if (MMpush(m,NIL)) return MERRMEM;
#endif
//

  MMechostr(MSKTRACE,"typechecking\n");

  if (i=TCtypecheck(m,z,ind)) return i;
  Mreinitpack(z);

  if (i=PKcompile(m,z,ind)) return i;  /* lecture fine */

//$ FA(24/11/2000): Take into account BPT when restoring stack
#if defined(RELEASE_DEVELOPER)
  m->pp += 3;
#else
  m->pp += 2;
#endif
//
  if (l=Mpushstring(m,name)) return l;

  s=MMmalloc(m,SIZEPAK,TYPETAB); if (s==NIL) return MERRMEM;
  m->tape[s+SizeHeader+OFFPKNAME]=m->top[m->pp];
  m->tape[s+SizeHeader+OFFPKINTRN]=m->top[ind+PKGVAR];
//$ FA(08/11/2000): Add package reference to identifiers
#if defined(RELEASE_DEVELOPER)
  PKLinkToPackage(m, SEGET(m, ind+PKGVAR), SEP2W(s));
#endif
//
  m->tape[s+SizeHeader+OFFPKTYP]=0;
#if defined(RELEASE_DEVELOPER)
//$ FA(29/11/2000): Assign unique id to package
  m->tape[s+SizeHeader+OFFPKID]   = SEI2W(pkgID++);
//$ FA(19/06/2001): Set size to nil (not available for native packages)
  m->tape[s+SizeHeader+OFFPKSIZE] = NIL;
//
#endif
  m->top[ind+PKGVAR]=s+s+1;
  m->pp++;
  return PKaddpak(m);
}

/* lecture et linkage d'un package
  en 0: liste des packages deja charges
 retourne en 0: nouvelle liste
*/ 
int PKloader(mmachine m,char *name,char *simplename)
{
  manlyz z;
  int    i;
  int    p;
  char*  bufname;
  char*  simple;
  int    res = MERROK;

  if ((z = new Manlyz) == 0) {
    return MERRMEM;
    goto cleanUp;
  }
  if ((bufname = new char[MAXSIZETOKEN+1]) == 0) {
    res = MERRMEM;
    goto cleanUp;
  }
  if ((simple = new char[MAXSIZETOKEN+1]) == 0) {
    res = MERRMEM;
    goto cleanUp;
  }
  strcpy(bufname, name);
  strcpy(simple, simplename);
  p = m->pp;
  MMechostr(MSKTRACE, "\nloading %s ...\n",bufname);
  if (Mopenpack(z, bufname))
    {
      MMechostr(0, "%s : introuvable\n",bufname);
      res = MERRNF;
      goto cleanUp;
    }
  z->mess[0] = '\0';
  i = PKloader2(m, z, simple);
  if (i)
    {
	  MMechostr(MSKRUNTIME,"file : %s\n",bufname);
      Maffligne(z);
      Mprinterror(i);
      MMechostr(MSKRUNTIME,"%s\n", z->mess);
      m->pp = p;
      Mclosepack(z);
      res = i;
      goto cleanUp;
    }
  Mclosepack(z);
  MMechostr(MSKTRACE,"loading complete\n");
cleanUp:
  if (z)
    delete z;
  if (bufname)
    delete [] bufname;
  if (simple)
    delete [] simple;
  return res;
}

/* lecture d'un package en dur
  en 0: liste des packages deja charges
 retourne en 0: nouvelle liste
*/
extern "C" {
int indexHard;
}

int PKhardpak(mmachine m, char *name,
              int n, char **namefun, int (**fun)(mmachine z)
              , int *nargfun, char **typfun)
{
  int i,k,l,s,typ,val;

  if (MMpush(m,NIL)) return MERRMEM;
//  MMechostr(MSKDEBUG,"hard loading %s\n",name);
  for(i=0;i<n;i++)
    {
/*	  if (namefun[i]) MMechostr(MSKDEBUG,"> %d %s\n",i,namefun[i]);
	  else MMechostr(MSKDEBUG,"> %d NULL\n",i);
*/
      typ=nargfun[i];
      if (l=Maddvar(m,m->pp,namefun[i],0)) return l;

      if (typ>=0)
        {
          if (fun[i]!=NULL)
            {
              s=MMmalloc(m,16,TYPEBUF); if (s==NIL) return MERRMEM;
              m->tape[s+SizeHeader]=(int) fun[i];
              if (MMpush(m,s+s+1)) return MERRMEM;
              
              s=MMmalloc(m,SIZEPROG,TYPETAB); if (s==NIL) return MERRMEM;
              m->tape[s+SizeHeader+OFFPARG] = typ*2;
              m->tape[s+SizeHeader+OFFPLOC] = NIL;
              m->tape[s+SizeHeader+OFFPBCD] = m->top[m->pp];
              m->tape[s+SizeHeader+OFFPREF] = (indexHard++)<<1;
              m->tape[s+SizeHeader+OFFPOPT] = NIL;
#if defined(RELEASE_DEVELOPER)
//$ FA(07/11/2000)
              m->tape[s+SizeHeader+OFFPVAR] = NIL;
//$ FA(18/11/2000)
              m->tape[s+SizeHeader+OFFPDBG] = 0;    // unset by default (no trace)
//$ FA(23/11/2000)
              m->tape[s+SizeHeader+OFFPBPT] = NIL;  // no BPT for hardcoded functions
//
#endif
              m->top[m->pp]=s+s+1;
            }
          else if (MMpush(m,NIL)) return MERRMEM;
        }
      else
        {
          if ((typ==TYPCONS)||(typ==TYPCONS0)||(typ==TYPFIELD)||(typ==TYPVAR))
			  val=(int)fun[i];
          else val=NIL;

          if (MMpush(m,val)) return MERRMEM;
        }

      if (typfun[i])
        {
          if (k=Mpushstring(m,typfun[i])) return MERRMEM;
          if (k=TPtypgraph(m)) return k;
	      if (k=TPsolvenode(m)) return k;
        }
      else if (MMpush(m,NIL)) return MERRMEM;
     
      k=Msearchvar(m,m->top[m->pp+2],namefun[i]);
      if (k==NIL) return MERRTYP;
      m->tape[k+SizeHeader+OFFVVAL]=m->top[m->pp+1];
#if defined(RELEASE_DEVELOPER)
//$ FA(22/11/2000): Add reference to function identifier into PB
	  if (typ >= 0 && SEGETTOP(m, 1) != NIL) // function
      SESTORE(m, SEW2P(SEGETTOP(m, 1)), OFFPVAR, SEP2W(k));
//
#endif
      m->tape[k+SizeHeader+OFFVSTYP]=m->top[m->pp];
      m->tape[k+SizeHeader+OFFVTYP]=typ*2;
      m->pp+=2;
    }
  if (l=Mpushstring(m,name)) return l;
  s=MMmalloc(m,SIZEPAK,TYPETAB); if (s==NIL) return MERRMEM;
  m->tape[s+SizeHeader+OFFPKNAME]=m->top[m->pp];
  m->tape[s+SizeHeader+OFFPKINTRN]=m->top[m->pp+1];
//$ FA(22/11/2000): Add package reference to identifiers
#if defined(RELEASE_DEVELOPER)
  PKLinkToPackage(m, SEGETTOP(m, 1), SEP2W(s));
#endif
//
  m->tape[s+SizeHeader+OFFPKTYP]=0;
#if defined(RELEASE_DEVELOPER)
//$ FA(29/11/2000): Assign unique id to package
  m->tape[s+SizeHeader+OFFPKID]   = SEI2W(pkgID++);
//$ FA(19/06/2001): Set size to nil (not available for native packages)
  m->tape[s+SizeHeader+OFFPKSIZE] = NIL;
//
#endif
  m->pp++;
  m->top[m->pp]=s+s+1;

  return PKaddpak(m);
}


//$ FA(13/04/2001): New syntax for hard-loading packages
int PKhardpak2(mmachine m, char *name, int ndefs, NativeDefinition defs[])
{
  int i,k,l,s,typ,val;

  if (MMpush(m,NIL)) return MERRMEM;

  for(i=0;i<ndefs;i++)
    {
      typ=defs[i].arity;
      if (l=Maddvar(m,m->pp,defs[i].name,0)) return l;

      if (typ>=0)
        {
          if (defs[i].function!=NULL)
            {
              s=MMmalloc(m,16,TYPEBUF); if (s==NIL) return MERRMEM;
              m->tape[s+SizeHeader]=(int)defs[i].function;
              if (MMpush(m,s+s+1)) return MERRMEM;
              
              s=MMmalloc(m,SIZEPROG,TYPETAB); if (s==NIL) return MERRMEM;
              m->tape[s+SizeHeader+OFFPARG] = typ*2;
              m->tape[s+SizeHeader+OFFPLOC] = NIL;
              m->tape[s+SizeHeader+OFFPBCD] = m->top[m->pp];
              m->tape[s+SizeHeader+OFFPREF] = (indexHard++)<<1;
              m->tape[s+SizeHeader+OFFPOPT] = NIL;
#if defined(RELEASE_DEVELOPER)
//$ FA(07/11/2000)
              m->tape[s+SizeHeader+OFFPVAR] = NIL;
//$ FA(18/11/2000)
              m->tape[s+SizeHeader+OFFPDBG] = 0;    // unset by default (no trace)
//$ FA(23/11/2000)
              m->tape[s+SizeHeader+OFFPBPT] = NIL;  // no BPT for hardcoded functions
//
#endif
              m->top[m->pp]=s+s+1;
            }
          else if (MMpush(m,NIL)) return MERRMEM;
        }
      else
        {
          if ((typ==TYPCONS)||(typ==TYPCONS0)||(typ==TYPFIELD)||(typ==TYPVAR))
			  val=(int)defs[i].function;
          else val=NIL;

          if (MMpush(m,val)) return MERRMEM;
        }

      if (defs[i].type)
        {
          if (k=Mpushstring(m,defs[i].type)) return MERRMEM;
          if (k=TPtypgraph(m)) return k;
	      if (k=TPsolvenode(m)) return k;
        }
      else if (MMpush(m,NIL)) return MERRMEM;
     
      k=Msearchvar(m,m->top[m->pp+2],defs[i].name);
      if (k==NIL) return MERRTYP;
      m->tape[k+SizeHeader+OFFVVAL]=m->top[m->pp+1];
#if defined(RELEASE_DEVELOPER)
//$ FA(22/11/2000): Add reference to function identifier into PB
	    if (typ >= 0 && SEGETTOP(m, 1) != NIL) // function
        SESTORE(m, SEW2P(SEGETTOP(m, 1)), OFFPVAR, SEP2W(k));
//
#endif
      m->tape[k+SizeHeader+OFFVSTYP]=m->top[m->pp];
      m->tape[k+SizeHeader+OFFVTYP]=typ*2;
      m->pp+=2;
    }
  if (l=Mpushstring(m,name)) return l;
  s=MMmalloc(m,SIZEPAK,TYPETAB); if (s==NIL) return MERRMEM;
  m->tape[s+SizeHeader+OFFPKNAME]=m->top[m->pp];
  m->tape[s+SizeHeader+OFFPKINTRN]=m->top[m->pp+1];
//$ FA(22/11/2000): Add package reference to identifiers
#if defined(RELEASE_DEVELOPER)
  PKLinkToPackage(m, SEGETTOP(m, 1), SEP2W(s));
#endif
//
  m->tape[s+SizeHeader+OFFPKTYP]=0;
#if defined(RELEASE_DEVELOPER)
//$ FA(10/06/2001): Assign unique id to package
  m->tape[s+SizeHeader+OFFPKID]   = SEI2W(pkgID++);
//$ FA(19/06/2001): Set size to nil (not available for native packages)
  m->tape[s+SizeHeader+OFFPKSIZE] = NIL;
//
#endif
  m->pp++;
  m->top[m->pp]=s+s+1;

  return PKaddpak(m);
}