/****************************************************************************
 *
 * $Id: sl2pl.c,v 1.4 2003/08/24 00:56:03 dburke Exp $
 *
 * sl2pl.c
 *   Conversion routines between S-Lang and Perl data types.
 *
 ****************************************************************************/

#include "util.h"
#include "pdl.h"
#include "sl2pl.h"

static SV * sl2pl_type( SLtype type );

/*
 * implement support for ND arrays using a generic interface
 * - ie do not use the C API but use S-Lang itself -
 * which is not as efficient but handles everything.
 * Support for specific types can be added later if it is
 * decided to be worthwhile
 *
 * NOTE:
 *   the following algorithm is a mess since we have the array
 *   both on the stack and in C scope
 *
 * S-Lang's dimensions are stored in int arrays (at least in 1.4.9)
 *
 */
static SV *
sl2pl_array_aref( SLang_Array_Type *at ) {

  AV *aref[SLARRAY_MAX_DIMS];
  int dimsize[SLARRAY_MAX_DIMS], coord[SLARRAY_MAX_DIMS];

  SV *arrayref = NULL;

  SV *get_array_elem_sv;
  char *get_array_elem_str;
  SV *dval;

  SLtype dtype = at->data_type;
  int    nelem = at->num_elements;
  int    ndims = at->num_dims;
  int   *dims  = at->dims;

  int maxdim = ndims - 1;
  int i, j;

  /*
   * set up the arrays for the loop
   *  1 - the actual data array
   *  2 - the arrays used to loop through it
   */
  arrayref = _create_empty_array( ndims, dims );

  for ( i = 0; i < ndims; i++ ) {
    Printf( ("  *** dimension %d has size %d\n",i,dims[i]) );
    coord[i]   = 0;
    dimsize[i] = dims[i] - 1;
    if ( i )
      aref[i] = (AV *) SvRV( *av_fetch( aref[i-1], 0, 0 ) );
    else
      aref[i] = (AV *) SvRV( arrayref );
  } 

  /*
   * this is truly not wonderful: set up the string that
   * pops the array and coordinates off the
   * S-Lang stack and returns the value of the corresponding array element
   * - *and* I'm too lazy to do this in C!
   */
  Printf( ("Calling Array_Type::_private_get_read_string(%d)\n",maxdim) );
  {
    int count;
    dSP; ENTER; SAVETMPS; PUSHMARK(SP);
    XPUSHs( sv_2mortal(newSViv(maxdim)) );
    PUTBACK;
    count = call_pv( "Array_Type::_private_get_read_string", G_SCALAR );
    SPAGAIN;
    if ( 1 != count )
      croak( "Internal error: unable to call _private_get_read_string()\n" );
    get_array_elem_sv = SvREFCNT_inc( POPs );
    PUTBACK; FREETMPS; LEAVE;
  }
  get_array_elem_str = SvPV_nolen(get_array_elem_sv);
  Printf( ("get str = [%s]\n",get_array_elem_str) );

  /*
   * We need the array in $1 with the current code,
   * so we have to push it back onto the stack but we do NOT
   * free at
   */
  UTIL_SLERR(
    SLang_push_array( at, 0 ),
    "Internal error - unable to push array onto the S-Lang stack"
  );
  (void) SLang_load_string( "$1=();" );

  /*
   * loop i=1 to nelem - see pl2sl_array() for more details
   */
  for ( i = 1; i < nelem; i++ ) {
    Printf( ("  **** Setting %dD array elem %d coord=[",ndims,i) );

    /*
     * since we are about to call sl2pl() we push $1 onto the stack
     * to protect it. Then we push the coordinates, and then the
     * current data value
     */
    for( j = 0; j < ndims; j++ ) {
      Printf( (" %d",coord[j]) );
      UTIL_SLERR(
	SLang_push_integer(coord[j]),
        "Internal error: unable to push onto the stack"
      );
    }
    Printf( (" ] and coord[maxdim] = %d\n",coord[maxdim]) );

    /* now get the value, convert to Perl, and store [also pushes array onto stack] */
    (void) SLang_load_string( get_array_elem_str );
    dval = sl2pl_type( dtype );
    av_store( aref[maxdim], coord[maxdim], dval );

    /* restore $1 to be the array */
    (void) SLang_load_string( "$1=();" );

    /* update the pointer */
    if ( coord[maxdim] < dimsize[maxdim] ) coord[maxdim]++;
    else {
      Printf( ("+++ start: loop to upate coords/array refs\n") );
      /*
       * loop through each previous coord until we find
       * one with 'coord[j] < dimsize[j]', increase it
       * and then reset the 'higher dim' coord/aref values
       */
      j = maxdim - 1;
      while ( coord[j] == dimsize[j] ) { j--; }
      Printf( ("++++++++ got to dim #%d with coord=[%d]\n",j,coord[j]) );
      coord[j]++;
      if ( j )
        aref[j] = (AV *) SvRV( *av_fetch( aref[j-1], coord[j-1], 0 ) );
      j++;
      while ( j <= maxdim ) {
	Printf( ("++++++ resetting dim #%d from %d to 0 (prev dimension val=%d)\n",
		 j,coord[j],coord[j-1]) );
	coord[j] = 0;
	aref[j] = (AV *) SvRV( *av_fetch( aref[j-1], coord[j-1], 0 ) );
	j++;
      }
      Printf( ("+++ finished coords/array refs update\n") );
    } /* if: coord[maxdim] == dimsize[maxdim] */

  } /* for: i=1 .. nelem-1 */

  /* handle the last element */
  Printf( ("  **** Setting %dD array elem %d coord=[",ndims,nelem) );
  for( j = 0; j <= maxdim; j++ ) {
    Printf( (" %d",coord[j]) );
    UTIL_SLERR(
      SLang_push_integer(coord[j]),
      "Internal error: unable to push onto the stack"
    );
  }
  Printf( (" ] [[last element]]\n") );

  /* now get the value, convert to Perl, and store */
  (void) SLang_load_string( get_array_elem_str );
  dval = sl2pl_type( dtype );
  av_store( aref[maxdim], coord[maxdim], dval );
  (void) SLang_load_string("$1=();"); /* clean up the stack */

  _clean_slang_vars(maxdim+2);
  SvREFCNT_dec( get_array_elem_sv );
  return arrayref;

} /* sl2pl_array_aref() */

