/* -*- mode: C; mode: fold; -*- */

/*
  Copyright (c) 2003 Massachusetts Institute of Technology

  This software was developed by the MIT Center for Space Research
  under contract SV1-61010 from the Smithsonian Institution.
  
  Permission to use, copy, modify, distribute, and sell this software
  and its documentation for any purpose is hereby granted without fee,
  provided that the above copyright notice appear in all copies and
  that both that copyright notice and this permission notice appear in
  the supporting documentation, and that the name of the Massachusetts
  Institute of Technology not be used in advertising or publicity
  pertaining to distribution of the software without specific, written
  prior permission.  The Massachusetts Institute of Technology makes
  no representations about the suitability of this software for any
  purpose.  It is provided "as is" without express or implied warranty.
  
  THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY DISCLAIMS ALL WARRANTIES
  WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  MERCHANTABILITY AND FITNESS.  IN NO EVENT SHALL THE MASSACHUSETTS
  INSTITUTE OF TECHNOLOGY BE LIABLE FOR ANY SPECIAL, INDIRECT OR
  CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
  OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/

/* Author: John E. Davis (davis@space.mit.edu) */

#include "config.h"
#include <stdio.h>
#include <signal.h>
#include <string.h>
#include <stdlib.h>

#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif

#include <slang.h>
#include <pvm3.h>

#ifdef __cplusplus
extern "C"
{
#endif
SLANG_MODULE(pvm);
#ifdef __cplusplus
}
#endif

#include "version.h"

static int throw_pvm_exception (int err)
{
   if (err < 0)
     SLang_verror (SL_INTRINSIC_ERROR, "pvm_error: %d", err);
   return err;
}

static int pop_2_ints (int *a, int *b)
{
   if ((-1 == SLang_pop_integer (b))
       || (-1 == SLang_pop_integer (a)))
     return -1;

   return 0;
}

static SLang_Array_Type *create_int_array (int n)
{
   return SLang_create_array (SLANG_INT_TYPE, 0, NULL, &n, 1);
}

static SLang_Array_Type *create_string_array (int n)
{
   return SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &n, 1);
}

static void datatype_intrinsic (int *class_id)
{
   SLtype id = (SLtype) *class_id;

   if (0 == SLclass_is_class_defined (id))
     {
        SLang_verror (SL_INVALID_PARM,
                      "Invalid data type id (%d)", id);
        return;
     }
   (void) SLclass_push_int_obj (SLANG_DATATYPE_TYPE, id);
}

#if 0
static int map_pvm_to_slang (int slang_data_type)
{
   switch (slang_data_type)
     {
      case SLANG_STRING_TYPE: return PVM_STR;
      case SLANG_UCHAR_TYPE: case SLANG_CHAR_TYPE: return PVM_BYTE;
      case SLANG_SHORT_TYPE: return PVM_SHORT;
      case SLANG_INT_TYPE: return PVM_INT;
      case SLANG_FLOAT_TYPE: return PVM_FLOAT;
      case SLANG_DOUBLE_TYPE: return PVM_DOUBLE;
      case SLANG_COMPLEX_TYPE: return PVM_DCPLX;
      case SLANG_LONG_TYPE: return PVM_LONG;
      case SLANG_USHORT_TYPE: return PVM_USHORT;
      case SLANG_UINT_TYPE: return PVM_UINT;
      case SLANG_ULONG_TYPE: return PVM_ULONG;
     }

   SLang_verror (SL_NOT_IMPLEMENTED, "Unsupported type %s",
                 SLclass_get_datatype_name (slang_data_type));
   return -1;
}
#endif

/* Define intrinsics here */
static void _pvm_spawn (int *flag, char *where, int *ntasks)
{
   SLang_Array_Type *at_argv;
   SLang_Array_Type *at_tids;
   char **argv;
   char *task;
   unsigned int argc;
   unsigned int i;
   char **argv_data;
   int *tids;

   if (*ntasks < 1)
     {
        SLang_verror (SL_INVALID_PARM, "pvm_spawn: ntasks must be > 0");
        return;
     }

   if (-1 == SLang_pop_array_of_type (&at_argv, SLANG_STRING_TYPE))
     return;

   argc = at_argv->num_elements;
   if (argc == 0)
     {
        SLang_verror (SL_INVALID_PARM, "pvm_spawn: argv has no elements");
        SLang_free_array (at_argv);
        return;
     }
   if (NULL == (argv = (char **)SLmalloc ((argc+1) * sizeof (char *))))
     {
        SLang_free_array (at_argv);
        return;
     }

   if (NULL == (at_tids = create_int_array (*ntasks)))
     {
        SLang_free_array (at_argv);
        SLfree ((char *)argv);
        return;
     }
   argv_data = (char **) at_argv->data;
   task = argv_data[0];
   for (i = 1; i < argc; i++)
     {
        if (argv_data[i] == NULL)
          break;
        argv [i-1] = argv_data[i];
     }
   argv[i-1] = NULL;

   tids = (int *)at_tids->data;
   (void) pvm_spawn (task, argv, *flag, where, *ntasks, tids);

   SLang_free_array (at_argv);
   SLfree ((char *)argv);

   if (*ntasks == 1)
     SLang_push_integer (*tids);
   else
     SLang_push_array (at_tids, 0);

   SLang_free_array (at_tids);
}

