/*
  Native entries for the HPrimitive class

  @author  Jeff Schoen / J. Czechowski IV / Neon Ngo

  Tips when translating from Fortran to C:
    (1) All Fortran function/subroutine names need an extra underscore at the
        end in C and should be in all lower-case. For example:
          Fortran:  SUBROUTINE M$FOO  ()
          C:        void       m$foo_ ()

    (2) All Fortran function/subroutine parameters are passed via pointers
        (EXCEPT lengths of strings) but all returns (EXCEPT strings) are
        returned using the standard primitive type. For example:
          Fortran:  real*8 function foo  (integer*4 param1, HEADER  hcb)
          C:        real_8          foo_ (int_4    *param1, HEADER *hcb)

    (3) A Fortran function/subroutine that takes in a string is rewritten to
        include the string length at the end of the parameter list. For example:
          Fortran:  integer*4 foo  (character*(*) str1, character*(*) str2, integer*4 val)
          C:        int_4     foo_ (char         *str1, char         *str2, int_4    *val, fstring_len_t lstr1, fstring_len_t lstr2)

    (4) A Fortran function that returns a string is rewritten as a void function with the
        string and it's length as the first two parameters. For example:
          Fortran:  character*1 foo  (integer*4 val)
          C:        void        foo_ (char *str, fstring_len_t lstr, int_4 *val)
*/

#include "cdefs.h"
#include "native.h"
#include "headers.h"
#include "context.h"
#include "commandable.h"
#include "midas.h"
#include "fcinterface.h"
#include "xmcompat.h"
#include "cutils.h"
#include <sys/param.h> /* Used to get MAXPATHLEN */
#include <stdlib.h>    /* Used by M$IMPORT */
#include <string.h>    /* Used by M$IMPORT */
#include <sys/types.h> /* Used by check_if_dir */
#include <sys/stat.h>  /* Used by check_if_dir */
#include <unistd.h>    /* Used by check_if_dir */
#include <ctype.h>     /* for toupper(), isdigit() */

/* Note: NmJackets.h is included after the debugging and stack trace definitions. */

#include "nxm_xbc_lib_HPrimitive.h"
#define HOST_START    nxm_xbc_lib_HPrimitive_HOST_START
#define HOST_CHECKIN  nxm_xbc_lib_HPrimitive_HOST_CHECKIN
#define HOST_OPEN     nxm_xbc_lib_HPrimitive_HOST_OPEN
#define HOST_SYNC     nxm_xbc_lib_HPrimitive_HOST_SYNC
#define HOST_PROCESS  nxm_xbc_lib_HPrimitive_HOST_PROCESS
#define HOST_RETURN   nxm_xbc_lib_HPrimitive_HOST_RETURN
#define HOST_CLOSE    nxm_xbc_lib_HPrimitive_HOST_CLOSE
#define HOST_DONE     nxm_xbc_lib_HPrimitive_HOST_DONE


#define CACHE_STRINGS TRUE  /* Turn string caching on/off. */
#define DEBUG         FALSE /* Turn basic debugging messages on/off. */
#define DEBUG_MEM     FALSE /* Turn memory-related debugging messages on/off. */
#define DEBUG_IO      FALSE /* Turn I/O-related debugging messages on/off. */

#if defined(XBC_DEBUG_TRACE) /* Commonly set in nxm/sys/cfg/build.props */
# define DEBUG_TRACE XBC_DEBUG_TRACE /* Turn on/off stack trace (if allowed by compiler). */
#else
# define DEBUG_TRACE FALSE           /* Turn on/off stack trace (if allowed by compiler). */
#endif

#if defined(__GNUC__)
/* For more details on how backtraces are made available by GCC, check out Section 22.1 "Backtraces"
   in "The GNU C Library" (see http://www.delorie.com/gnu/docs/glibc/libc_665.html). The execinfo.h
   library is LGPL (i.e. we can use it) the bfd.h library provides more functionality such as line
   number in the source code, but it is GPL (i.e. we can't use it for legal reasons).

   The backtrace(..) function treats the stack frames as a linked list and iterates over it creating
   an array of return addresses. The backtrace_symbols(..) method is more complicated since it looks
   up the associated symbols. Note that function inlining and tail-call optimizations may cause fewer
   frames than would be expected by looking at the source code. Additionally, static methods might
   not have symbol named entered in the shared object.

   While intended for "the purposes of logging or diagnostics", the "Backtraces" section of "The GNU
   C Library" does not restrict usage of the the backtrace(..) method. However, some older (2004)
   BSD implementations that I looked at used underlying calls that are intended only for debugging
   purposes (i.e. not 100% reliable). For now I'll assume that the GNU docs are accurate (with their
   approval of using backtrace(..) for "logging") meaning that it is safe to use in normal program
   execution.
 */
# include <execinfo.h>      /* for getStackTrace(..) */
# define MAX_STACK_SIZE 128 /* Range of 0..127 is typical in Linux/FreeBSD */
static void *tempStackArray[MAX_STACK_SIZE];
#endif

/* The STACKTRACE value is a jlong to allow us to put a pointer in it if required for other
   compilers (GCC would work fine with a jint). In cases where stack traces are turned off,
   STACKTRACE is simply set to 0.
 */
#if defined(__GNUC__) && DEBUG_TRACE
# define STACKSIZE      ((jlong)backtrace(tempStackArray,MAX_STACK_SIZE))
# define INITSTACKSIZE  ((jlong)(STACKSIZE - 1) << 16)            /* -1 to add back mh$<prim_name> */
# define STACKTRACE     ((jlong)(ctx->initStackSize | STACKSIZE)) /* First 16 bits are initial size, next 16 are current size. */
#else
# define STACKSIZE      ((jlong)0) /* not available or not enabled */
# define INITSTACKSIZE  ((jlong)0) /* not available or not enabled */
# define STACKTRACE     ((jlong)0) /* not available or not enabled */
#endif


#include "NmJackets.h" /* Do not move this... it depends on the above #define's */


/* Function prototypes. */
static void rfindString (char *, char *, fstring_len_t);
static void updateAuxEntries ();
void m_error (const char *);
void m$close_ (HEADER *);
void m$inok_ (HEADER *);
void m$init_ (HEADER *, const char *, const char *, const char *, int_4 *, fstring_len_t, fstring_len_t, fstring_len_t);

/* Function Prototypes external to this file */
void  m$xbc_setcommons_ (M_PTR*,M_PTR*); /* in xmlibf.for */
int_4 m$times2str_ (double *, double *, char *, char *, fstring_len_t, fstring_len_t); /* in utilities.for */
void  m$reformat_  (void *, char *, void *, char *, int_4 *, fstring_len_t, fstring_len_t); /* in math.for */
void  m$vinit_ (); /* in vector.for */
void  m_grab(HEADER *, void *, real_8, int_4, int_4 *); /* C interface to m$grab, in mjackets.c */

/* The "get context" for the command, this is only accessed by the getContext()
   method. Note that this must be local to the thread.
 */
static __thread Context gctx;
static __thread char hcbInit[512];

/* Pointer to the common MCSTRUCT used for all commands. Prior to 2.5.0 this
   was defined in a Fortran common block, it was moved to C during the changes
   to support 64-bit systems. This should only be accessed by m$chkin(..), all
   others should use mc pointer.
 */
static MCSTRUCT libMc;

/* Pointer to the common MUSTRUCT used for all commands. Prior to 2.5.0 this
   was defined in a Fortran common block, it was moved to C during the changes
   to support 64-bit systems. This should only be accessed by m$chkin(..), all
   others should use mu pointer.
 */
//static  MUSTRUCT libMu;  // Changed to line below in 3.3.4 because of Intel 13 issues (Bug 2777)
__thread MUSTRUCT libMu;

/* Mc and Mu pointer for C and C++ Primitives */
MCSTRUCT* Mc = 0;
__thread MUSTRUCT* Mu = 0; /* Mu should be in thread local (same as libMu) */

/*** XBC Debugging levels ***/
__thread int xbcdebug = 0; /* XBC debug level mask, 0 for none  */

typedef struct {
  jobject  jstring;
  char    *cstring;
} string_info;

Context *getContext() {
  return (&gctx);
}

/* Marks a local reference (such as a string that was created) as being ready to be
   garbage collected by the JavaVM.
*/
#define LocalGC(A)  deleteLocal(ctx, &(A), FALSE)
#define StringGC(A) deleteLocal(ctx, &(A), TRUE)

static void deleteLocal(Context *ctx, jobject *obj, bool_4 localString) {
  JNIEnv *env = ctx->env;
  jobject ptr = NULL;

  if (*obj == 0) {
    /* Nothing to delete. */
  } else {
#if CACHE_STRINGS
    if (localString) {
      ptr = (jobject)(jpointer)nm_putString(*obj, (jpointer)*obj);
    } else {
      ptr = *obj;
    }
#else
    ptr = *obj;
#endif
    if (ptr != NULL) {
      (*env)->DeleteLocalRef(env,ptr);
      if (DEBUG_MEM) { fprintf(stderr, "XMLIBC.C: DeleteLocalRef %p ... DELETED %p\n", obj, ptr); }
    } else {
      if (DEBUG_MEM) { fprintf(stderr, "XMLIBC.C: DeleteLocalRef %p ... SAVED\n", obj); }
    }
  }
  *obj = NULL;
}

void libHostInit (JNIEnv *env, jobject xm) {
  initMethods(env, xm);
}

/** This SHOULD ONLY be executed inside the Primitive's thread
    @param obj reference to the HPrimitive (Java object)
    @param nm  reference to NmJackets (Java object)
 */
void *initContext (JNIEnv *env, jobject obj, jobject nm) {
  Context *ctx = getContext();
  ctx->env           = env;
  ctx->nm            = nm;
  ctx->initStackSize = INITSTACKSIZE;
  ctx->todo          = -1.0;
  ctx->ncontrols     = 0;
  ctx->nmallocs      = 0;
  /* form initializer for the main header buffer for reuse later */
  nm_copyMainX((jlong)(jpointer)hcbInit);
  return (void *)ctx;
}

/* Creates a new Java byte array matching a given C/Fortran byte buffer. If cbuf
   is NULL a new (empty) array will be created with the given length.
   @param env   The JNI env.
   @param cbuf  The C/Fortran byte buffer.
   @param lcbuf The length of the byte buffer.
 */
jobject c2jbuf(JNIEnv *env, void* cbuf, int_4 lcbuf) {
  jobject array = (*env)->NewByteArray(env, lcbuf);

  if ((array != NULL) && (cbuf != NULL)) {
     (*env)->SetByteArrayRegion(env, array, 0, lcbuf, cbuf);
  }

  if (DEBUG_MEM) { fprintf(stderr, "XMLIBC.C: Created array of length %d = %p\n", lcbuf, array); }
  return array;
}

/* Copies a Java byte to an existing C/Fortran byte buffer.
   @param env   The JNI env.
   @param array The Java array.
   @param cbuf  The C/Fortran byte buffer.
   @param lcbuf The length of the byte buffer.
 */
void j2cbuf(JNIEnv *env, jobject array, void* cbuf, int_4 lcbuf) {
  int_4 length = lcbuf;

  if ((array != NULL) && (cbuf != NULL)) {
    if (length < 0) {
      length = (*env)->GetArrayLength(env, array);
    }
    (*env)->GetByteArrayRegion(env, array, 0, length, cbuf);
  }
}

/*
  String internal conversion utilities
*/

fstring_len_t j2cstr (JNIEnv *env, jobject jstr, char *str, fstring_len_t len) {
  const char *cstr;
  fstring_len_t lcstr;

  if (jstr == NULL) {
    str[0] = 0;
    len    = 0;
  } else {
    cstr  = (*env)->GetStringUTFChars(env, jstr, 0);
    lcstr = strlen(cstr);

    if (lcstr < len) {
      memcpy(str, cstr, lcstr+1);
      len = lcstr;
    } else {
      memcpy(str, cstr, len-1);
      str[len-1] = 0;
    }
    (*env)->ReleaseStringUTFChars(env, jstr, cstr);
  }
  return len;
}

/* Java String to Fortran string (character array) conversion.
   @param jstr Java String input
   @param fstr Fortran string output (character array)
   @param lfstr (max) length of Fortran string (fstr)
   @return length of output Fortran string (0 for null Java String)
 */
int j2fstr (JNIEnv *env, jobject jstr, char *fstr, fstring_len_t lfstr) {
  const char *cstr;
  fstring_len_t lcstr;

  if (jstr == NULL) {
    lcstr = 0;
    strc2f(NULL, lcstr, fstr, lfstr, C2F_FLAG_FILL);
    lfstr  = 0;
  } else {
    cstr  = (*env)->GetStringUTFChars(env, jstr, 0);
    lcstr = strlen(cstr);
    strc2f(cstr, lcstr, fstr, lfstr, C2F_FLAG_FILL);
    (*env)->ReleaseStringUTFChars(env, jstr, cstr);
    if (lcstr<lfstr) lfstr = lcstr;
  }
  return lfstr;
}