/*
 * to reduce replicated code we delegate most of the conversion
 * to sl2pl_array_aref() and then convert the array reference into
 * an Array_Type object. It's somewhat wasteful since we have
 * to find the dimensions and datatype again (especially as I'm
 * just relying on sl_array() to do this in Perl).
 */
static SV *
sl2pl_array_atype( SLang_Array_Type *at ) {
  SV *aref = sl2pl_array_aref(at);
  SV *obj;

  /***
      Should create the dims and datatype values and send to sl_array
      so that things are converted properly (otherwise
      UChar_Type -> Integer_Type etc)
  ***/

  Printf( ("Calling Inline::SLang::sl_array() to convert to Array_Type\n") );
  {
    int count;
    dSP; ENTER; SAVETMPS; PUSHMARK(SP);
    fixme( "memleaks?" );
    //    XPUSHs( sv_2mortal(newSViv(maxdim)) );
    XPUSHs( aref );
    XPUSHs( sv_2mortal(newSVpv(SLclass_get_datatype_name(at->data_type),0)) );
    PUTBACK;
    count = call_pv( "Inline::SLang::sl_array", G_SCALAR );
    SPAGAIN;
    if ( 1 != count )
      croak( "Internal error: unable to call Inline::SLang::sl_array()\n" );
    fixme( "memleak?" );
    obj = SvREFCNT_inc( POPs );
    PUTBACK; FREETMPS; LEAVE;
  }

  return obj;
} /* sl2pl_array_atype() */

static SV *
sl2pl_array( void ) {

  SV *out;
  SLang_Array_Type *at = NULL;

  Printf( ("  S-Lang stack contains: array  ") );

  UTIL_SLERR(
	     SLang_pop_array( &at, 0 ),
	     "Internal error - unable to pop duplicated array off the stack"
	     );
  Printf( (" num dims=%d  nelem=%d  type=%s\n",
	   at->num_dims, at->num_elements,
	   SLclass_get_datatype_name(at->data_type)) );

  /*
   * Output is one of the following - determined by the
   * value of the variable _slang_array_format:
   *
   *       Non-numeric        Numeric
   *   0 - array ref          -
   *   1 - Array_Type         -
   *   2 - array ref          piddle
   *   3 - Array_Type         piddle
   *
   * could do comparison by bit manipulation
   */

  switch ( _slang_array_format ) {
  case 0:
    out = sl2pl_array_aref( at );
    break;

  case 1:
    out = sl2pl_array_atype( at );
    break;

  case 2:
#if I_SL_HAVE_PDL == 1
    if ( IS_CONVERTABLE_TO_PDL(at->data_type) )
      out = sl2pl_array_pdl( at );
    else
#endif
      out = sl2pl_array_aref( at );
    break;

  case 3:
#if I_SL_HAVE_PDL == 1
    if ( IS_CONVERTABLE_TO_PDL(at->data_type) )
      out = sl2pl_array_pdl( at );
    else
#endif
      out = sl2pl_array_atype( at );
    break;

  } /* switch: _slang_array_format */

  /*
   * can free up the array now (although will want to keep it around
   * once [if?] we re-implement the type-specific routines)
   */
  SLang_free_array( at );

  return out;

} /* sl2pl_array() */