static int _pvm_mytid (void)
{
   return pvm_mytid ();
}

static int _pvm_parent (void)
{
   return pvm_parent ();
}

static void _pvm_exit (void)
{
   if (0 != pvm_exit ())
     SLang_vmessage ("pvm_exit failed\n");
}

static int _pvm_initsend (int *encoding)
{
   int bufid;

   bufid = pvm_initsend (*encoding);
   return bufid;
}

static void _pvm_pack (void)
{
   unsigned int nargs;

   nargs = (unsigned int) SLang_Num_Function_Args;
   if (-1 == SLreverse_stack ((int) nargs))
     return;

   while (nargs)
     {
        SLang_Array_Type *at;
        int info;
        VOID_STAR data;
        unsigned int num_elements;

        nargs--;
        if (-1 == SLang_pop_array (&at, 1))
          return;

        data = at->data;
        num_elements = at->num_elements;

        switch (at->data_type)
          {
           case SLANG_CHAR_TYPE:
           case SLANG_UCHAR_TYPE:
             info = pvm_pkbyte ((char*)data, num_elements, 1);
             break;
           case SLANG_SHORT_TYPE:
             info = pvm_pkshort ((short*)data, num_elements, 1);
             break;
           case SLANG_USHORT_TYPE:
             info = pvm_pkushort ((unsigned short*)data, num_elements, 1);
             break;
           case SLANG_INT_TYPE:
             info = pvm_pkint ((int*)data, num_elements, 1);
             break;
           case SLANG_UINT_TYPE:
             info = pvm_pkuint ((unsigned int*)data, num_elements, 1);
             break;
           case SLANG_LONG_TYPE:
             info = pvm_pklong ((long*)data, num_elements, 1);
             break;
           case SLANG_ULONG_TYPE:
             info = pvm_pkulong ((unsigned long*)data, num_elements, 1);
             break;
           case SLANG_FLOAT_TYPE:
             info = pvm_pkfloat ((float*)data, num_elements, 1);
             break;
           case SLANG_DOUBLE_TYPE:
             info = pvm_pkdouble ((double *)data, num_elements, 1);
             break;
           case SLANG_COMPLEX_TYPE:
             info = pvm_pkdcplx ((double *)data, num_elements, 1);
             break;

           case SLANG_STRING_TYPE:
             if (num_elements)
               info = pvm_pkstr (*(char **)data);
             else
               info = 0;
             break;

           default:
             SLang_verror (SL_INTRINSIC_ERROR, "pvm_pack: %s not supported",
                           SLclass_get_datatype_name (at->data_type));
             info = -1;
          }
        SLang_free_array (at);

        if (info < 0)
          {
             (void) throw_pvm_exception (info);
             return;
          }
     }
}

static int _pvm_unpack_internal (SLtype data_type, VOID_STAR data,
                                  unsigned int num_elements)
{
   int info;

   switch (data_type)
     {
      case SLANG_CHAR_TYPE:
      case SLANG_UCHAR_TYPE:
        info = pvm_upkbyte ((char*)data, num_elements, 1);
        break;
      case SLANG_SHORT_TYPE:
        info = pvm_upkshort ((short*)data, num_elements, 1);
        break;
      case SLANG_USHORT_TYPE:
        info = pvm_upkushort ((unsigned short*)data, num_elements, 1);
        break;
      case SLANG_INT_TYPE:
        info = pvm_upkint ((int*)data, num_elements, 1);
        break;
      case SLANG_UINT_TYPE:
        info = pvm_upkuint ((unsigned int*)data, num_elements, 1);
        break;
      case SLANG_LONG_TYPE:
        info = pvm_upklong ((long*)data, num_elements, 1);
        break;
      case SLANG_ULONG_TYPE:
        info = pvm_upkulong ((unsigned long*)data, num_elements, 1);
        break;
      case SLANG_FLOAT_TYPE:
        info = pvm_upkfloat ((float*)data, num_elements, 1);
        break;
      case SLANG_DOUBLE_TYPE:
        info = pvm_upkdouble ((double *)data, num_elements, 1);
        break;
      case SLANG_COMPLEX_TYPE:
        info = pvm_upkdcplx ((double *)data, num_elements, 1);
        break;

      case SLANG_STRING_TYPE:
          {
             int nbytes, msgtag, tid;
             char *buf;

             info = pvm_bufinfo (pvm_getrbuf(), &nbytes, &msgtag, &tid);
             if (info < 0)
               {
                  throw_pvm_exception (info);
                  return -1;
               }

             if (NULL == (buf = SLmalloc (nbytes + 1)))
               return -1;

             info = pvm_upkstr (buf);
             if (info < 0)
               {
                  throw_pvm_exception (info);
                  SLfree (buf);
                  return -1;
               }
             if (NULL == (*(char **)data = SLang_create_slstring (buf)))
               {
                  SLfree (buf);
                  return -1;
               }
             SLfree (buf);
          }
        break;

      default:
        SLang_verror (SL_INTRINSIC_ERROR, "pvm_pack: %s not supported",
                      SLclass_get_datatype_name (data_type));
        info = -1;
     }
   if (info < 0)
     {
        (void) throw_pvm_exception (info);
        return -1;
     }
   return 0;
}