jobject c2jstr (JNIEnv *env, const char *cstr) {
  Context *ctx = getContext();
  jobject jstr = NULL;
#if CACHE_STRINGS
  char buf[16];
  fstring_len_t len = strlen(cstr);

  if (len <= 16) {
    memset(buf, 0, 16);
    memcpy(buf, cstr, len);

    jstr = (jobject)(jpointer)nm_getString(buf[0], buf[1], buf[2], buf[3], buf[4], buf[5], buf[6], buf[7],
                                           buf[8], buf[9], buf[10],buf[11],buf[12],buf[13],buf[14],buf[15]);
  }
#endif

  if (jstr != NULL) {
    if (DEBUG_MEM) { fprintf(stderr, "XMLIBC.C: Found string '%s' = %p\n", cstr, jstr); }
  }
  else {
    jstr = (*env)->NewStringUTF(env, cstr);
    if (DEBUG_MEM) { fprintf(stderr, "XMLIBC.C: Created string '%s' = %p\n", cstr, jstr); }
    if (jstr == NULL) {
      nm_runGC();
      jstr = (*env)->NewStringUTF(env, cstr);
      if (DEBUG_MEM) { fprintf(stderr, "XMLIBC.C: Created string '%s' = %p (TRY 2)\n", cstr, jstr); }
    }
  }
  return jstr;
}

/* Converts a Fortran string to a Java string. Any trailing spaces in the Fortran string are trimmed.
   The Fortran string is first converted to a C string (with a null terminator at end) then to a Java String.
 */
jobject f2jstr (JNIEnv *env, const char *fstr, fstring_len_t len) {
  fstring_len_t i, j=len;
  char cstr[len+1]; /* BUG 2501 to prevent SIGSEGV for input string len >= 160 */
  for (; j>0 && fstr[j-1]<=' '; j--); /* remove trailing spaces on the Fortran string */
  for (i=0; i<j; i++) cstr[i]=fstr[i];
  cstr[j]=0;
  return c2jstr(env, cstr);
}

/* Converts a fortran switch name to the NeXtMidas/Java string. (This method
   adds the leading '/' that NeXtMidas expects in switch names.
   @param env     The JNI environment.
   @param fstr    The fortran string.
   @param len     The length of the Fortran string.
   @return The necessary Java string.
*/
jobject fsw2jstr (JNIEnv *env, const char *fstr, fstring_len_t len) {
  fstring_len_t i, j=len;
  char cstr[len+1]; cstr[0]='/'; /* BUG 2501 to prevent SIGSEGV for input string len >= 160 */
  for (; j>0 && fstr[j-1]<=' '; j--); /* Discount trailing spaces on the Fortran string */
  for (i=0; i<j; i++) cstr[i+1]=fstr[i];
  cstr[j+1]=0;
  return c2jstr(env, cstr);
}

void f2fstr (JNIEnv *env, const char *f1str, fstring_len_t f1len, char *f2str, fstring_len_t f2len) {
  fstring_len_t i;
  for (i=0; i<f2len; i++) {
    if (i<f1len) f2str[i]=f1str[i];
    else f2str[i]=' ';
  }
}

void c2fstr (JNIEnv *env, const char *c1str, char *f2str, fstring_len_t f2len) {
  fstring_len_t i, c1len=strlen(c1str);
  for (i=0; i<f2len; i++) {
    if (i<c1len) f2str[i]=c1str[i];
    else f2str[i]=' ';
  }
}


#if defined(__GNUC__)
jarray getStackTrace (jlong st) {
  if (st == 0) {
    return NULL; /* Stack trace not enabled. */
  }
  else {
    void          *array[MAX_STACK_SIZE];
    int_4          size    = backtrace(array,MAX_STACK_SIZE);
    char         **strings = backtrace_symbols(array, size);
    Context       *ctx     = getContext();
    JNIEnv        *env     = ctx->env;
    int_4          init    = ((st >> 16) & 0xFFFF);
    int_4          curr    = (st & 0xFFFF);
    int_4          start   = MAX(0, size - curr); /* Bug 1619: prevent negative start index */
    int_4          end     = MAX(0, size - init); /* Bug 1619: prevent negative end index */
    int_4          len     = MIN(size, MAX(0, end - start)); /* Bug 1619:prevent negative length & make sure len<=size */
    jclass         Object  = (*env)->FindClass(env, "java/lang/String");
    jobjectArray   jarray;
    int_4          i;

    if (len<=0) { len = size - 1; start = 1; } /* Bug 1619: len<=0, no stack trace? setting len to size-1 and start to 1 .*/
    jarray = (*env)->NewObjectArray(env, len, Object, NULL);

    for (i = 0; i < len; i++, start++) {
      (*env)->SetObjectArrayElement(env, jarray, i, c2jstr(ctx->env, strings[start]));
    }
    return jarray;
  }
}
#else
jarray getStackTrace (jlong st) { return NULL; } /* Not supported on this platform. */
#endif

void m_setbreak (int_4 value) {
  Context *ctx = getContext();
  ctx->mc->break_ = value;
}

void m$setbreak_ (int_4 *value) {
  m_setbreak(*value);
}

void m_error (const char *msg) {
  Context *ctx = getContext();
  jobject jmsg = c2jstr(ctx->env,msg);
  nm_error(jmsg);
  m_setbreak(1);
  StringGC(jmsg);
}

void m_warning (const char *msg) {
  Context *ctx = getContext();
  jobject jmsg = c2jstr(ctx->env,msg);
  nm_warning(jmsg);
  StringGC(jmsg);
}

void m_info (const char *msg) {
  Context *ctx = getContext();
  jobject jmsg = c2jstr(ctx->env,msg);
  nm_info(jmsg);
  StringGC(jmsg);
}

static void m_deprecate (const char *msg) {
  Context *ctx = getContext();
  jobject jmsg = c2jstr(ctx->env,msg);
  nm_deprecate(jmsg);
  StringGC(jmsg);
}

void m$info_ (const char *msg, fstring_len_t lmsg) {
  Context *ctx = getContext();
  jobject jmsg = f2jstr(ctx->env,msg,lmsg);
  nm_info(jmsg);
  StringGC(jmsg);
}

void m$warning_ (const char *msg, fstring_len_t lmsg) {
  Context *ctx = getContext();
  jobject jmsg = f2jstr(ctx->env,msg,lmsg);
  nm_warning(jmsg);
  StringGC(jmsg);
}

void m$error_ (const char *msg, fstring_len_t lmsg) {
  Context *ctx = getContext();
  jobject jmsg = f2jstr(ctx->env,msg,lmsg);
  if (DEBUG) { printf("m$error: %.*s\n",(int)lmsg,msg); }
  nm_error(jmsg);
  m_setbreak(1);
  StringGC(jmsg);
}

int_4 m$a2d_ (const char *string, double *dval, fstring_len_t ls) {
  Context *ctx = getContext();
  jobject jstring = f2jstr(ctx->env,string,ls);
  int_4 status = 0;
  if (DEBUG) { fprintf(stderr, "XMLIBC.C: M$A2D string='%.*s'\n", (int)ls, string); }
  *dval = nm_s2d(jstring);
  StringGC(jstring);
  status = 1;
  if (DEBUG) { fprintf(stderr, "XMLIBC.C: M$A2D dval=%f, status=%d\n", *dval, status); }
  return status;
}

/*
  Memory routines
*/
void m_stmalloc (int_4 nbytes, M_PTR *location) {
  int_4 truebytes;
  if (nbytes <= 0)
    location->p = (M_PTR_T)NULL;
  else {
    truebytes = ((nbytes + 3) / 4) * 4;
    if (! (location->p = (M_PTR_T)malloc(truebytes))) {
      printf("Attempting to allocate %d bytes\n", truebytes);
      m_error("Unable to allocate requested memory");
    }
  }
}

void m$stmalloc_ (const int_4 *p1, M_PTR *p2) {
  m_stmalloc(*p1, p2);
}

void m_stmfree (int_4 nbytes, M_PTR location) {
  Context *ctx = getContext();
  if (nbytes > 0) free((void*)location.p);
}

void m$stmfree_ (const int_4 *p1, M_PTR *p2) {
  m_stmfree(*p1, *p2);
}

void m$malloc64_ (int_8 *size, M_PTR *addr) {
  Context *ctx = getContext();
  addr->p = (M_PTR_T)NULL;
  if (*size <= 0) return;
  addr->p = (M_PTR_T)malloc(*size);
  if (ctx->nmallocs>=MAXMALLOCS) m_error("No malloc slots left");
  ctx->mallocs[ctx->nmallocs++] = addr->p;
}

void m$malloc_ (int_4 *size, M_PTR *addr) {
  int_8 size8 = *size;
  m$malloc64_(&size8, addr);
}

void m$free_ (M_PTR *addr) {
  Context *ctx = getContext();
  int_4 i=0;
  if (addr->p != 0) {
    for (i=0; i<ctx->nmallocs && ctx->mallocs[i]!=addr->p; i++);
    if (i==ctx->nmallocs) m_error("Could not find mfree slot");
    else free( (void *)ctx->mallocs[i] );
    ctx->nmallocs--;
    for (; i<ctx->nmallocs; i++) ctx->mallocs[i] = ctx->mallocs[i+1];
  }
}

void m$mfree_ (int_4 *size, M_PTR *addr) {
  if (size != 0) m$free_(addr);
}

void m$remalloc_ (int_4 *size, M_PTR *addr) {
  Context *ctx = getContext();
  m$free_(addr);
  m$malloc_(size,addr);
}

void m$freeall_ () {
  Context *ctx = getContext();
  int_4 i=0;
  for (i=0; i<ctx->nmallocs; i++) free( (void *)ctx->mallocs[i] );
  ctx->nmallocs=0;
}


/*
  Args methods
*/
void m$upick_ (char *upick, fstring_len_t lupick, int_4 *n) {
  Context *ctx = getContext();
  jobject jstr = nm_upick(*n);
  fstring_len_t ls = j2fstr(ctx->env,jstr,upick,lupick);
  if (DEBUG) { printf("m$upick %d=%.*s len=%d\n",*n,(int)ls,upick,ls); }
  LocalGC(jstr);
}

void m$apick_ (char *apick, fstring_len_t lapick, int_4 *n) {
  Context *ctx = getContext();
  jobject jstr = nm_apick(*n);
  fstring_len_t ls = j2fstr(ctx->env,jstr,apick,lapick);
  if (DEBUG) { printf("m$apick %d=%.*s len=%d\n",*n,(int)ls,apick,ls); }
  LocalGC(jstr);
}

int_4 m$uapick_ (int *n, char *uapick, int_4 *flags, fstring_len_t luapick) {
  Context *ctx = getContext();
  jobject jstr = nm_upick(*n);
  fstring_len_t ls = j2fstr(ctx->env,jstr,uapick,luapick);
  if (DEBUG) { printf("m$uapick %d=%.*s len=%d flags=%d\n",*n,(int)ls,uapick,ls,*flags); }
  LocalGC(jstr);
  return ls;
}

int_4 m$apick_post_ (char *apick, int_4 *ln, fstring_len_t lapick) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env,apick,*ln);
  jobject jstro = nm_apickpost(jstri,1); /* RESOLVE only flag */
  fstring_len_t ls = j2fstr(ctx->env,jstro,apick,lapick);
  if (DEBUG) { printf("m$apick_post %.*s\n",(int)ls,apick); }
  LocalGC(jstri);
  LocalGC(jstro);
  return ls;
}

double m$dpick_ (int_4 *n) {
  Context *ctx = getContext();
  double value = nm_dpick(*n);
  if (DEBUG) { printf("m$dpick %d=%f\n",*n,value); }
  return value;
}

float m$fpick_ (int_4 *n) {
  return (float)m$dpick_(n);
}

int_4 m$lpick_ (int_4 *n) {
  Context *ctx = getContext();
  jint value = nm_lpick(*n);
  if (DEBUG) { printf("m$lpick %d=%d\n",*n,value); }
  return value;
}

int_2 m$ipick_ (int_4 *n) {
  return (int_2)m$lpick_(n);
}

int_1 m$bpick_ (int_4 *n) {
  return (int_1)m$lpick_(n);
}

int_4 m$ppick_ (int_4 *n) {
  Context *ctx = getContext();
  return nm_ppick(*n);
}

int_4 m$spick_ (int_4 *n) {
  Context *ctx  = getContext();
  return nm_spick(*n);
}

int_4 m$tpick_ (int_4 *n, double* wsec, double* fsec) {
  Context *ctx = getContext();
  JNIEnv  *env = ctx->env;
/* NTN: orig code before fix to Bug 1514
    double  sec = m$dpick_(n);
    int_4    precision = (m$ppick_(n) == 0)? 0: 1;
    JC4: This uses the same algorithm used by new Time(double) to get wsec and fsec.
    sec = sec+5e-7;
    *wsec = floor(sec);
    *fsec = 1e-6*floor(1e6*(sec-*wsec));
*/
  jarray jresults  = nm_tpick(*n);
  int_4  precision = 0; /* precision value, 0 for not present or error */
  if (jresults != NULL) {
    jdouble *darray = (jdouble *)GetArray(jresults);
    precision = (int_4) darray[0];
    *wsec     = darray[1];
    *fsec     = darray[2];
    ReleaseArrayNoCopyBack(env,jresults,darray); /* NTN: don't need to copy changes back to jresults */
  }

  if (DEBUG) { printf("m$tpick %d=(wsec=%lf, fsec=%le, precision=%d)\n",*n,*wsec,*fsec,precision); }
  return precision;
}