/*
 * use a tied hash to represent a S-Lang structure
 * - see also Struct_Type
 */
static SV *
sl2pl_assoc( void ) {

  SLang_Array_Type *keys = NULL;
  SV *tied_object, *object;
  HV *hash;
  char *typename, *keyname;
  int i;

  Printf( ("  stack contains an associative array\n") );

  /*
   * use S-Lang to parse the Associative array
   * (approach suggested by John Davis) since there isn't
   * a public C API for them (ie internals liable to change)
   */
  (void) SLang_load_string( "$1=();assoc_get_keys($1);" );
  UTIL_SLERR(
	     SLang_pop_array( &keys, 0 ),
	     "Internal error: unable to pop keys array off the stack\n"
	     );
  
  (void) SLang_load_string( "string(_typeof(assoc_get_values($1)));" );
  UTIL_SLERR(
	     SLang_pop_slstring( &typename ),
	     "Internal error: unable to pop string off the S-Lang stack\n"
	     );
  Printf( (">> Assoc_Array has type = [%s]\n",typename) );
  CALL_METHOD_SCALAR_SV( sv_2mortal(newSVpv("Assoc_Type",0)), 
			 "new", C2PL_MARG_S(typename);, tied_object );
  SLang_free_slstring(typename);

  /*
   * get a reference to the hash which is actually storing the data
   */
  CALL_METHOD_SCALAR_SV( tied_object, "_private_get_hashref", , object );
  object = sv_2mortal( object );
  hash = (HV *) SvRV( object );
  
  /*
   * loop through each element, converting the values to Perl types
   * NOTE:
   *   previously converted all the field values to Perl in one go
   *   but as I'm planning to change the array handling to use
   *   tied arrays and I don't understand how to access them from
   *   C I'm doing them one at a time
   * (08/18/03 DJB - not sure how much of this statement remains true)
   */
  Printf( ("About to loop through the Assoc array keys [nelem=%d]\n",
	   keys->num_elements) );
  for ( i = 0; i < keys->num_elements; i++ ) {
    SV *value;
    
    /* get the key */
    (void) SLang_get_array_element( keys, &i, &keyname );
    Printf( ( "assoc array key = [%s]\n", keyname ) );

    /* convert the value from the S-Lang array - leave on stack */
    UTIL_SLERR(
	       SLang_push_string(keyname),
	       "Internal error during conversion of S-Lang Assoc_Array to Perl\n"
	       );

    /*
     * since the sl2pl() call may invalidate the value of $1
     * we cheat and stick $1 onto the S-Lang stack as well as
     * the value of the key we're interested in so that we can
     * reset $1 after the call to sl2pl()
     * THIS IS NOT MEMORY/TIME EFFICIENT !
     */
    (void) SLang_load_string( "$2 = (); $1; $1[$2];" );
    value = sl2pl();
    (void) SLang_load_string( "$1 = ();" );
    
    /* store in the hash */
    hv_store( hash, keyname, strlen(keyname), value, 0 );

    SLang_free_slstring( keyname ); // is this necessary?
  } /* for: i = 0 .. num_elements-1 */

  /* free up memory */
  _clean_slang_vars(2);
  SLang_free_array( keys );
  Printf( ("freed up keys array (S-Lang)\n") );

  return tied_object;

} /* sl2pl_assoc() */

/*
 * Convert S-Lang structs - including type-deffed ones
 * to Perl <> objects
 *
 * If we were just bothered about S-lang structs - ie not the
 * type-deffed ones - then we could just have this code directly
 * in sl2pl() within a "case SLANG_STRUCT_TYPE: {}".
 * However, as I don't know how we can easily tell whether an
 * item on the S_Lang stack is a type-deffed structure we go
 * with this method
 *
 * We are called with a S-Lang structure in $1
 */