static void _pvm_unpack (void)
{
   int num_elements = 1;
   SLtype type;
   int need_array = 0;
   SLang_Array_Type *at;

   if (SLang_Num_Function_Args == 2)
     {
        need_array = 1;

        if (-1 == SLang_pop_integer (&num_elements))
          return;
        if (num_elements < 0)
          {
             SLang_verror (SL_INVALID_PARM, "pvm_unpack: num-elements should >0");
             return;
          }
     }
   if (-1 == SLang_pop_datatype (&type))
     return;

   if (NULL == (at = SLang_create_array (type, 0, NULL, &num_elements, 1)))
     return;

   if (-1 == _pvm_unpack_internal (type, at->data, num_elements))
     {
        SLang_free_array (at);
        return;
     }

   if (need_array)
     (void) SLang_push_array (at, 0);
   else
     (void) SLang_push_value (type, at->data);
   SLang_free_array (at);
}

static int _pvm_recv (int *tid, int *msgtag)
{
   return throw_pvm_exception (pvm_recv (*tid, *msgtag));
}

static void _pvm_send (int *tid, int *msgtag)
{
   (void) throw_pvm_exception (pvm_send (*tid, *msgtag));
}

static void _pvm_notify (void)
{
   int what, msgtag, info;

   if (-1 == SLreverse_stack (SLang_Num_Function_Args))
     return;

   /* stack: tids, msgtag, what */
   if (-1 == pop_2_ints (&msgtag, &what))
     return;

   if ((what == PvmTaskExit) || (what == PvmHostDelete))
     {
        SLang_Array_Type *at;
        if (-1 == SLang_pop_array_of_type (&at, SLANG_INT_TYPE))
          return;

        info = pvm_notify (what, msgtag, at->num_elements, (int *)at->data);
        SLang_free_array (at);
     }
   else if (what == PvmHostAdd)
     {
        int cnt;

        if (-1 == SLang_pop_integer (&cnt))
          return;

        info = pvm_notify (what, msgtag, cnt, NULL);
     }
   else
     {
        SLang_verror (SL_INVALID_PARM, "pvm_notify: event to trigger parameter is invalid");
        return;
     }

   (void) throw_pvm_exception (info);
}

static void _pvm_bufinfo (int *bufid)
{
   int bytes, tid, msgtag, info;

   info = pvm_bufinfo (*bufid, &bytes, &msgtag, &tid);
   if (info < 0)
     {
        throw_pvm_exception (info);
        return;
     }
   (void) SLang_push_integer (bytes);
   (void) SLang_push_integer (msgtag);
   (void) SLang_push_integer (tid);
}

static int _pvm_probe (int *tid, int *msgtag)
{
   return throw_pvm_exception (pvm_probe (*tid, *msgtag));
}

static int _pvm_archcode (char *arch)
{
   return throw_pvm_exception (pvm_archcode (arch));
}

static int _pvm_addhost (char *host)
{
   int info;
   return pvm_addhosts (&host, 1, &info);
}

static void _pvm_delhost (char *host)
{
   int info;
   throw_pvm_exception (pvm_delhosts (&host, 1, &info));
}

static void _pvm_export (char *name)
{
   (void) pvm_export (name);
}

static void _pvm_freebuf (int *bufid)
{
   (void) throw_pvm_exception (pvm_freebuf (*bufid));
}

static void _pvm_freecontext (int *ctx)
{
   (void) throw_pvm_exception (pvm_freecontext (*ctx));
}
static int _pvm_getcontext (void)
{
   return throw_pvm_exception (pvm_getcontext ());
}

static int _pvm_newcontext (void)
{
   return throw_pvm_exception (pvm_newcontext ());
}
static int _pvm_setcontext (int *ctx)
{
   return throw_pvm_exception (pvm_setcontext (*ctx));
}

static int _pvm_getopt (int *what)
{
   return throw_pvm_exception (pvm_getopt (*what));
}

static int _pvm_nrecv (int *tid, int *msgtag)
{
   return throw_pvm_exception (pvm_nrecv (*tid, *msgtag));
}

static void _pvm_sendsig (int *tid, int *sig)
{
   (void) throw_pvm_exception (pvm_sendsig (*tid, *sig));
}
static int _pvm_tidtohost (int *tid)
{
   return throw_pvm_exception (pvm_tidtohost (*tid));
}
static int _pvm_setopt (int *opt, int *val)
{
   return throw_pvm_exception (pvm_setopt (*opt, *val));
}

typedef struct
{
   int narch;
   SLang_Array_Type *hi_tid;
   SLang_Array_Type *hi_name;
   SLang_Array_Type *hi_arch;
   SLang_Array_Type *hi_speed;
   SLang_Array_Type *hi_dsig;
}
Host_Config_Type;

static SLang_CStruct_Field_Type Config_Struct [] =
{
   MAKE_CSTRUCT_FIELD(Host_Config_Type, narch, "narch", SLANG_INT_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Host_Config_Type, hi_tid, "hi_tid", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Host_Config_Type, hi_name, "hi_name", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Host_Config_Type, hi_arch, "hi_arch", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Host_Config_Type, hi_speed, "hi_speed", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Host_Config_Type, hi_dsig, "hi_dsig", SLANG_ARRAY_TYPE, 0),
   SLANG_END_CSTRUCT_TABLE
};