int_4 m$get_uswitch_ (const char *name, char *string, fstring_len_t lname, fstring_len_t lstring) {
  Context *ctx = getContext();
  jobject jname    = fsw2jstr(ctx->env,name,lname);
  jobject jstr     = nm_get_uswitch_def(jname,NULL);
  int_4   ls       = -1;
  if (jstr != NULL) {
    ls = j2fstr(ctx->env,jstr,string,lstring);
    if (DEBUG) { printf("m$get_uswitch(%.*s) = %.*s (length=%d)\n", (int)lname, name, (int)lstring, string,ls); }
  } else {
    if (DEBUG) { printf("m$get_uswitch(%.*s) = NULL\n", (int)lname, name); }
  }
  StringGC(jname);
  LocalGC(jstr);
  return ls;
}

int_4 m$get_pswitch_ (char *name, fstring_len_t lname) {
  Context *ctx = getContext();
  jobject jname = fsw2jstr(ctx->env,name,lname);
  int_4   value = nm_get_pswitch(jname);
  if (DEBUG) { printf("m$get_pswitch(%.*s) = %d\n", (int)lname, name, value); }
  StringGC(jname);
  return value;
}

int_4 m$get_sswitch_ (char *name, fstring_len_t lname) {
  Context *ctx  = getContext();
  jobject jname = fsw2jstr(ctx->env,name,lname);
  int_4   value = nm_get_sswitch(jname);
  if (DEBUG) { printf("m$get_sswitch(%.*s) = %d\n", (int)lname, name, value); }
  StringGC(jname);
  return value;
}

int_4 m$get_sswitch_def_ (char *name, int_4* def, fstring_len_t lname) {
  Context  *ctx  = getContext();
  jobject  jname = fsw2jstr(ctx->env,name,lname);
  jboolean isPresent = nm_get_pswitch(jname);
  int_4    default_val = *def;
  int_4    value;
  if (isPresent == JNI_FALSE) {
    value = default_val; // switch not present, return default value
    if (DEBUG) { printf("m$get_sswitch_def(%.*s, %d) = %d (switch not present)\n",(int)lname,name,default_val,value); }
    return value;
  } else {
    jboolean jbool = (default_val == 0)? JNI_FALSE: JNI_TRUE;
    value = nm_get_sswitch_def(jname,jbool);
    if (DEBUG) { printf("m$get_sswitch_def(%.*s, %d) = %d\n",(int)lname,name,default_val,value); }
  }
  StringGC(jname);

  return value;
}

int_4 m$get_switch_ (char *name, fstring_len_t lname) {
  Context *ctx  = getContext();
  jobject jname = fsw2jstr(ctx->env,name,lname);
  int_4   value = nm_get_switch(jname);
  if (DEBUG) { printf("m$get_switch(%.*s) = %d\n",(int)lname,name,value); }
  StringGC(jname);
  return value;
}

int_4 m$get_switch_def_ (char *name, int_4 *def, fstring_len_t lname) {
  Context *ctx  = getContext();
  jobject jname = fsw2jstr(ctx->env,name,lname);
  int_4   value = nm_get_switch_def(jname,*def);
  if (DEBUG) { printf("m$get_switch_def(%.*s,%d) = %d\n",(int)lname,name,*def,value); }
  StringGC(jname);
  return value;
}

double m$get_dswitch_ (char *name, fstring_len_t lname) {
  Context *ctx  = getContext();
  jobject jname = fsw2jstr(ctx->env,name,lname);
  double  value = nm_get_dswitch(jname);
  if (DEBUG) { printf("m$get_dswitch(%.*s) = %f\n",(int)lname,name,value); }
  StringGC(jname);
  return value;
}

double m$get_dswitch_def_ (char *name, double *def, fstring_len_t lname) {
  Context *ctx  = getContext();
  jobject jname = fsw2jstr(ctx->env,name,lname);
  double  value = nm_get_dswitch_def(jname,*def);
  if (DEBUG) { printf("m$get_dswitch_def(%.*s,%f) = %f\n",(int)lname,name,*def,value); }
  StringGC(jname);
  return value;
}

void m$test_format_ (char *test_format, fstring_len_t ltest_format,
                     const char *format, const char *format_allow,
                     fstring_len_t lformat, fstring_len_t lformat_allow) {
  Context *ctx = getContext();
  jobject jformat = f2jstr(ctx->env,format,lformat);
  jobject jformat_allow = f2jstr(ctx->env,format_allow,lformat_allow);

  jobject jstr = nm_test_format(jformat,jformat_allow);
  fstring_len_t ls = j2fstr(ctx->env,jstr,test_format,ltest_format);
  if (DEBUG) { printf("m$test_format format=%.*s allow=%.*s result=%.*s len=%d\n",
    (int)lformat,format, (int)lformat_allow,format_allow, (int)ls,test_format, ls);
  }
  LocalGC(jstr);
  StringGC(jformat);
  StringGC(jformat_allow);

  if (ls==0) {
    char emsg[128];
    snprintf(emsg,128,"Format code '%.*s' disallowed! allow=%.*s checked in m$test_format",
      (int)lformat,format, (int)lformat_allow,format_allow);
    m_error(emsg);
  }
}


/*
  System Methods
*/

/** Initialize host command (e.g. native code Primitive)
    @param obj reference to the HPrimitive (Java object)
    @param nm  reference to NmJackets (Java object)
    @return 0 or positive on success, negative on error
    @since NeXtMidas 2.7.2
 */
int initCommand (JNIEnv *env, jobject obj, jobject nm, jint debuglevel) {
  int result = 0;    /* initially assume 0 for success */
  MCSTRUCT  *mc;
  MUSTRUCT  *mu;
  Context *ctx = getContext();
  jobject jcmdname;
  HEADER    hcb;
  int_4     ltmp = 0;

  xbcdebug = debuglevel;
  if (xbcdebug>0) printf("INFO: xbcdebug level = %d\n",xbcdebug);
  if (ctx == NULL) {
    fprintf(stderr, "ERROR: xmlibc.initCommand(): Can not getContext(..)!\n");
    return -1; /* error, -1 for null Context */
  }
  else if (env == NULL) {
    fprintf(stderr, "ERROR: xmlibc.initCommand(): JNIEnv is null!\n");
    return -2; /* error, -2 for null JNIEnv */
  }

  if (xbcdebug>2) printf("DEBUG: before Mc=%p  Mu=%p\n",Mc,Mu);
  /* Set Mc and Mu for use from C / C++ Primitive */
  mc = Mc = ctx->mc = &libMc;
  mu = Mu = ctx->mu = &libMu;
  if (xbcdebug>2) printf("DEBUG: after  mc=%p Mc=%p  mu=%p Mu=%p\n",mc,Mc,mu,Mu);

  /* check that Mc, Mu, and env are NOT NULL, otherwise error out */
  if (Mc == NULL || Mu == NULL || env == NULL) {
    fprintf(stderr, "ERROR: xmlibc.initCommand(): Can not set Mc or Mu! Mc=%p Mu=%pn",Mc,Mu);
    return -3; /* error, -3 for null Mc or Mu */
  }

  if (DEBUG) { fprintf(stderr, "mc=%p mu=%p\n",mc,mu); }
  mc->verify = 0;
  mc->debug  = 0;
  mc->break_ = 0;
  mc->beep   = 0;
  mc->status = 0;
  mc->mode   = nm_pipe_mode();
  mc->pause  = 0.001;
  mc->nformat[0] = 'G';
  mc->nformat[1] = 'E';
  mc->nformat[2] = 'N';
  mc->nformat[3] = ' ';
  mc->seed   = 12345678;
  mc->tolerance = 1.0e-6;
  mc->number_parameters = nm_number_parameters();
  mc->command_support = 'H';

  jcmdname = nm_command_name();
  j2fstr(ctx->env,jcmdname,mc->command_name,40);
  memcpy(mu->command_name,mc->command_name,40);

  /** set the current machine's data representation (endian) at compile time */
#if defined(_IEEE)
  strncpy(mc->machine, "IEEE", 4);
#elif defined(_EEEI)
  strncpy(mc->machine, "EEEI", 4);
#endif

  mc->plot_node[0]=0;
  mc->plot_node2[0]=0;
  mc->top         =          100;
  mc->left        =           10;
  mc->height      =          650;
  mc->width       =          700;
  mc->visClass    =           -1;
  mc->visDepth    =           -1;
  mc->visID       =           -1;

  /* The following 3 lines match those set by M$COMMAND_ENTRY in X-Midas 3.8.3 shell.for. */
  mu->alert   = !m$get_pswitch_("NOALERT", 7);
  mu->warn    = !m$get_pswitch_("NOWARN",  6);
  mu->verbose = !m$get_sswitch_("QUIET",   5);

  mu->id      = nm_id(); /* Set to -1 if /ID= is a string. */
  mu->todo    = -1;
  mu->okio    = TRUE;

  /* TBD: (1) Need to mimick behavior in X-Midas M$ALLOCATE and M$CLOSE to    */
  /*          to set Mu.file and Mu.files appropriately.                      */
  /*      (2) Need to set Mu.spawn appropriately (0 is just a guess).         */
  mu->files   = 0;
  mu->spawn   = 0;

  m$vinit_();  /* fix for Bug 1506, call M$VINIT to match X-Midas's behavior */

  updateAuxEntries();

  rfindString("AUX.HOMEPATH", mc->home_path,  256);
  rfindString("AUX.HOME",     mc->login_path,  60);
  rfindString("ENV.USER",     mc->read_id,     60);
  rfindString("ENV.USER",     mc->write_id,    60);
  rfindString("ENV.USER",     mc->user_id,      8);
  rfindString("ENV.OSTYPE",   mc->OS_type,      4);
  /* TODO: map this value? and remove truncation warning? rfindString("ENV.OSNAME", mc->OS_name, 4); */
  /* TODO: truncate and only get hostname portion? rfindString("ENV.HOSTNAME", mc->hostname, 16); */

  if (mc->command_name[0]=='X') {
    ltmp=0;
    const char* xcolorfn = "nxm.xbc.dat.xcolornew";
    m$init_(&hcb,xcolorfn,"2000","4I",&ltmp,strlen(xcolorfn),4,2); /* 4=strlen("2000"), 2=strlen("4I") */
    m$inok_(&hcb);
    if (hcb.open) {
      ltmp = -1;
      m_grab(&hcb, &mc->colormap, 1.0, 4, &ltmp);
      m$close_(&hcb);
    } else {
      printf("Err opening color file: %s\n",hcb.file_name);
    }
  }

  if (xbcdebug>1) { printf("INFO: initCommand Mc pause=%f \n",mc->pause); }

  return result; /* 0 for success */
}

/** This should only be called by C/C++ Primitives.
 *  This is called after initCommand() so Mc and Mu have been initialized.
 *  This method updates the host primitive's state to HOST_CHECKIN to follow proper state transition.
 *  @since NeXtMidas 2.7.2
 */
void m_checkin () {
  Context *ctx = getContext();

  /* since 3.1.2: Set pMc (and hence Mc) and pMu (and hence Mu) for use from Fortran APIs */
  M_PTR mcPtr;
  M_PTR muPtr;
  mcPtr.p = (M_PTR_T)Mc;
  muPtr.p = (M_PTR_T)Mu;
  m$xbc_setcommons_(&mcPtr, &muPtr); /* set pMc and pMu (this has to be done in Fortran) */

  nm_setHostState(HOST_CHECKIN);
  if (xbcdebug>1) printf("DEBUG: m_checkin() Updated Host Primitive state to %ld\n", HOST_CHECKIN);
}

/** XFPP always translates M$CHECKIN to M$CHKIN(pMc,pMu) because we need to pass the shared
    references for Mc and Mu in for initialization. This method will ONLY get called in the
    case of a failed compile.
 */
void m$checkin_ () {
  Context *ctx = getContext();
  fprintf(stderr, "ERROR: File was incorrectly compiled, m$checkin should have been replaced by m$chkin(pMc,pMu)\n");
  nm_setHostState(HOST_DONE);
}

/** This should only be called by Fortran Primitives.
 *  This is called after initCommand() so Mc and Mu have been initialized.
 *  This method updates the host primitive's state to HOST_CHECKIN to follow proper state transition.
 */
void m$chkin_ (MCSTRUCT **pmc, MUSTRUCT **pmu) {
  M_PTR      mcPtr;  /* for setting Fortran host Primitive's pMc */
  M_PTR      muPtr;  /* for setting Fortran host Primitive's pMu */
  MCSTRUCT  *mc     = Mc;
  MUSTRUCT  *mu     = Mu;
  Context   *ctx    = getContext();

  /* Set Mc and Mu for use from Fortran Primitive */
  mcPtr.p = (M_PTR_T)mc;
  muPtr.p = (M_PTR_T)mu;
  m$xbc_setcommons_(&mcPtr,&muPtr); /* set pMc and pMu (this has to be done in Fortran) */
  *pmc = mc; /* set Mc (this cannot be done in Fortran, since it does not support pointer to pointer) */
  *pmu = mu; /* set Mu (this cannot be done in Fortran, since it does not support pointer to pointer) */

  if (xbcdebug>1) { printf("m$chkin Mc=%p=%p Mu=%p=%p\n",ctx->mc,mc,ctx->mu,mu); }

  nm_setHostState(HOST_CHECKIN);
}