static SV *
sl2pl_struct(void) {
  char *stype;
  SV *tied_object, *object;
  HV *hash;
  SV *fieldsref;
  AV *fields;
  int i, nfields;
  int a2p_flag;

  Printf( ("  stack contains: structure - ") );

  /*
   * get the Perl class name for this structure
   * (let S-Lang bother with the string handling)
   */
  (void) SLang_load_string( "string(typeof($1));" );
  UTIL_SLERR(
    SLang_pop_slstring(&stype), 
    "Error: unable to get datatype of a structure\n"
  );
  Printf( ("it's type is %s\n",stype) );

  /*
   * - handle similarly to associative arrays, in that
   *   we take advantage of the S-Lang stack
   * - can't guarantee that $1 isn't going to get trashed when
   *   converting the array of strings, so we push it on
   *
   */
  (void) SLang_load_string( "$1;get_struct_field_names($1);" );

  /*
   * convert the item on the stack (ie the field names) to a perl array
   *
   * NOTE:
   *   since we are going to convert an array from S-Lang to
   *   Perl we need to ensure that we do it as a array ref
   *   whatever the user actually wants (and set it back later)
   */
  a2p_flag = _slang_array_format;
  _slang_array_format = 0;
  fieldsref = sv_2mortal( sl2pl() );
  _slang_array_format = a2p_flag;
  fields = (AV *) SvRV( fieldsref );
  nfields = 1 + av_len( fields );
  Printf( ("Number of fields in the structure = %d\n", nfields ) );

  (void) SLang_load_string( "$1=();" );

  /*
   * create the <XXX> object and then get the underlying structure
   * used to implement the tied hash. object is a reference to the
   * hash that stores the data [ie it's not the full Struct_Type
   * implementation 'object' which is an array reference]
   */
  CALL_METHOD_SCALAR_SV( sv_2mortal(newSVpv(stype,0)), 
			 "new", XPUSHs(fieldsref);, tied_object );
  CALL_METHOD_SCALAR_SV( tied_object, "_private_get_hashref", , object );
  object = sv_2mortal( object );
  hash = (HV *) SvRV( object );

  /*
   * loop through each field: push its value onto the S-Lang stack, convert
   * it to a Perl SV *, and store in the Perl hash
   *
   * Since we call sl2pl() - which may trash $1 - we need to protect the value
   * in $1 by pushing it onto the stack prior to the sl2pl() call and then
   * popping it back again afterwards. Not really memory/time efficient
   */
  for ( i = 0; i<nfields; i++ ) {
    SV **name;
    SV *value;
    char *fieldname;
    
    /* get the field name */
    name = av_fetch( fields, (I32) i, 0 );
    fieldname = SvPV_nolen( *name );
    Printf( ("struct field name %d/%d = [%s]\n", i, nfields-1, fieldname) );

    UTIL_SLERR(
      SLang_push_string( fieldname ),
      "Internal error - Unable to push name of struct field onto stack"
    );
    (void) SLang_load_string( "$2=(); $1; get_struct_field($1,$2);" );
    value = sl2pl();

    /*
     * if value = undef [ie S-Lang value == NULL] then leave alone
     * since calling hv_store with an undef value seems to delete
     * the key from the hash
     *
     * should we check for failure/NULL from hv_store?
     */
    if ( SvOK(value) )
      hv_store( hash, fieldname, strlen(fieldname), value, 0 );
    else
      SvREFCNT_dec( value );

    (void) SLang_load_string( "$1=();" );

    Printf( ("  and finished with struct field %d/%d [%s]\n", i, nfields-1,
	     fieldname) );

  } /* for: i */
  
  /* free up memory/clean-up vars */
  SLang_free_slstring( stype );
  _clean_slang_vars(2);
  return tied_object;

} /* sl2pl_struct() */

/*
 * Handle S-Lang variables for which we 
 * consider the type to be "opaque" in Perl scope - ie
 * you can assign it to a variable and send it back to S-Lang
 * but there's not a lot else you can do with it.
 * To do this we store the variable in the _inline namespace
 * and return the index string for that variable. This
 * variable gets converted to a Perl object of class
 * <typeof S-Lang variable>, which inherits
 * from Inline::SLang::_Type.
 * See the definition of the _inline namespace in SLang.pm
 * (created during the load phase of processing)
 *
 * We are called with a S-Lang variable in $1
 */
static SV *
sl2pl_opaque(void) {
  char *sltype;
  char *slkey;
  SV *perlobj;

  (void) SLang_load_string( "_inline->_store_data( $1 );" );
  UTIL_SLERR(
     SLang_pop_slstring(&slkey),
    "Error: unable to store S-Lang data"
  );
  UTIL_SLERR(
     SLang_pop_slstring(&sltype),
    "Error: unable to store S-Lang data"
  );
  _clean_slang_vars(1);
  Printf( ("Storing S-Lang type %s using key %s\n", sltype, slkey) );

  /*
   * Now create an object of the right type
   */
  CALL_METHOD_SCALAR_SV(
			sv_2mortal(newSVpv(sltype,0)),
			"new",
			C2PL_MARG_S( slkey ),
			perlobj );
  return perlobj;

} /* sl2pl_opaque() */