static void _pvm_config (void)
{
   int nhost, narch;
   struct pvmhostinfo *hostp;
   Host_Config_Type h;
   int i;

   if (throw_pvm_exception (pvm_config (&nhost, &narch, &hostp)) < 0)
     return;

   memset ((char *) &h, sizeof(h), 0);

   h.narch = narch;
   if ((NULL == (h.hi_tid = create_int_array (nhost)))
       || (NULL == (h.hi_name = create_string_array (nhost)))
       || (NULL == (h.hi_arch = create_string_array (nhost)))
       || (NULL == (h.hi_speed = create_int_array (nhost)))
       || (NULL == (h.hi_dsig = create_int_array (nhost))))
     goto free_return;

   /* Ok for the slang errors to occur below --- no need to check failures */
   for (i = 0; i < nhost; i++)
     {
        ((int *)(h.hi_tid->data))[i] = hostp[i].hi_tid;
        ((char **)(h.hi_name->data))[i] = SLang_create_slstring (hostp[i].hi_name);
        ((char **)(h.hi_arch->data))[i] = SLang_create_slstring (hostp[i].hi_arch);
        ((int *)(h.hi_speed->data))[i] = hostp[i].hi_speed;
        ((int *)(h.hi_dsig->data))[i] = hostp[i].hi_dsig;
     }
   (void) SLang_push_cstruct ((VOID_STAR) &h, Config_Struct);

   free_return:
   SLang_free_array (h.hi_tid);
   SLang_free_array (h.hi_name);
   SLang_free_array (h.hi_arch);
   SLang_free_array (h.hi_speed);
   SLang_free_array (h.hi_dsig);
}

static int _pvm_getrbuf (void)
{
   return throw_pvm_exception (pvm_getrbuf ());
}
static int _pvm_getsbuf (void)
{
   return throw_pvm_exception (pvm_getsbuf ());
}
static void _pvm_halt (void)
{
   (void) throw_pvm_exception (pvm_halt ());
}

static void _pvm_kill (int *tid)
{
   (void) throw_pvm_exception (pvm_kill (*tid));
}
static int _pvm_mstat (char *host)
{
   return pvm_mstat (host);
}
static int _pvm_pstat (int *tid)
{
   return pvm_pstat (*tid);
}
typedef struct
{
   SLang_Array_Type *ti_tid;
   SLang_Array_Type *ti_ptid;
   SLang_Array_Type *ti_host;
   SLang_Array_Type *ti_flag;
   SLang_Array_Type *ti_a_out;
}
Task_Info_Type;

static SLang_CStruct_Field_Type TaskInfo_Struct [] =
{
   MAKE_CSTRUCT_FIELD(Task_Info_Type, ti_tid, "ti_tid", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Task_Info_Type, ti_ptid, "ti_ptid", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Task_Info_Type, ti_host, "ti_host", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Task_Info_Type, ti_flag, "ti_flag", SLANG_ARRAY_TYPE, 0),
   MAKE_CSTRUCT_FIELD(Task_Info_Type, ti_a_out, "ti_a_out", SLANG_ARRAY_TYPE, 0),
   SLANG_END_CSTRUCT_TABLE
};

static void _pvm_tasks (int *where)
{
   int ntask;
   struct pvmtaskinfo *taskinfo;
   Task_Info_Type t;
   int i, status;

   status = pvm_tasks (*where, &ntask, &taskinfo);
   if (status == PvmNoHost)
     {
        SLang_push_null ();
        return;
     }

   throw_pvm_exception (status);

   memset ((char *) &t, sizeof(t), 0);

   if ((NULL == (t.ti_tid = create_int_array (ntask)))
       || (NULL == (t.ti_ptid = create_int_array (ntask)))
       || (NULL == (t.ti_host = create_int_array (ntask)))
       || (NULL == (t.ti_flag = create_int_array (ntask)))
       || (NULL == (t.ti_a_out = create_string_array (ntask))))
     goto free_return;

   /* Ok for the slang errors to occur below --- no need to check failures */
   for (i = 0; i < ntask; i++)
     {
        ((int *)(t.ti_tid->data))[i] = taskinfo[i].ti_tid;
        ((int *)(t.ti_ptid->data))[i] = taskinfo[i].ti_ptid;
        ((int *)(t.ti_host->data))[i] = taskinfo[i].ti_host;
        ((int *)(t.ti_flag->data))[i] = taskinfo[i].ti_flag;
        ((char **)(t.ti_a_out->data))[i] = SLang_create_slstring (taskinfo[i].ti_a_out);
     }
   (void) SLang_push_cstruct ((VOID_STAR) &t, TaskInfo_Struct);

   free_return:
   SLang_free_array (t.ti_tid);
   SLang_free_array (t.ti_ptid);
   SLang_free_array (t.ti_host);
   SLang_free_array (t.ti_flag);
   SLang_free_array (t.ti_a_out);
}

static void _pvm_mcast (int *msgid)
{
   SLang_Array_Type *at;

   if (-1 == SLang_pop_array_of_type (&at, SLANG_INT_TYPE))
     return;

   if (at->num_elements)
     throw_pvm_exception (pvm_mcast ((int *)at->data, at->num_elements, *msgid));

   SLang_free_array (at);
}