void m$sync_ () {
  Context *ctx = getContext();
  nm_setHostState(HOST_SYNC);
}

void m$return_ () {
  Context *ctx = getContext();
  nm_setHostState(HOST_RETURN);
  m$freeall_();
}

void m$todo_ (double *todo) {
  Context *ctx = getContext();
  ctx->todo = *todo;
}

bool_4 m$do_ (int_4 *lper, int_4 *ndo) {
  Context *ctx = getContext();
  bool_4 status = FALSE;

  if (ctx->mc->break_) return FALSE;

  if (ctx->isPiped) {
    status = nm_getHostState();
    if (status!=HOST_PROCESS) return FALSE;
    status = nm_getPipeMode();
    if (status==PSTOP || status==POFF) return FALSE;
  }
  /*printf("m$do=%f mode=%x\n",ctx->todo,status);*/
  if (ctx->todo == -1) {
    *ndo = *lper;
  }
  else if (ctx->todo == 0) {
    *ndo = 0;
    return FALSE;
  }
  else if (ctx->todo >= *lper) {
    *ndo = (*lper);
    ctx->todo -= (*lper);
  }
  else {
    *ndo = (int)ctx->todo;
    ctx->todo = 0;
  }
  /* since 2.9.2, return Mu.okio (TRUE most of the time) field for BUG 2375 */
  return Mu->okio;
}

void m$didnt_ (int_4 *ndidnt) {
  Context *ctx = getContext();
  ctx->todo += (*ndidnt);
}

/*
  Control widgets
*/
int_4 winit (char *name, fstring_len_t lname, int_4 type, int_4 lval, double dval, char *list, fstring_len_t llist) {
  Context *ctx = getContext();
  int_4 j, i = ctx->ncontrols++;
  jobject jname;

  if (i>=MAXCONTROLS) return 0;
  f2fstr(ctx->env, name,lname, ctx->controls[i].name,16);
  for (j=0; j<lname; j++) if (name[j]==' '&&name[j+1]>' ') ctx->controls[i].name[j]='_';
  ctx->controls[i].type = type;
  ctx->controls[i].lval = lval;
  ctx->controls[i].dval = dval;
  ctx->controls[i].list = list;
  ctx->controls[i].llist = llist;
  if (DEBUG) { printf("m$winit name=%.*s type=%d lval=%d dval=%lf\n",(int)lname,name,type,lval,dval); }

  jname = f2jstr(ctx->env,name,lname);
  nm_winit (ctx->ncontrols,jname);
  StringGC(jname);

  return ctx->ncontrols;
}

int_4 m$mwinit_ (char *name, int_4 *msel, char *list, fstring_len_t lname, fstring_len_t llist) {
  fstring_len_t i;
  for (i=0; list[i]!=';' && i<llist; i++);
  if (i<llist) { i++; list+=i; llist-=i; }
  return winit(name,lname,1, *msel,0.0, list,llist);
}

int_4 m$lwinit_ (char *name, int_4 *vdef, int_4 *vmin, int_4 *vmax, int_4 *vinc, fstring_len_t lname) {
  return winit(name,lname,2, *vdef,0.0, 0,0);
}

int_4 m$fwinit_ (char *name, float *vdef, float *vmin, float *vmax, float *vinc, fstring_len_t lname) {
  return winit(name,lname,3, 0,*vdef, 0,0);
}

int_4 m$dwinit_ (char *name, double *vdef, double *vmin, double *vmax, double *vinc, fstring_len_t lname) {
  return winit(name,lname,4, 0,*vdef, 0,0);
}

int_4 m$mwget_ (int_4 *id, int_4 *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == ctx->controls[*id-1].lval) return 0;
  *value = ctx->controls[*id-1].lval;
  return 1;
}

int_4 m$lwget_ (int_4 *id, int_4 *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == ctx->controls[*id-1].lval) return 0;
  *value = ctx->controls[*id-1].lval;
  return 1;
}

int_4 m$fwget_ (int_4 *id, float *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == (float)ctx->controls[*id-1].dval) return 0;
  *value = (float)ctx->controls[*id-1].dval;
  return 1;
}

int_4 m$dwget_ (int_4 *id, double *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == ctx->controls[*id-1].dval) return 0;
  *value = ctx->controls[*id-1].dval;
  return 1;
}

int_4 m$mwput_ (int_4 *id, int_4 *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == ctx->controls[*id-1].lval) return 0;
  ctx->controls[*id-1].lval = *value;
  return 1;
}

int_4 m$lwput_ (int_4 *id, int_4 *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == ctx->controls[*id-1].lval) return 0;
  ctx->controls[*id-1].lval = *value;
  return 1;
}

int_4 m$fwput_ (int_4 *id, float *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == (float)ctx->controls[*id-1].dval) return 0;
  ctx->controls[*id-1].dval = *value;
  return 1;
}

int_4 m$dwput_ (int_4 *id, double *value) {
  Context *ctx = getContext();
  if (*id <= 0 || *value == ctx->controls[*id-1].dval) return 0;
  ctx->controls[*id-1].dval = *value;
  return 1;
}


/*
  Results methods
*/
int_4 m$get_result_ (char *name, void *value, int_4 *buflen, int_4 *modemask,
                     char *type, int_4 *attrmask, fstring_len_t lname, fstring_len_t ltype) {
  Context *ctx  = getContext();
  JNIEnv  *env  = ctx->env;
  jobject jname = f2jstr(ctx->env,name,lname);
  jobject jbuf  = nm_get_result(jname);
  int_4   bytes = -1;
  int_4   lres  = 0;
  int_4   i     = 0;

  *attrmask = 0;

  if (jbuf == NULL) {
    *type = ' ';
    bytes = -1;

  } else {
    lres  = (*env)->GetArrayLength(env, jbuf);
    bytes = lres-1;
    if (bytes > *buflen) {
      m_warning("m$get_result: Length of result exceeds buffer length, truncating results value.");
      bytes = *buflen;
    }

    (*env)->GetByteArrayRegion(env, jbuf, 0, 1,     (jbyte*)type);
    (*env)->GetByteArrayRegion(env, jbuf, 1, bytes, (jbyte*)value);
  }

  StringGC(jname);
  LocalGC(jbuf);
  return bytes;
}

int_4 m$put_result_ (char *name, void *value, int_4 *buflen, int_4 *modemask,
                     char *type, int_4 *attrmask, fstring_len_t lname, fstring_len_t ltype) {
  Context *ctx = getContext();
  JNIEnv  *env = ctx->env;
  jobject jstr = f2jstr(ctx->env,name,lname);
  jobject jbuf = c2jbuf(ctx->env,value,*buflen);
  int_4   res  = 0;

  res = nm_put_result(jstr, *type, jbuf);
  StringGC(jstr);
  LocalGC(jbuf);
  return res;
}

/* This typedef copied from nxm/sys/lib/Native.c */
typedef union {
  jdouble *dbuf;
  jfloat  *fbuf;
  jlong   *xbuf;
  jint    *lbuf;
  jshort  *ibuf;
  jbyte   *bbuf;
} buffer_t;

void m$rfind_ (char *type, fstring_len_t ltype, char *name, char *aval, double *dval, fstring_len_t lname, fstring_len_t laval) {
  int_4 modemask = 0;
  int_4 attrmask = 0;
  int_4 bytes    = 0;
  int_4 lvalue   = max(sizeof(double), laval);
  buffer_t value;

  value.bbuf = malloc(lvalue);

  if (DEBUG) { fprintf(stderr, "XMLIBC.C: M$RFIND: try to find '%.*s'\n", (int)lname, name); }
  bytes = m$get_result_(name, value.bbuf, &lvalue, &modemask, type, &attrmask, lname, 1);

  if (bytes < 0) {
    *type = ' ';
  }
  if (DEBUG) { fprintf(stderr, "XMLIBC.C: M$RFIND: bytes=%d type=%c\n", bytes, *type); }

  if (*type == ' ') {
    /* Do nothing */
  } else if (*type == 'A') {
    memset(aval, ' ', laval);    /* Clear previous string */
    memcpy(aval, value.bbuf, bytes);  /* Write new string */
    *dval = bytes;

  } else {
    switch(*type) {
      case 'D': *dval = (double)value.dbuf[0]; break;
      case 'F': *dval = (double)value.fbuf[0]; break;
      case 'X': *dval = (double)value.xbuf[0]; break;
      case 'L': *dval = (double)value.lbuf[0]; break;
      case 'I': *dval = (double)value.ibuf[0]; break;
      case 'B': *dval = (double)value.bbuf[0]; break;
      default:  m_error("m$rfind: Unknown result type found."); break;
    }
  }
  free(value.bbuf);
}

int_4 m$del_result_ (char *name, int_4* mask, fstring_len_t lname) {
  Context *ctx  = getContext();
  jobject jname = f2jstr(ctx->env,name,lname);
  nm_del_result(jname);
  StringGC(jname);
  return 1; /* Num deleted */
}

/** Internal use only: double an M$RFIND for a string. */
static void rfindString (char *resname, char *dest, fstring_len_t ldest) {
  char     msg[128];
  char     type;
  double   dval;

  m$rfind_(&type, 1, resname, dest, &dval, strlen(resname), ldest);
  if (type != 'A') {
    snprintf(msg, 128, "XBC: Error: Unable to access %s (type=%c)", resname, type);
    m_warning(msg);
    dest[0] = 0;
  }
}

/** Calls m$put_result_ but calls m_error if there is an error. */
static void try_m$put_result_ (char *name, void *value, int_4 *buflen, int_4 *modemask,
                              char *type, int_4 *attrmask, fstring_len_t lname, fstring_len_t ltype) {
  int_4 bytes = m$put_result_(name, value, buflen, modemask, type, attrmask, lname, ltype);
  if (bytes < -1) m_error("Failed to set result.");
}

void m$arslt_ (char *name, char *value, fstring_len_t lname, fstring_len_t lvalue) {
  int_4 lv=lvalue, mm=0, am=0; char type='A';
  try_m$put_result_ (name, (void *)value, &lv, &mm, &type, &am, lname, 1);
}
void m$drslt_ (char *name, double *value, fstring_len_t lname) {
  int_4 lv=8, mm=0, am=0; char type='D';
  try_m$put_result_ (name, (void *)value, &lv, &mm, &type, &am, lname, 1);
}
void m$frslt_ (char *name, float *value, fstring_len_t lname) {
  int_4 lv=4, mm=0, am=0; char type='F';
  try_m$put_result_ (name, (void *)value, &lv, &mm, &type, &am, lname, 1);
}
void m$lrslt_ (char *name, int_4 *value, fstring_len_t lname) {
  int_4 lv=4, mm=0, am=0; char type='L';
  try_m$put_result_ (name, (void *)value, &lv, &mm, &type, &am, lname, 1);
}
void m$irslt_ (char *name, int_2 *value, fstring_len_t lname) {
  int_4 lv=2, mm=0, am=0; char type='I';
  try_m$put_result_ (name, (void *)value, &lv, &mm, &type, &am, lname, 1);
}
void m$brslt_ (char *name, int_1 *value, fstring_len_t lname) {
  int_4 lv=1, mm=0, am=0; char type='B';
  try_m$put_result_ (name, (void *)value, &lv, &mm, &type, &am, lname, 1);
}
void m$trslt_ (char *name, double *wsec, double *fsec, fstring_len_t lname) {
  double    sec  = (*wsec) + (*fsec);
  int_4     i    =  0; /* Loop counter */
  int_4     j    = -1; /* Index of '|' (-1=use sec, -2=use str) */
  char      type = 'X';
  char      str[128];
  fstring_len_t lstr = 0;

  if ((lname > 2) && (name[0] == 'A') && (name[1] == ':')) {
    j = -2;
    type  = 'X';
    name  = name+2;
    lname = lname-2;
  } else if ((lname > 3) && (name[0] == 'T') && (name[2] == ':')) {
    j = -2;
    type  = name[1];
    name  = name+3;
    lname = lname-3;
  } else {
    for (i = 0; (i < lname) && (j == -1); i++) {
      if (name[i] == '|') { j = i; }
    }
  }

  if (j == -2) {
    lstr = m$times2str_(wsec, fsec, &type, str, 1, 128);
    m$arslt_(name, str, lname, lstr);
  } else if (j == -1) {
    m$drslt_(name, &sec, lname);
  } else {
    m$drslt_(name, wsec, j);
    m$drslt_(name+j+1, fsec, lname-j-1);
  }
}
int_4 m$str2result_ (char *name, char *value, int_4 *attrmask, fstring_len_t lname, fstring_len_t lvalue) {
  int_4 lv=1, mm=0, am=0; char type=' ';
  int_4 len = m$length_(value, lvalue);
  return m$put_result_ (name, value, &len, &mm, &type, &am, lname, 1);
}
void m$rcast_ (char *type, char *name, double *value, fstring_len_t ltype, fstring_len_t lname) {
  char  str[128];
  void  *buf = value;
  int_4 lbuf = 8;
  int_4 mask = 0;
  char  dtyp = 'D';
  int_4 attr = 0;

  lname  = min(lname, 126);
  str[0] = type[0];
  str[1] = ':';
  memcpy(&(str[2]), name, lname);

  if ((str[0] == '_') || (str[0] == ' ')) { str[0] = 'D'; }

  m$put_result_(str, buf, &lbuf, &mask, &dtyp, &attr, lname+2, ltype);
}
int_4 m$rdel_ (char *name, fstring_len_t lname) {
  int_4 mask = 0;
  /* m_deprecate("M$RDEL: M$RDEL was deprecated prior to X-Midas 3.8.3, use M$DEL_RESULT."); */
  return m$del_result_(name, &mask, lname);
}