/*
 * convert S-Lang variables to perl variables
 */

static SV *
sl2pl_type( SLtype type ) {

  /*
   * handle the various types
   * - having separate items for all the "integer" types is
   *   probably OTT
   */
  switch( type ) {

  case SLANG_NULL_TYPE:
    /* return an undef */
    Printf( ("  stack contains: NULL\n") );
    /* clear the stack of the NULL type variable (assume it works) */
    (void) SLdo_pop_n(1);
    return &PL_sv_undef;
    break;

    /* integers */
    SL2PL_ITYPE( CHAR,  char,    char )
    SL2PL_ITYPE( SHORT, short,   short )
    SL2PL_ITYPE( INT,   integer, int )
    SL2PL_ITYPE( LONG,  long,    long )

  case SLANG_FLOAT_TYPE:
    {
      float fval;
      UTIL_SLERR(
	SLang_pop_float( &fval ),
	"Error: unable to read float value from the stack\n"
      );
      Printf( ("  stack contains: float = %g\n", fval ) );
      return newSVnv(fval);
    }

  case SLANG_DOUBLE_TYPE:
    {
      double dval;
      UTIL_SLERR(
	SLang_pop_double( &dval, NULL, NULL ),
	"Error: unable to read double value from the stack\n"
      );
      Printf( ("  stack contains: double = %g\n", dval ) );
      return newSVnv(dval);
    }

  case SLANG_STRING_TYPE:
    {
      SV *out;
      char *sval;
      UTIL_SLERR(
        SLang_pop_slstring(&sval),
	"Error: unable to read a string from the stack\n"
      );
      Printf( ("  stack contains: string = %s\n", sval ) );
      out = newSVpv( sval, 0 );
      SLang_free_slstring( sval );
      return out;
    }

  case SLANG_COMPLEX_TYPE:
    {
      /*
       * store as a Math::Complex object
       */
      SV *object;
      double real, imag;

      UTIL_SLERR(
        SLang_pop_complex( &real, &imag ),
	"Error: unable to read complex value from the stack\n"
      );
      Printf( ("  stack contains: complex %g + %g i\n", real, imag ) );

      CALL_METHOD_SCALAR_SV(
       	 sv_2mortal(newSVpv("Math::Complex",0)),
         "make",
	 C2PL_MARG_D( real ); C2PL_MARG_D( imag );,
         object );

      return object;

    } /* COMPLEX */

  case SLANG_ARRAY_TYPE:
    return sl2pl_array();
    break;

  case SLANG_ASSOC_TYPE:
    return sl2pl_assoc();
    break;

  case SLANG_DATATYPE_TYPE:
    {
      char *dname;
      SLtype dtype;

      /*
       * store the datatype value as a string of the name,
       * into an DataType_Type object
       */
      Printf( ("  stack contains: a S-Lang datatype object\n") );
      UTIL_SLERR(
		 SLang_pop_datatype( &dtype ),
		 "Internal error - unable to pop datatype off the stack"
		 );
      Printf( ("  - value == %d\n", (int) dtype) );

      dname = SLclass_get_datatype_name( dtype );
      Printf( ("  - name  == %s\n", dname) );

      /* if use newRV [== newRV_inc] then this leaks memory */
      return
	sv_bless(
		 newRV_noinc( newSVpv(dname,0) ),
		 gv_stashpv("DataType_Type",1)
		 );
      break;

    } /* DATATYPE */

  default:
    {
      /*
       * There are 2 cases:
       *  - a struct, including type-deffed ones
       *  - everything else
       *
       * Important that $1 left as value since needed by sl2pl_struct|opaque
       * routines
       */
      int is_struct;
      (void) SLang_load_string( "$1 = (); is_struct_type($1);" );
      UTIL_SLERR(
		 SLang_pop_integer( &is_struct ),
		 "Error: unable to pop an item from the S-Lang stack"
		 );

      if ( is_struct ) return sl2pl_struct();
      else             return sl2pl_opaque();

    } /* default */
  }

} /* sl2pl_type() */

/*
 * convert the object on the S-Lang stack to
 * a perl object.
 *
 * The use of the S-Lang stack may limit recursion,
 * but it's easy to stick values back onto the S-Lang
 * stack. In fact, we make use of this when processing
 * certain types.
 */

SV *
sl2pl( void ) {

  /* should we really be using SLtype instead of int? */
  int type = SLang_peek_at_stack();
  return sl2pl_type( type );

} /* sl2pl() */