#if 0
static void not_implemented (void)
{
   SLang_verror (SL_NOT_IMPLEMENTED, "Not implemented");
}
static void _pvm_psend (void)
{
   /* I do not know how I can implement this one without a memory leak.
    * The best I can do is to make it operate in a synchronous manner.
    */
   not_implemented ();
}

static void _pvm_precv (void)
{
   not_implemented ();
}
static void _pvm_perror (void)
{
   not_implemented ();
}
static void _pvm_addmhf (void)
{
   not_implemented ();
}
static void _pvm_delinfo (void)
{
   not_implemented ();
}
static void _pvm_delmhf (void)
{
   not_implemented ();
}
static void _pvm_gather (void)
{
   not_implemented ();
}
static void _pvm_getfds (void)
{
   not_implemented ();
}

static void _pvm_getminfo (void)
{
   not_implemented ();
}
static void _pvm_getnoresets (void)
{
   not_implemented ();
}
static void _pvm_hostsync (void)
{
   not_implemented ();
}
static void _pvm_getmboxinfo (void)
{
   not_implemented ();
}
static void _pvm_mkbuf (void)
{
   not_implemented ();
}
static void _pvm_putinfo (void)
{
   not_implemented ();
}
static void _pvm_recvinfo (void)
{
   not_implemented ();
}
static void _pvm_reduce (void)
{
   not_implemented ();
}
static void _pvm_reg_hoster (void)
{
   not_implemented ();
}
static void _pvm_reg_rm (void)
{
   not_implemented ();
}
static void _pvm_reg_tasker (void)
{
   not_implemented ();
}
static void _pvm_reg_tracer (void)
{
   not_implemented ();
}
static void _pvm_scatter (void)
{
   not_implemented ();
}
static void _pvm_setminfo (void)
{
   not_implemented ();
}
static void _pvm_setrbuf (void)
{
   not_implemented ();
}
static void _pvm_setsbuf (void)
{
   not_implemented ();
}
static void _pvm_siblings (void)
{
   not_implemented ();
}
static void _pvm_start_pvmd (void)
{
   not_implemented ();
}
static void _pvm_tickle (void)
{
   not_implemented ();
}
static void _pvm_trecv (void)
{
   not_implemented ();
}
static void _pvm_unexport (void)
{
   not_implemented ();
}
static void _pvm_version (void)
{
   not_implemented ();
}
#endif

#define USE_GROUP_FUNCTIONS 1
#if USE_GROUP_FUNCTIONS
/* There are the group functions, which are in a separate library. */
static void _pvm_bcast (char *group, int *msgtag)
{
   (void) throw_pvm_exception (pvm_bcast (group, *msgtag));
}
static int _pvm_getinst (char *group, int *tid)
{
   return throw_pvm_exception (pvm_getinst (group, *tid));
}
static void _pvm_barrier (char *group, int *count)
{
   throw_pvm_exception (pvm_barrier (group, *count));
}
static void _pvm_lvgroup (char *group)
{
   throw_pvm_exception (pvm_lvgroup (group));
}
static int _pvm_gettid (char *group, int *inum)
{
   return throw_pvm_exception (pvm_gettid (group, *inum));
}
static int _pvm_gsize (char *group)
{
   return throw_pvm_exception (pvm_gsize (group));
}
static int _pvm_joingroup (char *group)
{
   return throw_pvm_exception (pvm_joingroup(group));
}
#endif

static void sigterm_handler (int sig)
{
   killpg (0, sig);
   exit (1);
}

static void _pvm_sigterm_enable (int *mode)
{
   if (*mode == 0)
     {
        (void) SLsignal (SIGTERM, SIG_DFL);
        return;
     }
   /* Make this process its own group leader. This is done to avoid
    * killing the pvm daemon, which otherwise is a member of the current
    * process group.
    */
   (void) setpgid (getpid (), getpid ());
   SLsignal (SIGTERM, sigterm_handler);
}

#define USE_TRACING_FUNCTIONS 1
#if USE_TRACING_FUNCTIONS
/* At this time, the only tracing functions, constants and data types
 * included are those necessary to interface with XPVM. */

#include <pvmtev.h>

typedef struct
{
   Pvmtmask trace_mask;
}
Pvmtmask_Type;
static int Pvmtmask_Type_Id = -1;

static void destroy_pvmtmask_type (SLtype type, VOID_STAR f)
{
   (void) type; (void) f;
}

static void _pvm_settmask (int *tid, Pvmtmask_Type *tm)
{
   pvm_settmask (*tid, tm->trace_mask);
}

static void _tev_mask_init (Pvmtmask_Type *tm)
{
   TEV_MASK_INIT (tm->trace_mask);
}

static void _tev_mask_set (Pvmtmask_Type *tm, int *m)
{
   TEV_MASK_SET (tm->trace_mask, *m);
}

#endif

#define DUMMY_MODEL_TYPE 255

#define V SLANG_VOID_TYPE
#define I SLANG_INT_TYPE
#define S SLANG_STRING_TYPE