/*
  AUX methods
*/
static void updateAuxEntries () {
  Context *ctx = getContext();
  JNIEnv  *env = ctx->env;
  jarray  jbuf = nm_getAuxEntries();
  int_4   len  = 0;

  if (jbuf != NULL) {
    len = (*env)->GetArrayLength(env, jbuf);
    ctx->mc->read_auxs = MIN(L_auxs, len-1);
    (*env)->GetIntArrayRegion(env, jbuf, 0, 1,                   (jint*)&(ctx->mc->write_aux));
    (*env)->GetIntArrayRegion(env, jbuf, 1, ctx->mc->read_auxs , (jint*)  ctx->mc->read_aux  );

    LocalGC(jbuf);
  }
}

int_4 m$valid_aux_ (int_4 *auxindex) {
  Context *ctx = getContext();
  return nm_valid_aux(*auxindex);
}

int_4 m$get_aux_path_ (int_4 *aux, char *auxpath, fstring_len_t lauxpath) {
  Context *ctx = getContext();
  jobject jstr = nm_get_aux_path(*aux);
  fstring_len_t ls = -1;

  if (jstr == NULL) {
    ls = -1;
    memset(auxpath, ' ', lauxpath);
  } else {
    ls = j2fstr(ctx->env,jstr,auxpath,lauxpath);
    LocalGC(jstr);
  }

  return ls;
}

int_4 m$add_read_aux_ (int_4 *raux, int_4 *pos) {
  Context *ctx = getContext();
  int_4 status = nm_add_read_aux(*raux, *pos);
  updateAuxEntries();
  return status;
}

int_4 m$del_read_aux_ (int_4 *raux) {
  Context *ctx = getContext();
  int_4 status = nm_del_read_aux(*raux);
  updateAuxEntries();
  return status;
}

void m$clear_read_auxlist_ () {
  Context *ctx = getContext();
  nm_clear_read_auxlist();
  updateAuxEntries();
}

int_4 m$define_aux_ (int_4 *aux, char *auxpath, fstring_len_t lauxpath) {
  Context *ctx = getContext();
  jobject jstr = f2jstr(ctx->env,auxpath,lauxpath);
  int_4 status = nm_define_aux(*aux, jstr);
  LocalGC(jstr);
  return status;
}

/*
  IO methods
*/
void m$initialize_ (HEADER *hcb) {
  Context *ctx = getContext();
  memcpy ((void*)hcb,(void*)hcbInit,512);
  hcb->lph = nm_alloc();

  /* internals header fields that have important defaults (Bug 1887) */
  hcb->head_lu         = hcb->file_lu = -1;
  hcb->output          = 0;
  hcb->offset          = 0.0;
  hcb->size            = 0.0;
  hcb->first_byte      = 0.0;
  hcb->last_byte       = hcb->data_start;
  hcb->last_bits       = 0;
  hcb->ext_alloc       = 0;
  hcb->ext_scope_start = -1;
  hcb->t6subr_alloc    = 0;
  hcb->savebuf_len     = 0;
  c2fstr(ctx->env, "", hcb->switches,8);   /* hcb->switches  = ' '; */
  c2fstr(ctx->env, "", hcb->qualifier,40); /* hcb->qualifier = ' '; */
  hcb->open            = 0;
  hcb->class           = 1;
  hcb->flush           = 0;
  hcb->buffer_block    = -1;
  /* end of internals header fields that have important defaults (Bug 1887) */
}

void m$init_ (HEADER *hcb, const char *name, const char *types, const char *formats, int_4 *modifiers,
              fstring_len_t lname, fstring_len_t ltypes, fstring_len_t lformats) {
  Context *ctx = getContext();
  double  type = 0.0;
  m$initialize_(hcb);
  f2fstr(ctx->env, name,    lname,    hcb->file_name,   80);
  f2fstr(ctx->env, types,   ltypes,   hcb->type_allow,  40);
  f2fstr(ctx->env, formats, lformats, hcb->format_allow,40);

  /* JC4: The next section matches undocumented functionality of M$INIT in X-Midas*/
  if (m$length_(types, ltypes) == 4) {
    m$a2d_(types, &type, ltypes);
    hcb->type = (int)type;
  }
  if (m$length_(formats, lformats) == 2) {
    f2fstr(ctx->env, formats, lformats, hcb->format, 2);
  }
}

void m$propagate_ (HEADER *hcbi, HEADER *hcbo) {
  Context *ctx = getContext();
  /* propagate main header */
  memcpy ((void*)hcbo,(void*)hcbi,512);
  hcbo->data_size = 0.0; /* NTN: matches xm444 */
  /* internals header fields that have important defaults */
  hcbo->size = hcbi->size;
  hcbo->class = hcbi->class;
  hcbo->ext_size = 0;
  hcbo->ext_start = 0;
  hcbo->ext_alloc = 0;
  hcbo->ext_scope_start = -1;
  hcbo->t6subr_alloc = 0; /* NTN: matches xm444 */
  hcbo->savebuf_len = 0;
  hcbo->open = 0;
  hcbo->protected = 0;
  c2fstr(ctx->env, "", hcbo->switches,8);
  c2fstr(ctx->env, "", hcbo->qualifier,40);
  /* remember where the extended headers are to be copied over from */
  hcbo->ext_loc = hcbi->lph;
}

void m$hcbfunc_ (HEADER *hcb, int_4 *func, int_4 *args);

static void m$open (HEADER *hcb, int_4 flags) {
  Context *ctx     = getContext();
  jobject jname    = f2jstr(ctx->env,hcb->file_name,80);
  jobject jtypes   = f2jstr(ctx->env,hcb->type_allow,40);
  jobject jformats = f2jstr(ctx->env,hcb->format_allow,40);
  jint    jflags   = 0;
  jint    append   = 0;
  jint    output   = -1;
  jint    inout    = (flags&HCBF_INPUT) && (flags&HCBF_OUTPUT);
  jint    id       = -1;
  int_4   hcbfunc  = 0;
  int_4   hcbargs  = 0;
  char    str[128]; /* Temp output string. */

  if (DEBUG_IO) { printf("M$OPEN: %.*s called with flags 0x%x\n",80,hcb->file_name,flags); }

  if (strncmp(hcb->switches, "OPTIONAL", 8) == 0) { flags |= HCBF_OPTIONAL; }

  /* convert HCB flags to DataFile flags */
       if (inout            ) { jflags |= 0x03; output = 1; append = 0; }
  else if (flags&HCBF_INPUT ) { jflags |= 0x01; output = 0; append = 0; }
  else if (flags&HCBF_OUTPUT) { jflags |= 0x02; output = 1; append = 0; }
  else if (flags&HCBF_APPEND) { jflags |= 0x08; output = 1; append = 1; }
  else                        { jflags |= 0x01; output = 0; append = 0; }

  if (flags&HCBF_FLUSH   ) jflags |= 0x10;
  if (flags&HCBF_NOABORT ) jflags |= 0x20;
  if (flags&HCBF_OPTIONAL) jflags |= 0x40;

  if (output == -1) {
    m_warning("M$OPEN: File is not marked as input or output file, assume input.");
    flags = flags|HCBF_INPUT;
    jflags |= 0x01;
    output = 0;
  }

  /* JC4: We set hcb->lph to hold the ID for the NeXtMidas DataFile object (prior to NeXtMidas 2.5.0
          this was a pointer to the Java object, but that was a bad idea), NmJackets then handles
          the translation from ID to DataFile object.

          We set hcb->lph as follows:
            hcb->lph > 0   - Valid DataFile (m$open or m$init called, but not m$close)
            hcb->lph = 0   - Not yet initialized (m$open not called yet), this is the
                             default for an HCB in the Fortran
            hcb->lph < 0   - Closed DataFile (m$open and then m$close called). If hcb->lph=N
                             when valid, set it to hcb->lph=-N now to allow us to detect when
                             a file is used after being closed. (for debugging purposes)
   */
//ORIG  if (hcb->lph==0) hcb->lph = nm_alloc();
//ORIG  nm_init (hcb->lph,jname,jtypes,jformats,jflags);
  hcb->lph = nm_init(hcb->lph,jname,jtypes,jformats,jflags);
  hcb->output = output;

  /* NTN: For OUTPUT ONLY file, use local machine header and data representation.
          Need to reset head_rep and data_rep in HCB (since M$PROPAGATE can be
          called before M$ALLOCATE or M$OPEN. This mimics X-Midas's M$ALLOCATE
          behavior which is called my M$OPEN for output only file. Bug 1616.
   */
  if (!(flags&HCBF_INPUT) && output) {
      strncpy(hcb->head_rep, ctx->mc->machine, 4);
      strncpy(hcb->data_rep, ctx->mc->machine, 4);
  }

  /* JC4: Need to copy the main header of an output or in-out file from HCB into
          DataFile before the file can be opened.
  */
  if (hcb->output) {
    nm_copyMain(hcb->lph,(jlong)(jpointer)hcb,-1); /* copy HCB main into class variables */
  }
  hcb->open = nm_open(hcb->lph)? 1 : 0;
  if (DEBUG_IO) { printf("M$OPEN: %.*s hcb.open=%d (ID=%d)\n",80,hcb->file_name,hcb->open,hcb->lph); }

  if (hcb->open) {
    /* CDC: For an output or in-out file, the presence of a positive ext_loc indicates there
            are extended keywords in the indicated source file which need to be propagated into
            this file.  Now that this file exists and is open, it's time to perform that copy.
    */
    if (output && hcb->ext_loc>0) {
      int result = nm_propagateExtKeywords(hcb->ext_loc, hcb->lph);
      if (result) {
        printf("M$OPEN: Failed to propagate extended keywords from (ID=%d) into (FILENAME=%.*s)\n", hcb->ext_loc, 80, hcb->file_name);
      }
      hcb->ext_loc = 0;
    }

    /* JC4: Need to copy the main header of an input or in-out file from DataFile
            into the HCB before hcb->type or hcb->format can be used.
    */
    if ((flags&HCBF_INPUT) || append) {
      hcb->size = nm_getSize(hcb->lph);
      nm_copyMain(hcb->lph,(jlong)(jpointer)hcb,1); /* copy class variables into HCB main */
    }
    hcb->bps  = nm_getBPS(hcb->lph);
    hcb->spa  = nm_getSPA(hcb->lph);
    hcb->ape  = nm_getAPE(hcb->lph);
    hcb->bpa  = hcb->bps * hcb->spa;
    hcb->dbpe = nm_getBPE(hcb->lph);
    hcb->bpe  = (int_4)hcb->dbpe;
    if (hcb->bpe==0) hcb->bpe = (int_4)(-8*hcb->dbpe);
    hcb->class    = hcb->type/1000;
    hcb->buf_mode = hcb->format[0];
    hcb->buf_type = hcb->format[1];
    hcb->xfer_len = 0;
    hcb->cons_len = -1;
    hcb->offset   = nm_getSeek(hcb->lph); /* Bug 1745 - update offset to current in DataFile */
    /* Initialize other hcb fields - match XMidas code - Since 3.5.2 Bug 2773 */
    hcb->first_byte = hcb->data_start;
    hcb->last_byte = hcb->data_size + hcb->data_start;
    /* do fix up for bit data */
    hcb->last_bits = (int)(fmod(hcb->last_byte,1.0) * 8);
    if (hcb->last_bits > 0) {
    	hcb->last_byte = (int)(hcb->last_byte) + 1;
    	hcb->last_bits = hcb->last_bits - 8;
    }
  } else {
    /* JC4: Should I do anything here? */
    if ((flags&HCBF_INPUT) && !(flags&HCBF_NOABORT) && !(flags&HCBF_OPTIONAL)) {
      snprintf(str, 128, "M$OPEN: could not open file %.*s (ID=%d)",80,hcb->file_name,hcb->lph);
      m_error(str);
    }
  }
  if (DEBUG_IO) { printf("M$OPEN: %.*s done (ID=%d, Mc.break=%d)\n",80,hcb->file_name,hcb->lph,ctx->mc->break_); }

  StringGC(jname);
  StringGC(jtypes);
  StringGC(jformats);
}

void m$open_ (HEADER *hcb, int_4 *flags) {
  m$open(hcb,*flags);
}

void m$update_header_ (HEADER *hcb) {
  Context *ctx = getContext();
  if (hcb->open!=0) {
    nm_copyMain(hcb->lph,(jlong)(jpointer)hcb,-2);
  }
}

void m$close_ (HEADER *hcb) {
  Context *ctx = getContext();
  if (DEBUG_IO) { printf("M$CLOSE: %.*s closing DataFile=%d\n",80,hcb->file_name,hcb->lph); }
  if (hcb->open   == 0) return;
  if (hcb->output == 1) {
    nm_copyMain(hcb->lph,(jlong)(jpointer)hcb,-1);
    nm_flush(hcb->lph);
  }
  nm_close(hcb->lph);
  if (hcb->lph > 0) {
    hcb->open = 0;
    hcb->lph  = -hcb->lph; /* JC4: Set hcb->lph, see M$OPEN(..) for details. */
  }
}

void m$inok_ (HEADER *hcb) {
  m$open(hcb,HCBF_INPUT);
  int_4 fnamelen = m$length_(hcb->file_name, 80);
  int isOptional = (strncmp(hcb->switches,"OPTIONAL",8)==0) && (fnamelen==0); /* fix Bug 1515 */
  if (!hcb->open && !isOptional) {
    char msg[128];
    snprintf(msg,128,"M$INOK: could not open file %.*s (ID=%d)",fnamelen,hcb->file_name,hcb->lph);
    m_warning(msg);
  }
}

void m$inokw_ (HEADER *hcb) {
  m$open(hcb,HCBF_INPUT|HCBF_OUTPUT);
  if (!hcb->open) {
    char msg[128];
    int_4 fnamelen = m$length_(hcb->file_name, 80);
    snprintf(msg, 128, "M$INOKW: could not open file %.*s (ID=%d)",fnamelen,hcb->file_name,hcb->lph);
    m_warning(msg);
  }
}

void m$allocate_ (HEADER *hcb) {
  m$open(hcb,HCBF_OUTPUT);
}

void m$existence_ (HEADER *hcb, int_4 *dir) {
  Context *ctx  = getContext();
  JNIEnv  *env  = ctx->env;
  jobject jbuf  = NULL;
  jbuf = c2jbuf(ctx->env, hcb->file_name, 80);
  hcb->exist = nm_existence(jbuf, *dir);
  (*env)->GetByteArrayRegion(env, jbuf, 0, 80, (jbyte*)hcb->file_name);
  LocalGC(jbuf);
}

void m$force1000_ (HEADER *hcb) {
  Context *ctx = getContext();
  if (hcb->open==0) return;
  if (hcb->type==3 || hcb->type==5 || hcb->type==6) {
    if (hcb->format[0]=='N' && hcb->format[1]=='H')
      m_error("Cannot M$FORCE1000 type 3000, 5000 and 6000 files with NH format");
  }
  nm_setDFS(hcb->lph,0);
  hcb->ape  = 1;
  hcb->bpe  = hcb->bpa;
  hcb->dbpe = nm_getBPE(hcb->lph);
  hcb->size = nm_getSize(hcb->lph);
}

void m$force2000_ (HEADER *hcb, int_4 *fs) {
  Context *ctx = getContext();
  int_4 lfs = abs(*fs);
  if (hcb->open==0) return;
  m$force1000_(hcb);
  if (lfs == 0) {
    hcb->type = 1000;
    hcb->class = 1;
  } else {
    nm_setDFS(hcb->lph,lfs);
    hcb->adjunct.t2.subsize = lfs;
    hcb->size = hcb->size / lfs;
    hcb->bpe  = hcb->bpe  * lfs;
    hcb->dbpe = hcb->dbpe * lfs;
    hcb->ape  = lfs;
    if (lfs<0) {
      hcb->type = 2000;
      hcb->class = 2;
      hcb->adjunct.t2.yunits = hcb->adjunct.t2.xunits;
      hcb->adjunct.t2.ystart = hcb->adjunct.t2.xstart;
      hcb->adjunct.t2.ydelta = hcb->adjunct.t2.xdelta * lfs;
    }
  }
}

/** Adds a qualifier to a file name.
    @param hcb  The HCB.
    @param qual The qualifier (a C string).
*/
static void add_qual (HEADER *hcb, char *qual) {
  char  *fname  = hcb->file_name;
  int_4  lfname = m$length_(fname, 80);
  size_t lqual  = strlen(qual);

  if (lfname + lqual >= 80) {
    m_error("File name is too long.");
  } else {
    memcpy(&(fname[lfname]), qual, lqual);
  }
}

/** Gets a qualifier from a file name.
    @param hcb  The HCB.
    @param qual The qualifier name.
*/
int_4 m$get_qualifier_ (HEADER *hcb, char *name, fstring_len_t lname) {
  return -1;
}

int_4 m$get_uqualifier_ (HEADER *hcb, char *name, char *value, fstring_len_t lname, fstring_len_t lvalue) {
  return -1;
}

void m$hcbfunc_ (HEADER *hcb, int_4 *func, int_4 *args) {
  Context *ctx = getContext();
  char    temp[128];
  jint    avail;
  jint    skip;

  switch(*func) {
    case HCBF_CTG:
      if (hcb->open!=0) m_warning("M$HCBFUNC: HCBF_CTG used on an open file.");
      add_qual(hcb, "(CTG=1)");
      break;
    case HCBF_AUX:
      if (hcb->open!=0) m_warning("M$HCBFUNC: HCBF_AUX used on an open file.");
      snprintf(temp, 128, "(AUX=%d)", args[0]);
      add_qual(hcb, temp);
      break;
    case HCBF_WAIT:
      if (hcb->open!=0) m_warning("M$HCBFUNC: HCBF_WAIT used on an open file.");
      add_qual(hcb, "(WAIT=1)");
      break;
    case HCBF_SAM: /* The addition of "(OD=1)" is not documented in X-Midas. */
      if (hcb->open!=0) m_warning("M$HCBFUNC: HCBF_SAM used on an open file.");
      add_qual(hcb, "(CTG=1)(AUX=SAMAUX)(OD=1)");
      break;
    case HCBF_PS: /* This is not documented in X-Midas. */
      if (hcb->open!=0) m_warning("M$HCBFUNC: HCBF_PS used on an open file.");
      snprintf(temp, 128, "(PS=%d)", args[0]);
      add_qual(hcb, temp);
      break;
    case HCBF_FLUSH:
      if (hcb->open==0) return;
      if (DEBUG) { printf("m$hcbfunc:Calling DataFile.flush() .. "); }
      nm_flush(hcb->lph);
      if (DEBUG) { printf("Done\n"); }
      break;
    case HCBF_APPEND:
      hcb->offset = hcb->size;
      nm_seek(hcb->lph, hcb->offset);
      if ((hcb-> type / 1000) != 4) {
    	/* Handle Packed Bits and Nibble Packed Bits - Since 3.5.2 BUG 2773 */
    	double last_byte_bits = hcb->data_start + (hcb->size*hcb->dbpe);
    	hcb->last_byte = (int)last_byte_bits;
        if (hcb->format[1] == 'P') {
          /* since fractional numbers may not be exact, round up */
          hcb->last_bits = (int)((last_byte_bits - hcb->last_byte)*8 + 0.5);
        } else if (hcb->format[1] == 'N'){
          hcb->last_bits = (int)((last_byte_bits - hcb->last_byte)*2 + 0.5);
        }
      } else if (FALSE) { /* JC4: Should be hcb.pkt.packetized */
        m_warning("M$HCBFUNC: No support for HCBF_APPEND on packetized files.");
      }
      break;
    case HCBF_REOPEN: /* This is how X-Midas does it, not NeXtMidas. */
      m$close_(hcb);
      m$inokw_(hcb);
      break;
    case HCBF_LASTBYTE:
      hcb->last_byte = hcb->data_start + (hcb->size * hcb->dbpe);
      break;
    case HCBF_PRESERVE: /* This is nearly meaningless in NeXtMidas. */
      f2fstr(ctx->env, "PRESERVE", 8, hcb->switches, 8);
      break;
    case HCBF_AVAIL:
      if (hcb->open==0) return;
      if (DEBUG) { printf("m$hcbfunc:Calling DataFile.avail() .. "); }
      avail = (jint)nm_avail(hcb->lph);
      *args = avail;
      if (DEBUG) { printf("Done (%d available)\n", avail); }
      break;
    case HCBF_SKIP:
      if (hcb->open==0) return;
      if (DEBUG) { printf("m$hcbfunc:Calling DataFile.skip(%d) .. ", *args); }
      skip = nm_skip(hcb->lph, *args);
      hcb->offset = nm_getSeek(hcb->lph); /* Bug 1745 - update offset to current in DataFile */
      if (DEBUG) { printf("Done (%d skipped)\n", skip); }
      break;
    default:
      m_error("M$HCBFUNC: Unknown function!");
      break;
  }
}

void m$seek_ (HEADER *hcb, double *pos) {
  Context *ctx = getContext();
  double seek_pos = MAX(1.0, *pos); /* make sure not less than 1 */
  /* Bug 1745 - save new seek position into hcb->offset */
  hcb->offset = seek_pos - 1;       /* change from 1 base to 0 base */
  nm_seek(hcb->lph, hcb->offset);
}

/** returns -1 on read error, 0 for EOF */
int_4 m_read (HEADER *hcb, int_1 *buffer, double offset, int_4 xfer) {
  int_4 stat=0;
  int_4 nsca=0;
  Context *ctx = getContext();
  jint bytes = xfer * hcb->dbpe;

  /* NTN: seeking is now done in nm_read(..) if (offset>=0) nm_seek(hcb->lph,offset); */
  stat = nm_read(hcb->lph,(jlong)(jpointer)buffer,offset,bytes);
  if (stat == -3) return -1;                /* read error (translate -3 to -1) */
  if (stat < bytes) ctx->todo=0;            /* stop m$do loop */
  if (stat != bytes) xfer = stat/hcb->dbpe; /* in elements    */

  /* reformat if necessary */
  if (hcb->buf_type != hcb->format[1]) {
    nsca = xfer * hcb->ape * hcb->spa;
    m$reformat_(buffer,&hcb->format[1],buffer,&hcb->buf_type,&nsca,1,1);
  }
  return xfer;
}

void m$grab_ (HEADER *hcb, int_1 *buffer, double *start, int_4 *nget, int_4 *ngot) {
  double start0 = (*start - 1); /* change from 1 base to 0 base */
  hcb->xfer_len = *nget;        /* since 3.0.2 for Bug 2549 */
  int_4 n = m_read (hcb,buffer,start0,*nget);
  hcb->offset = start0 + n;     /* Bug 1745 - save offset back into hcb->offset */
  /* since 2.9.2, set Mu.okio field for BUG 2375 */
  if ((n != hcb->xfer_len) && (hcb->cons_len != -2)) {
    Mu->okio = FALSE;
  }
  if (*ngot != -1) *ngot = n;
}

void m$grabx_ (HEADER *hcb, int_1 *buffer, int_4 *ngot) {
  int_4 n = m_read (hcb,buffer,hcb->offset,hcb->xfer_len);
  if (hcb->cons_len >= 0) hcb->offset += hcb->cons_len;
  else hcb->offset += n;
  /* since 2.9.2, set Mu.okio field for BUG 2375 */
  if ((n < 0) && (hcb->cons_len <= -2)) {
    n = -2;
    Mu->okio = FALSE;
  }
  else if ((n != hcb->xfer_len) && (hcb->cons_len != -2)) {
    Mu->okio = FALSE;
  }
  if (*ngot != -1) *ngot = n;
}

int_4 m_write (HEADER *hcb, int_1 *buffer, double offset, int_4 xfer) {
  int_4 stat=0;
  int_4 nsca=0;
  Context *ctx = getContext();
  jint bytes = xfer * hcb->dbpe;

  if (xfer > 0) { /* X-Midas allows xfer<0 to mean transfer nothing... yea. */
    if (hcb->buf_type != hcb->format[1]) {
      nsca = xfer * hcb->ape * hcb->spa;
      m$reformat_(buffer,&hcb->buf_type,buffer,&hcb->format[1],&nsca,1,1);
    }
    stat = nm_write(hcb->lph,(jlong)(jpointer)buffer,offset,bytes);
    hcb->offset = nm_getSeek(hcb->lph); /* Bug 1745 - update offset to current in DataFile */
    if (stat < 0) return stat;
    if (stat != bytes) xfer = stat/hcb->dbpe; /* in elements */
  }
  return xfer;
}

void m$shove_ (HEADER *hcb, int_1 *buffer, double *start, int_4 *ntoput, int_4 *ngot) {
  if (hcb->open==0) return;
  *ngot = m_write(hcb,buffer,(*start-1),*ntoput);
}

void m$shovex_ (HEADER *hcb, int_1 *buffer, int_4 *nput) {
  if (hcb->open==0) return;
  m_write(hcb,buffer,-1.0,*nput);
}

void m$filad_ (HEADER *hcb, int_1 *buffer, int_4 *nput) {
  if (hcb->open==0) return;
  m_write(hcb,buffer,-1.0,*nput);
}

int_4 m$xfer_length_ (int_4 *bpe, int_4 *maxbufsize) {
  Context *ctx = getContext();
  jint xfer = 0;
  jint tl;
  int_4 maxbytes = abs(*maxbufsize);

  if      (*bpe > 0) xfer = maxbytes/(*bpe);          /* byte bpe */
  else if (*bpe < 0) xfer = -8 * (maxbytes-2)/(*bpe); /* bit  bpe (leave 2 bytes extra room in buffer for off-byte bit handling) */
  tl = m$get_switch_("TL",2);
  if (tl > 0) {
    if (*maxbufsize < 0) xfer = tl;
    else if (tl > xfer) {
      char msg[128];
      snprintf(msg,128,"Internal buffer limits transfers to %d elements",xfer);
      m_warning(msg);
    } else {
      xfer = tl;
    }
  }
  if (xfer<=0) m_error("Transfer length of zero calculated in M$XFER_LENGTH");
  if (DEBUG) { printf("m$xfer_len=%d\n",xfer); }
  return xfer;
}