static SLang_Intrin_Fun_Type Module_Intrinsics [] =
{
   MAKE_INTRINSIC_1("pvm_delhost", _pvm_delhost, V, S),
   MAKE_INTRINSIC_1("pvm_export", _pvm_export, V, S),
   MAKE_INTRINSIC_1("pvm_freebuf", _pvm_freebuf, V, I),
   MAKE_INTRINSIC_1("pvm_freecontext", _pvm_freecontext, V, I),
   MAKE_INTRINSIC_0("pvm_getcontext", _pvm_getcontext, I),
   MAKE_INTRINSIC_0("pvm_newcontext", _pvm_newcontext, I),
   MAKE_INTRINSIC_1("pvm_setcontext", _pvm_setcontext, I, I),
   MAKE_INTRINSIC_1("pvm_getopt", _pvm_getopt, I, I),
   MAKE_INTRINSIC_2("pvm_nrecv", _pvm_nrecv, I, I, I),
   MAKE_INTRINSIC_2("pvm_sendsig", _pvm_sendsig, V, I, I),
   MAKE_INTRINSIC_1("pvm_tidtohost", _pvm_tidtohost, I, I),
   MAKE_INTRINSIC_2("pvm_setopt", _pvm_setopt, I, I, I),
   MAKE_INTRINSIC_0("pvm_config", _pvm_config, V),
   MAKE_INTRINSIC_0("pvm_getrbuf", _pvm_getrbuf, I),
   MAKE_INTRINSIC_0("pvm_getsbuf", _pvm_getsbuf, I),
   MAKE_INTRINSIC_0("pvm_halt", _pvm_halt, V),
   MAKE_INTRINSIC_1("pvm_tasks", _pvm_tasks, V, I),
   MAKE_INTRINSIC_1("pvm_kill", _pvm_kill, V, I),
   MAKE_INTRINSIC_1("pvm_mstat", _pvm_mstat, I, S),
   MAKE_INTRINSIC_1("pvm_pstat", _pvm_pstat, I, I),
   MAKE_INTRINSIC_1("pvm_mcast", _pvm_mcast, V, I),

   MAKE_INTRINSIC_1("pvm_addhost", _pvm_addhost, I, S),
   MAKE_INTRINSIC_1("pvm_archcode", _pvm_archcode, I, S),
   MAKE_INTRINSIC_2("pvm_probe", _pvm_probe, I, I, I),
   MAKE_INTRINSIC_1("pvm_bufinfo", _pvm_bufinfo, V, I),
   MAKE_INTRINSIC_0("pvm_notify", _pvm_notify, V),
   MAKE_INTRINSIC_0("pvm_unpack", _pvm_unpack, V),
   MAKE_INTRINSIC_2("pvm_send", _pvm_send, V, I, I),
   MAKE_INTRINSIC_2("pvm_recv", _pvm_recv, I, I, I),
   MAKE_INTRINSIC_0("pvm_pack", _pvm_pack, V),
   MAKE_INTRINSIC_1("pvm_initsend", _pvm_initsend, I, I),
   MAKE_INTRINSIC_0("pvm_exit", _pvm_exit, V),
   MAKE_INTRINSIC_0("pvm_mytid", _pvm_mytid, I),
   MAKE_INTRINSIC_0("pvm_parent", _pvm_parent, I),
   MAKE_INTRINSIC_3("pvm_spawn", _pvm_spawn, V, I, S, I),

#if USE_GROUP_FUNCTIONS
   MAKE_INTRINSIC_2("pvm_barrier", _pvm_barrier, V, S, I),
   MAKE_INTRINSIC_2("pvm_getinst", _pvm_getinst, I, S, I),
   MAKE_INTRINSIC_2("pvm_bcast", _pvm_bcast, V, S, I),
   MAKE_INTRINSIC_2("pvm_gettid", _pvm_gettid, I, S, I),
   MAKE_INTRINSIC_1("pvm_gsize", _pvm_gsize, I, S),
   MAKE_INTRINSIC_1("pvm_joingroup", _pvm_joingroup, V, S),
   MAKE_INTRINSIC_1("pvm_lvgroup", _pvm_lvgroup, V, S),
#endif

#if USE_TRACING_FUNCTIONS
   MAKE_INTRINSIC_2("pvm_settmask", _pvm_settmask, V, I, DUMMY_MODEL_TYPE),
   MAKE_INTRINSIC_1("pvm_tev_mask_init", _tev_mask_init, V, DUMMY_MODEL_TYPE),
   MAKE_INTRINSIC_2("pvm_tev_mask_set", _tev_mask_set, V, DUMMY_MODEL_TYPE, I),
#endif

   MAKE_INTRINSIC_1("pvm_sigterm_enable", _pvm_sigterm_enable, V, I),
   MAKE_INTRINSIC_1("__datatype", datatype_intrinsic, V, I),
   SLANG_END_INTRIN_FUN_TABLE
};

static SLang_Intrin_Var_Type Module_Variables [] =
{
   MAKE_VARIABLE("_pvm_module_version_string", &Module_Version_String, SLANG_STRING_TYPE, 1),
   SLANG_END_INTRIN_VAR_TABLE
};

static SLang_IConstant_Type Module_IConstants [] =
{
   MAKE_ICONSTANT("_pvm_module_version", MODULE_VERSION_NUMBER),
   SLANG_END_ICONST_TABLE
};