int_4 m$get_keydata_ (HEADER *hcb, char *key, void *bbuf, int_4 *mbuf, int_4 *mode,
                     char *type, fstring_len_t lkey, fstring_len_t ltype) {
  Context *ctx  = getContext();
  JNIEnv  *env  = ctx->env;
  jobject jkey  = c2jbuf(ctx->env, key, lkey);
  jobject jval  = NULL;
  jint    ljval = 0;
  jint    bytes = 0;

  jval = nm_get_keydata(hcb->lph, jkey, *mode, *type);

  if (jval == NULL) {
    bytes = -1;
  } else {
    ljval = (*env)->GetArrayLength(env, jval);
    bytes = min(ljval-1, *mbuf);

    if (((*mode)&MK_Typeasis) != 0) {
      /* only copy-back type as indicated by flags */
      (*env)->GetByteArrayRegion(env, jval, 0, 1, (jbyte*)type);       /* type (may be modified) */
    }
    (*env)->GetByteArrayRegion(env, jval, 1, bytes, (jbyte*)bbuf);     /* data */
    if ((((*mode)&MK_Typetag) != 0) || (((*mode)&MK_Next) != 0)) {
      /* only copy-back key as indicated by flags */
      (*env)->GetByteArrayRegion(env, jkey, 0, lkey, (jbyte*)key);     /* key (may be modified) */
    }
  }
  LocalGC(jkey);
  LocalGC(jval);

  return bytes;
}

#define L_keytmp 4096
int_1 keytmp[L_keytmp];

int_4 m$find_keydata_ (HEADER *hcb, char *key, void *lbuf, int_4 *mbuf, int_4 *mode,
                     char *type, fstring_len_t lkey, fstring_len_t ltype) {
  int_4 maxbuf = L_keytmp;
  lbuf = (void*)keytmp;
  *mbuf = m$get_keydata_(hcb, key, (void*)keytmp, &maxbuf, mode, type, lkey, ltype);
   return *mbuf;
}

int_4 m$put_keydata_ (HEADER *hcb, char *key, void *val, int_4 *mbuf, int_4 *mode,
                     char *type, fstring_len_t lkey, fstring_len_t ltype) {
  Context *ctx  = getContext();
  JNIEnv  *env  = ctx->env;
  jobject jkey  = c2jbuf(ctx->env, key, lkey);
  jobject jval  = c2jbuf(ctx->env, val, *mbuf);
  jint    bytes = -1;

  bytes = nm_put_keydata(hcb->lph, jkey, jval, *mode, *type);

  if (((*mode)&MK_Typetag) != 0) { /* since 3.1.2: update key & val ONLY IF MK_TypeTag is set (BUG 1378) */
    (*env)->GetByteArrayRegion(env, jkey, 0, lkey,  (jbyte*)key);
    (*env)->GetByteArrayRegion(env, jval, 0, *mbuf, (jbyte*)val);
  }

  LocalGC(jkey);
  LocalGC(jval);
  return bytes;
}

int_4 m$del_keydata_ (HEADER *hcb, char *key, int_4 *mode, fstring_len_t lkey) {
  Context *ctx   = getContext();
  JNIEnv  *env   = ctx->env;
  jobject jkey   = c2jbuf(ctx->env, key, lkey);
  jint    status = nm_del_keydata(hcb->lph, jkey, *mode);

  LocalGC(jkey);
  return status;
}

int_4 m$get_keyword_ (HEADER *hcb, char *key, char *val, fstring_len_t lkey, fstring_len_t lval) {
  int_4 mode = MK_Normal;
  char  type = 'A';
  int_4 mbuf = (int_4)lval;
  int_4 size = m$get_keydata_(hcb, key, val, &mbuf, &mode, &type, lkey, (fstring_len_t)1);

  if ((size >= 0) && (size < lval)) {
    memset(&(val[size]), ' ', (lval-size)); /* Fill with spaces, same as X-Midas */
  }

  return size;
}

int_4 m$put_keyword_ (HEADER *hcb, char *key, char *val, fstring_len_t lkey, fstring_len_t lval) {
  int_4 mode = MK_Normal;
  char  type = 'A';
  int_4 mbuf = (int_4)lval;

  return m$put_keydata_(hcb, key, val, &mbuf, &mode, &type, lkey, (fstring_len_t)1);
}

int_4 m$repl_keyword_ (HEADER *hcb, char *key, char *val, fstring_len_t lkey, fstring_len_t lval) {
  int_4 mode = MK_Replace;
  char  type = 'A';
  int_4 mbuf = (int_4)lval;

  return m$put_keydata_(hcb, key, val, &mbuf, &mode, &type, lkey, (fstring_len_t)1);
}

int_4 m$del_keyword_ (HEADER *hcb, char *key, fstring_len_t lkey) {
  int_4 mode = MK_Normal;

  return m$del_keydata_(hcb, key, &mode, lkey);
}

static int_4 scope_keyword (HEADER *hcb, char *tags, fstring_len_t ltags, bool_4 quiet) {
  /* Note that X-Midas uses a spcae to clear scope, NeXtMidas uses "ALL" */
  Context *ctx  = getContext();
  JNIEnv  *env  = ctx->env;
  jobject jtags = (tags[0]==' ')? c2jstr(ctx->env,"ALL"): f2jstr(ctx->env,tags,ltags);
  jint    level = nm_scope_keyword(hcb->lph, jtags);
  int_4   stat  = 0;

  LocalGC(jtags);

  if (level > 0) {
    stat = 1;
  } else {
    stat = -1;
    if (quiet==FALSE) {
      m_warning("XMLIBC: Bad keyword scope string:");
      /* NOTE: The funky syntax here is for printing FORTRAN strings, please leave here as a reference */
      printf("XMLIBC: scope_keyword key=%.*s len=%d\n",(int)ltags,tags,(int)ltags);
      printf("XMLIBC: scope_keyword filename=%s \n",hcb->file_name);
    }
  }

  return stat;
}

int_4 m$scope_keyword_ (HEADER *hcb, char *tags, fstring_len_t ltags) {
  return scope_keyword(hcb, tags, ltags, FALSE);
}

int_4 m$scope_keyword_quiet_ (HEADER *hcb, char *tags, fstring_len_t ltags) {
  return scope_keyword(hcb, tags, ltags, TRUE);
}

/*
  Utilities
*/
int_4 m$send_msge_ (int_1 *mqh, int_1 *mqd, int_4 *rid, int_4 *mask, int_4 *ntrys, float *wait, int_4 *eflag) {
  Context *ctx = getContext();
  int_4 status = nm_put_msge((jlong)(jpointer)mqh,(jlong)(jpointer)mqd,(*rid),(*mask));

  if (status < 0) {
    switch(*eflag) {
      case 0:  /* No output. */                                           break;
      case 1:  m_warning("M$SEND_MSGE: Error putting message on queue."); break;
      case 2:  m_error("M$SEND_MSGE: Error putting message on queue.");   break;
      default: m_error("M$SEND_MSGE: Invalid eflag value.");              break;
    }
  }
  return status;
}

void m$send_msg_ (int_1 *mqh, int_1 *mqd, int_4 *rid, int_4 *mask) {
  int_4 ntrys = -1;
  float wait  = 0.0;
  int_4 eflag = 1;

  m$send_msge_(mqh, mqd, rid, mask, &ntrys, &wait, &eflag);
}

int_4 m$get_msg_ (int_1 *mqh, int_1 *mqd, int_4 *maxsize, float *wait, int_4 *mask) {
  Context *ctx = getContext();
  return nm_get_msg((jlong)(jpointer)mqh,(jlong)(jpointer)mqd,(*maxsize),(*wait),(*mask));
}

int_4 m$npm_ (char *cmode, fstring_len_t len) {
  int mode = (int_u1)*cmode;
  switch (mode) {
    case 'S': return 1;
    case 'C': return 2;
    case 'V': return 3;
    case 'Q': return 4;
    case 'M': return 9;
    case 'X': return 10;
    case 'T': return 16;
    case 'U': return 1;
    case 'A': return 32;
    default:
      if (isdigit(mode))   { return mode - '0'; }
      else if (mode > 127) { return mode - 127; }
      else                 { return 0;          }
  }
}

void m$now_ (real_8* time1, real_8* time2) {
  Context *ctx = getContext();
  JNIEnv  *env = ctx->env;
  jdoubleArray jtimeArray = nm_now();
  if (jtimeArray != NULL) {
    jdouble darray[2];
    (*env)->GetDoubleArrayRegion(env, jtimeArray, 0, 2, darray);
    *time1     = darray[0];
    *time2     = darray[1];
  }
}

/* Replacement for %loc(functionPointer) when using Portland Group Compiler. */
M_PTR_T get_address_ (void (*func)() ) {
  return ((M_PTR_T) func);
}

/* JC4: This is a generic replacement for the OS-specific gerror_ method in
        X-Midas that just calls M$ERROR.
*/
void gerror_ (char *text, fstring_len_t tlen) {
  fprintf(stderr, "XBC: GERROR called.\n");
  m$error_(text, tlen);
}

int_4 m$get_default_ (char *cwd, fstring_len_t lcwd) {
  char type[1];
  char name[8] = "AUX.CWD";
  double dval = 0.0;
  m$rfind_ (type, 1, name, cwd, &dval, 7, lcwd);

  if (type[0] != 'A') {
    m_error("M$GET_DEFAULT could not find AUX.CWD.\n");
    dval = 0.0;
  }

  return (int_4)dval;
}

int_4 m$ldirectory_ (char *path, char *fname, char *ext, char *fullname,
                    int_4 *i, int_4 *j, int_4 *k, fstring_len_t lpath, fstring_len_t lfname,
                    fstring_len_t lext, fstring_len_t lfullname) {
  Context *ctx        = getContext();
  JNIEnv  *env        = ctx->env;
  jobject jpath       = c2jbuf(ctx->env, path,     lpath);
  jobject jfname      = c2jbuf(ctx->env, fname,    lfname);
  jobject jext        = c2jbuf(ctx->env, ext,      lext);
  jobject jfullname   = c2jbuf(ctx->env, fullname, lfullname);
  int_4   outArray[4] = { 0, 0, 0, 0 };
  jobject joutArray   = NULL;

  joutArray = nm_ldirectory(jpath,jfname,jext,jfullname,*i,*j,*k);

  j2cbuf(env, jpath,     path,     lpath);     LocalGC(jpath);
  j2cbuf(env, jfname,    fname,    lfname);    LocalGC(jfname);
  j2cbuf(env, jext,      ext,      lext);      LocalGC(jext);
  j2cbuf(env, jfullname, fullname, lfullname); LocalGC(jfullname);
  j2cbuf(env, joutArray, outArray, 4);         LocalGC(joutArray);

  (*i) = outArray[1];
  (*j) = outArray[2];
  (*k) = outArray[3];

  return outArray[0];
}

void m$map_section_ (int_4 *id, int_4 *flag) {
  m_info("M$MAP_SECTION: Shared memory sections not applicable in XBC.\n");
}

void m$map_buffer_ (int_4 *id) {
  m_info("M$MAP_SECTION: Shared memory sections not applicable in XBC.\n");
}

/******************************************************************************/
/* These methods copied from unix.c in X-Midas 3.8.3                          */
/*                                                                            */
/* JC4: I needed to add an extra cast to quiet some compiler warnings, see    */
/*      "JC4:" notes in code unix_expand_filename.                            */
/******************************************************************************/

/* unix_expand_filename has been expanded to add the capabilities of
 * parsing cname with multiple $'s
 * If cname = "$stuff/morejunk" or
 *    cname = "$stuff         " or
 *    cname = "$stuff/junk/$morejunk"
 * where stuff is delimited by $ and / or SPACE, upcase "stuff"
 * and try to expand using getenv().  Complain if getenv fails.
 * otherwise, return the input string.  Expansions are stashed
 * in a large static buffer.  This will NOT be thread safe.
 */
char *unix_expand_filename( char *cname ) {
  static char expand_str[MAXPATHLEN];  /* size DOES matter */
  char env_str[84];
  char *evp;
  char *scratch;
  char *scratch1;
  char *ep = env_str;
  char *ep1;
  char *cp = cname;
  char *xp = expand_str;
  char *warn_str;
  int_4 len;
  int_4  check,fcheck,strcnt;

  memset(expand_str,0,MAXPATHLEN);
  check = 0;
  fcheck = 1;
  strcnt = 0;

  if ( *cname != '$' )
  {
    return cname;
  }
  while (*cp != '\0')
  {
    scratch = ep;
    ep1 = ep;
    scratch1 = xp;
    while (*ep == *++cp)
    {
      strcnt++;
      if (*cp == '$')
      {
        check++;
        memset(env_str,0,sizeof(env_str));
         ep = env_str;
      }
      else
      {
        if ((check != 0) || (fcheck != 0))
        {
          if (*cp == '/' || *cp == ' ')
         {
           break;
         }
         *ep = toupper(*cp);
         (*ep)++;
        }
        else
        {
          if (*cp == '/' || *cp == ' ')
          {
            break;
          }
          *ep = *cp;
          (*ep)++;
        }
      }
    }
    *ep++ = 0;
    if ((check != 0) || (fcheck != 0))
    {
      /* JC4: Start - cast env ptr. */
      /* evp=getenv(env_str); */
      evp=(char*)getenv(env_str);
      /* JC4: End - cast env ptr. */

      if (evp == NULL)
      {
        warn_str = malloc(sizeof(char) * strlen(env_str)+37);
        sprintf(warn_str,"Environment variable not defined $%s",env_str);
        m_warning(warn_str);
        free(warn_str);
        return cname;
      }
      len = L_cmd_chars - 1;  /* NEVER overrun */
      while ( --len > 0 && *evp )
      {
        *xp++ = *evp++;
      }
      if (*cp != '\0')
      {
      *xp++ = '/';
      }
    }
    else
    {
      len = L_cmd_chars - 1;  /* NEVER overrun */
      ep = ep1;
      while ( --len > 0 && *ep && *ep != ' ' )
      {
        *xp++ = *ep++;

      }
      if (*cp != '\0')
      {
        *xp++ = '/';
      }
    }
     check = 0;
     fcheck = 0;
  }
  return expand_str;
}

void  unix_fort_expand_filename_(char *in, char *out, fstring_len_t l1, fstring_len_t l2) {
  char *tmp=malloc(l1+1);
  strf2c ( in, l1, tmp, l1+1, F2C_TRIM );
  strc2f ( unix_expand_filename(tmp), -1, out, l2, C2F_FILL);
  free(tmp);
}

#define NEW_BYTE_BUFFER(addr,size) \
          nm_byteBufferInit((*ctx->env)->NewDirectByteBuffer(ctx->env,(addr),(size)))
#define FREE_BYTE_BUFFER(buf) LocalGC(buf)

/* call getOptArea(opt,area) and put results in str. */
static void getOptPath(char *path, fstring_len_t lpath, char *opt, char *area, fstring_len_t lopt, fstring_len_t larea) {
  Context *ctx = getContext();
  jobject pathBuf = NEW_BYTE_BUFFER(path,lpath);
  jobject optBuf  = NEW_BYTE_BUFFER(opt,lopt);
  jobject areaBuf = NEW_BYTE_BUFFER(area,larea);

  nm_getOptPath(pathBuf,optBuf,areaBuf);

  FREE_BYTE_BUFFER(pathBuf);
  FREE_BYTE_BUFFER(optBuf);
  FREE_BYTE_BUFFER(areaBuf);
}

int_4 m$import_(char *var_arg, char *buf_arg, fstring_len_t lvar, fstring_len_t lbuf) {
  char  cvar_arg[80];
  char  path[80];
  char *str;
  char *opt;
  int_4 len;

  strf2c(var_arg, lvar, cvar_arg, sizeof(cvar_arg), F2C_TRIM);

  if ((lbuf >= 6) && (strncmp(cvar_arg,"XMAREA",6)==0)) {
    if (lbuf > 7) { /* XMAREA_<opt> */
      opt = &cvar_arg[7];
    } else { /* XMAREA */
      m_warning("M$IMPORT: Trying to import XMAREA but it does not exist in XBC.");
      opt = "XBC";
    }
    getOptPath(path,80,opt,".",strlen(opt),1);
    len = strlen(path);
    strc2f(path, len, buf_arg, lbuf, C2F_FILL);
    return len;

  } else if ((str = getenv(cvar_arg)) == NULL) {
    strc2f("", 0, buf_arg, lbuf, C2F_FILL);
    return -1;
  } else {
    len = strlen(str);
    strc2f(str, len, buf_arg, lbuf, C2F_FILL);
    return len;
  }
}

int_4 check_if_dir_(char *dir_arg, fstring_len_t L1) {
  char        dir_name[PATH_MAX+1];
  int_4       status;
  struct stat dstat;

  strf2c(dir_arg, L1, dir_name, sizeof(dir_name), F2C_UNIXFILE);

  status = stat(dir_name,&dstat);
  if (status != -1)
  {
    if (S_ISDIR(dstat.st_mode))
      status = 1;
    else
      status = 0;
  }
  else
  {
    status = 0;
  }

  return status;
}

/*******************************************************************************
  SEDIT methods
*******************************************************************************/

/* M$STRIM: Trim spaces and control chars (<= ' ') off both ends of instr
            and save into outstr.
   @return length of return string (outstr).
   @since NeXtMidas 2.7.1
*/
int_4 m$strim_(const char *instr, char *outstr, fstring_len_t len_instr, fstring_len_t len_outstr) {
  register char c;
  register int  ii;     /* index into instr */
  register int  jj = 0; /* index into outstr (also will be return length of outstr */

  len_instr = m$length_(instr, len_instr); /* get len of instr without trailing spaces */
  for (ii = 0; ii < len_instr; ii++) {
    c = instr[ii];
    if (c <= ' ' && jj==0) continue; /* skips leading spaces and control chars (matches X-Midas) */
    outstr[jj++] = c;
    if (jj >= len_outstr) break;     /* make sure we don't overwrite max length of outstr */
  }
  return jj; /* jj is length of outstr */
}

/** M$HEAD: Extracts the path from a full file name in in_str and places it in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.1.2
 */
int_4 m$head_(const char *instr, char *outstr, fstring_len_t len_instr, fstring_len_t len_outstr) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jobject jstro = nm_sedit_head(jstri);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstro);
  return rtnlen;
}

/** M$TAIL: Extracts the file name (with extension) from a full file name in in_str and  places it in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.1.2
 */
int_4 m$tail_(const char *instr, char *outstr, fstring_len_t len_instr, fstring_len_t len_outstr) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jobject jstro = nm_sedit_tail(jstri);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstro);
  return rtnlen;
}


/** M$ROOT: Extracts the file name (without extension) from a full file name in in_str and  places it in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.1.2
 */
int_4 m$root_(const char *instr, char *outstr, fstring_len_t len_instr, fstring_len_t len_outstr) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jobject jstro = nm_sedit_root(jstri);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstro);
  return rtnlen;
}

/** M$EXT: Extracts the extension from a file name in in_str and places it in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.1.2
 */
int_4 m$ext_(const char *instr, char *outstr, fstring_len_t len_instr, fstring_len_t len_outstr) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jobject jstro = nm_sedit_ext(jstri);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstro);
  return rtnlen;
}

/** M$TRIMS: Trims off in_str before string1 and after string2 placing result in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.1.2
 */
int_4 m$trims_(const char *instr, char *outstr, const char *p1, const char *p2, fstring_len_t len_instr, fstring_len_t len_outstr, fstring_len_t len_p1, fstring_len_t len_p2) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jobject jstrp1 = f2jstr(ctx->env, p1, len_p1);
  jobject jstrp2 = f2jstr(ctx->env, p2, len_p2);
  jobject jstro = nm_sedit_trims(jstri, jstrp1, jstrp2);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstrp1);
  LocalGC(jstrp2);
  LocalGC(jstro);
  return rtnlen;
}

/** M$BETWEEN: Extracts any possible substring from in_str between start and finish placing
    result in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.1.2
 */
int_4 m$between_(const char *instr, char *outstr, const int_4 *min, const int_4 *max, fstring_len_t len_instr, fstring_len_t len_outstr) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jint jint1 = *min;
  jint jint2 = *max;
  jobject jstro = nm_sedit_between(jstri, jint1 - 1, jint2 - 1); // Adjustment for 1 base to 0
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstro);
  return rtnlen;
}

/** M$WORD: Extracts the naturally delimited word containing string placing word
    in outstr.  Returns length of outstr.
    @return Returns the length of outstr.
    @since NeXtMidas 3.5.0
 */
int_4 m$word_(const char *instr, char *outstr, const char *string, fstring_len_t len_instr, fstring_len_t len_outstr, fstring_len_t len_string) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jobject jstr  = f2jstr(ctx->env, string, len_string);
  jobject jstro = nm_sedit_word(jstri, jstr);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstr);
  LocalGC(jstro);
  return rtnlen;
}

/** M$NELEMENTS: Returns the number of elements in in_str as delimited by string.
    @return Returns the number of elements.
    @since NeXtMidas 3.5.0
 */
int_4 m$nelements_(const char *in_str, const char *string, fstring_len_t in_str_len, fstring_len_t string_len) {
  // Special case of single space delimiter. Trailing spaces annihilated when translated to Fortran. Use "<SPACE>" instead.
  if (strcmp(string,"<SPACE>") == 0) {
    string = " ";
  }
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, in_str, in_str_len);
  jobject delim = f2jstr(ctx->env, string, string_len);
  jint n_elem = nm_sedit_nelements(jstri, delim);
  LocalGC(jstri);
  LocalGC(delim);
  return n_elem;
}

/** M$ELEMENT: Extracts the nth delimited word where the delimiter is string.
    @return Returns the length of out_str.
    @since NeXtMidas 3.5.0
 */
int_4 m$element_(const char *in_str, char *out_str, const int_4 *n, const char *string, fstring_len_t in_str_len, fstring_len_t out_str_len, fstring_len_t string_len) {
  // Special case of single space delimiter. Trailing spaces annihilated when translated to Fortran. Use "<SPACE>" instead.
  if (strcmp(string,"<SPACE>") == 0) {
    string = " ";
  }
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, in_str, in_str_len);
  jint jint_n = *n;
  jobject delim = f2jstr(ctx->env, string, string_len);
  jobject jstro = nm_sedit_element(jstri, jint_n, delim);
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, out_str, out_str_len);
  LocalGC(jstri);
  LocalGC(delim);
  LocalGC(jstro);
  return rtnlen;
}

/** M$NSEARCH: Finds index of nth occurrence of sub_str in in_str.
    @return Returns index of nth occurrence of sub_str.
    @since NeXtMidas 3.5.0
 */
int_4 m$nsearch_(const char *in_str, char *sub_str, const int_4 *n, fstring_len_t in_str_len, fstring_len_t sub_str_len) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, in_str, in_str_len);
  jobject jstrs = f2jstr(ctx->env, sub_str, sub_str_len);
  jint jint_n = *n;
  jint indexof = nm_sedit_nsearch(jstri, jstrs, jint_n);
  LocalGC(jstri);
  LocalGC(jstrs);
  return indexof;
}

/** M$RANGE: Extracts substring from in_str between start and finish placing
    result in out_str.
    @return Returns the length of out_str.
    @since NeXtMidas 3.5.0
 */
int_4 m$range_(const char *instr, char *outstr, const int_4 *min, const int_4 *max, fstring_len_t len_instr, fstring_len_t len_outstr) {
  Context *ctx = getContext();
  jobject jstri = f2jstr(ctx->env, instr, len_instr);
  jint jint1 = *min;
  jint jint2 = *max;
  jobject jstro = nm_sedit_range(jstri, jint1 - 1, jint2 - 1); // Adjustment for 1 base to 0
  fstring_len_t rtnlen = j2fstr(ctx->env, jstro, outstr, len_outstr);
  LocalGC(jstri);
  LocalGC(jstro);
  return rtnlen;
}

/** M$STARTSWITH: Checks if string starts with str1.
    @return Returns integer true/false.
    @since NeXtMidas 3.5.0
 */
int_4 m$startswith_(const char *string, char *str1, fstring_len_t string_len, fstring_len_t str1_len) {
  Context *ctx = getContext();
  jobject jstring = f2jstr(ctx->env, string, string_len);
  jobject jstr1 = f2jstr(ctx->env, str1, str1_len);
  jint jintb = nm_sedit_startswith(jstring, jstr1);
  LocalGC(jstring);
  LocalGC(jstr1);
  return jintb;
}

/** M$ENDSWITH: Checks if string ends with str1.
    @return Returns integer true/false.
    @since NeXtMidas 3.5.0
 */
int_4 m$endswith_(const char *string, char *str1, fstring_len_t string_len, fstring_len_t str1_len) {
  Context *ctx = getContext();
  jobject jstring = f2jstr(ctx->env, string, string_len);
  jobject jstr1 = f2jstr(ctx->env, str1, str1_len);
  jint jintb = nm_sedit_endswith(jstring, jstr1);
  LocalGC(jstring);
  LocalGC(jstr1);
  return jintb;
}

/** M$NFORMAT: Checks if string ends with str1.
    @return Returns length of formatted string.
    @since NeXtMidas 3.5.0
 */
int_4 m$nformat_(const char *instr, const char *formatstr, char *outstr, fstring_len_t instr_len, fstring_len_t formatstr_len, fstring_len_t outstr_len) {
  Context *ctx = getContext();
  jobject jinstr = f2jstr(ctx->env, instr, instr_len);
  jobject jformatstr = f2jstr(ctx->env, formatstr, formatstr_len);
  jobject joutstr = nm_sedit_nformat(jinstr, jformatstr);
  fstring_len_t rtnlen = j2fstr(ctx->env, joutstr, outstr, outstr_len);
  LocalGC(jinstr);
  LocalGC(jformatstr);
  LocalGC(joutstr);
  return rtnlen;
}