static SLang_IConstant_Type Module_Constants [] =
{
   MAKE_ICONSTANT("PvmDataDefault", PvmDataDefault),
   MAKE_ICONSTANT("PvmDataRaw", PvmDataRaw),
   MAKE_ICONSTANT("PvmDataInPlace", PvmDataInPlace),
   MAKE_ICONSTANT("PvmDataTrace", PvmDataTrace),
   MAKE_ICONSTANT("PvmTaskDefault", PvmTaskDefault),
   MAKE_ICONSTANT("PvmTaskHost", PvmTaskHost),
   MAKE_ICONSTANT("PvmTaskArch", PvmTaskArch),
   MAKE_ICONSTANT("PvmTaskDebug", PvmTaskDebug),
   MAKE_ICONSTANT("PvmTaskTrace", PvmTaskTrace),
   MAKE_ICONSTANT("PvmMppFront", PvmMppFront),
   MAKE_ICONSTANT("PvmHostCompl", PvmHostCompl),
   MAKE_ICONSTANT("PvmNoSpawnParent", PvmNoSpawnParent),
   MAKE_ICONSTANT("PvmTaskExit", PvmTaskExit),
   MAKE_ICONSTANT("PvmHostDelete", PvmHostDelete),
   MAKE_ICONSTANT("PvmHostAdd", PvmHostAdd),
   MAKE_ICONSTANT("PvmRouteAdd", PvmRouteAdd),
   MAKE_ICONSTANT("PvmRouteDelete", PvmRouteDelete),
   MAKE_ICONSTANT("PvmNotifyCancel", PvmNotifyCancel),
   MAKE_ICONSTANT("PvmRoute", PvmRoute),
   MAKE_ICONSTANT("PvmDontRoute", PvmDontRoute),
   MAKE_ICONSTANT("PvmAllowDirect", PvmAllowDirect),
   MAKE_ICONSTANT("PvmRouteDirect", PvmRouteDirect),
   MAKE_ICONSTANT("PvmDebugMask", PvmDebugMask),
   MAKE_ICONSTANT("PvmAutoErr", PvmAutoErr),
   MAKE_ICONSTANT("PvmOutputTid", PvmOutputTid),
   MAKE_ICONSTANT("PvmOutputCode", PvmOutputCode),
   MAKE_ICONSTANT("PvmTraceTid", PvmTraceTid),
   MAKE_ICONSTANT("PvmTraceCode", PvmTraceCode),
   MAKE_ICONSTANT("PvmTraceBuffer", PvmTraceBuffer),
   MAKE_ICONSTANT("PvmTraceOptions", PvmTraceOptions),
   MAKE_ICONSTANT("PvmTraceFull", PvmTraceFull),
   MAKE_ICONSTANT("PvmTraceTime", PvmTraceTime),
   MAKE_ICONSTANT("PvmTraceCount", PvmTraceCount),
   MAKE_ICONSTANT("PvmFragSize", PvmFragSize),
   MAKE_ICONSTANT("PvmResvTids", PvmResvTids),
   MAKE_ICONSTANT("PvmSelfOutputTid", PvmSelfOutputTid),
   MAKE_ICONSTANT("PvmSelfOutputCode", PvmSelfOutputCode),
   MAKE_ICONSTANT("PvmSelfTraceTid", PvmSelfTraceTid),
   MAKE_ICONSTANT("PvmSelfTraceCode", PvmSelfTraceCode),
   MAKE_ICONSTANT("PvmSelfTraceBuffer", PvmSelfTraceBuffer),
   MAKE_ICONSTANT("PvmSelfTraceOptions", PvmSelfTraceOptions),
   MAKE_ICONSTANT("PvmShowTids", PvmShowTids),
   MAKE_ICONSTANT("PvmPollType", PvmPollType),
   MAKE_ICONSTANT("PvmPollConstant", PvmPollConstant),
   MAKE_ICONSTANT("PvmPollSleep", PvmPollSleep),
   MAKE_ICONSTANT("PvmPollTime", PvmPollTime),
   MAKE_ICONSTANT("PvmOutputContext", PvmOutputContext),
   MAKE_ICONSTANT("PvmTraceContext", PvmTraceContext),
   MAKE_ICONSTANT("PvmSelfOutputContext", PvmSelfOutputContext),
   MAKE_ICONSTANT("PvmSelfTraceContext", PvmSelfTraceContext),
   MAKE_ICONSTANT("PvmNoReset", PvmNoReset),
   MAKE_ICONSTANT("PvmTaskSelf", PvmTaskSelf),
   MAKE_ICONSTANT("PvmTaskChild", PvmTaskChild),
   MAKE_ICONSTANT("PvmBaseContext", PvmBaseContext),
   MAKE_ICONSTANT("PvmMboxDefault", PvmMboxDefault),
   MAKE_ICONSTANT("PvmMboxPersistent", PvmMboxPersistent),
   MAKE_ICONSTANT("PvmMboxMultiInstance", PvmMboxMultiInstance),
   MAKE_ICONSTANT("PvmMboxOverWritable", PvmMboxOverWritable),
   MAKE_ICONSTANT("PvmMboxFirstAvail", PvmMboxFirstAvail),
   MAKE_ICONSTANT("PvmMboxReadAndDelete", PvmMboxReadAndDelete),
   MAKE_ICONSTANT("PvmMboxWaitForInfo", PvmMboxWaitForInfo),
   MAKE_ICONSTANT("PvmOk", PvmOk),
   MAKE_ICONSTANT("PvmBadParam", PvmBadParam),
   MAKE_ICONSTANT("PvmMismatch", PvmMismatch),
   MAKE_ICONSTANT("PvmOverflow", PvmOverflow),
   MAKE_ICONSTANT("PvmNoData", PvmNoData),
   MAKE_ICONSTANT("PvmNoHost", PvmNoHost),
   MAKE_ICONSTANT("PvmNoFile", PvmNoFile),
   MAKE_ICONSTANT("PvmDenied", PvmDenied),
   MAKE_ICONSTANT("PvmNoMem", PvmNoMem),
   MAKE_ICONSTANT("PvmBadMsg", PvmBadMsg),
   MAKE_ICONSTANT("PvmSysErr", PvmSysErr),
   MAKE_ICONSTANT("PvmNoBuf", PvmNoBuf),
   MAKE_ICONSTANT("PvmNoSuchBuf", PvmNoSuchBuf),
   MAKE_ICONSTANT("PvmNullGroup", PvmNullGroup),
   MAKE_ICONSTANT("PvmDupGroup", PvmDupGroup),
   MAKE_ICONSTANT("PvmNoGroup", PvmNoGroup),
   MAKE_ICONSTANT("PvmNotInGroup", PvmNotInGroup),
   MAKE_ICONSTANT("PvmNoInst", PvmNoInst),
   MAKE_ICONSTANT("PvmHostFail", PvmHostFail),
   MAKE_ICONSTANT("PvmNoParent", PvmNoParent),
   MAKE_ICONSTANT("PvmNotImpl", PvmNotImpl),
   MAKE_ICONSTANT("PvmDSysErr", PvmDSysErr),
   MAKE_ICONSTANT("PvmBadVersion", PvmBadVersion),
   MAKE_ICONSTANT("PvmOutOfRes", PvmOutOfRes),
   MAKE_ICONSTANT("PvmDupHost", PvmDupHost),
   MAKE_ICONSTANT("PvmCantStart", PvmCantStart),
   MAKE_ICONSTANT("PvmAlready", PvmAlready),
   MAKE_ICONSTANT("PvmNoTask", PvmNoTask),
   MAKE_ICONSTANT("PvmNotFound", PvmNotFound),
   MAKE_ICONSTANT("PvmExists", PvmExists),
   MAKE_ICONSTANT("PvmHostrNMstr", PvmHostrNMstr),
   MAKE_ICONSTANT("PvmParentNotSet", PvmParentNotSet),
   MAKE_ICONSTANT("PvmNoEntry", PvmNoEntry),
   MAKE_ICONSTANT("PvmDupEntry", PvmDupEntry),

#if USE_TRACING_FUNCTIONS
   MAKE_ICONSTANT("TEV_MCAST", TEV_MCAST),
   MAKE_ICONSTANT("TEV_SEND", TEV_SEND),
   MAKE_ICONSTANT("TEV_RECV", TEV_RECV),
   MAKE_ICONSTANT("TEV_NRECV", TEV_NRECV),
#endif

   MAKE_ICONSTANT("_pvm_module_version", MODULE_VERSION_NUMBER),
   MAKE_ICONSTANT("_pvm_library_version", MAKE_VERSION(PVM_MAJOR_VERSION,PVM_MINOR_VERSION,PVM_PATCH_VERSION)),

   SLANG_END_ICONST_TABLE
};

#if USE_TRACING_FUNCTIONS
static void patchup_intrinsic_table (void) /*{{{*/
{
   SLang_Intrin_Fun_Type *f;

   f = Module_Intrinsics;
   while (f->name != NULL)
     {
        unsigned int i, nargs;
        SLtype *args;

        nargs = f->num_args;
        args = f->arg_types;
        for (i = 0; i < nargs; i++)
          {
             if (args[i] == DUMMY_MODEL_TYPE)
               args[i] = Pvmtmask_Type_Id;
          }

        /* For completeness */
        if (f->return_type == DUMMY_MODEL_TYPE)
          f->return_type = Pvmtmask_Type_Id;

        f++;
     }
}
/*}}}*/

#endif

int init_pvm_module_ns (char *ns_name)
{
#if USE_TRACING_FUNCTIONS
   SLang_Class_Type *cl;
#endif

   SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);
   if (ns == NULL)
     return -1;

   if ((-1 == SLns_add_intrin_fun_table (ns, Module_Intrinsics, "__PVM__"))
       || (-1 == SLns_add_intrin_var_table (ns, Module_Variables, NULL))
       || (-1 == SLns_add_iconstant_table (ns, Module_Constants, NULL))
       || (-1 == SLns_add_iconstant_table (ns, Module_IConstants, NULL))
       )
     return -1;

#if USE_TRACING_FUNCTIONS
   if (Pvmtmask_Type_Id == -1)
     {        
        if (NULL == (cl = SLclass_allocate_class ("Pvmtmask_Type")))
          return -1;
        (void) SLclass_set_destroy_function (cl, destroy_pvmtmask_type);
        if (-1 == SLclass_register_class (cl, SLANG_VOID_TYPE,
                                          sizeof (Pvmtmask_Type), SLANG_CLASS_TYPE_MMT))
          return -1;
        Pvmtmask_Type_Id = SLclass_get_class_id (cl);
        patchup_intrinsic_table ();
     }   
#endif

   return 0;
}

/* This function is optional */
void deinit_pvm_module (void)
{
}
