ports//science/ruby-dcl/work/ruby-dcl-1.5.2/dcl

/*
 * dcl_obj2cary.c
 *   $Id: dcl_obj2cary.c,v 1.2 2000/11/12 00:37:37 keiko Exp $
 */

#include <math.h>
#include "ruby.h"
#include "version.h"
#include "libtinyf2c.h"
#include "narray.h"

extern VALUE mDCL;

/*  functions  */
char    *obj2ccharary(VALUE, int, int);
integer *obj2cintegerary(VALUE);
real    *obj2crealary(VALUE);
complex *obj2ccomplexary(VALUE);
logical *obj2clogicalary(VALUE);

void dcl_freeccharary(char *);
void dcl_freecintegerary(integer *);
void dcl_freecrealary(real *);
void dcl_freeccomplexary(complex *);
void dcl_freeclogicalary(logical *);

static char    *ary2ccharary(VALUE, int, int);
static integer *ary2cintegerary(VALUE);
static real    *ary2crealary(VALUE);
static logical *ary2clogicalary(VALUE);
/* not implemented
static complex *ary2ccomplexary(VALUE);
*/

static real    *na2crealary(VALUE);
static logical *na2clogicalary(VALUE);
static integer *na2cintegerary(VALUE);
/* not implemented
static complex *na2ccomplexary(VALUE);
*/

/*  defines  */
#define BE_INTEGER(x) ((integer)(NUM2INT(rb_Integer(x))))
#define BE_REAL(x)    ((real)(RFLOAT(rb_Float(x))->value))
#define BE_LOGICAL(x) (((x == Qnil) || (x == Qfalse)) ? FALSE_ : TRUE_ )
/* not implemented 
#define BE_COMPLEX(x) ...
*/


/*
 * dcl_obj2cxxxary() : convert ruby object to c xxx type array
 *   dcl_obj2ccharary()
 *   dcl_obj2cintegerary()
 *   dcl_obj2crealary()
 *   dcl_obj2ccomplexary() : not implemented
 *   dcl_obj2clogicalary()
 */
char *
dcl_obj2ccharary(src, size, len)
    VALUE src;
    int size;
    int len;
{
    VALUE chk;
    char *rtn;

    switch (TYPE(src)){
    case T_ARRAY:
        rtn = ary2ccharary(src, size, len);
        break;
    default:
        rb_raise(rb_eTypeError, "expect integer array");
        break;
    }
    return rtn;
}

integer *
dcl_obj2cintegerary(src)
    VALUE src;
{
    VALUE chk;
    integer *rtn;

    switch (TYPE(src)){
    case T_DATA:
        chk = rb_obj_is_kind_of(src, cNArray);
        if (chk == Qfalse) {
            rb_raise(rb_eTypeError, "expect integer array");
        }
        rtn = na2cintegerary(src);
        break;
    case T_ARRAY:
        rtn = ary2cintegerary(src);
        break;
    default:
        rb_raise(rb_eTypeError, "expect integer array");
        break;
    }

    return rtn;
}

real *
dcl_obj2crealary(src)
    VALUE src;
{
    VALUE chk;
    real *rtn;
    char *klass;
    VALUE rmiss;

    switch (TYPE(src)){
    case T_OBJECT:
	klass = STR2CSTR( rb_funcall(rb_funcall(src, rb_intern("class"),0),
				     rb_intern("to_s"),0) );
	if (strncmp(klass,"NArrayMiss",10) != 0) {
	    rb_raise(rb_eTypeError, "a numeric array expected");
	}
	rmiss = rb_funcall(mDCL,rb_intern("glrget"),1,rb_str_new2("rmiss"));
	src = rb_funcall( src, rb_intern("to_na"), 1, rmiss );
    case T_DATA:
        chk = rb_obj_is_kind_of(src, cNArray);
        rtn = na2crealary(src);
        break;
    case T_ARRAY:
        rtn = ary2crealary(src);
        break;
    default:
        rb_raise(rb_eTypeError, "expect real array");
        break;
    }

    return rtn;
}

/* not implemented
complex *
dcl_obj2ccomplexary(src)
    VALUE src;
{
    VALUE chk;
    complex *rtn;

    switch (TYPE(src)){
    case T_DATA:
        chk = rb_obj_is_kind_of(src, cNArray);
        if (chk == Qfalse) {
            rb_raise(rb_eTypeError, "expect complex array");
        }
        rtn = na2ccomplexary(src);
        break;
    case T_ARRAY:
        rtn = ary2ccomplexary(src);
        break;
    default:
        rb_raise(rb_eTypeError, "expect complex array");
        break;
    }
    
    return rtn;
}
*/

logical *
dcl_obj2clogicalary(src)
    VALUE src;
{
    VALUE chk;
    logical *rtn;

    switch (TYPE(src)){
    case T_DATA:
	chk = rb_obj_is_kind_of(src, cNArray);
        if (chk == Qfalse) {
            rb_raise(rb_eTypeError, "expect logical array");
        }
        rtn = na2clogicalary(src);
        break;
    case T_ARRAY:
        rtn = ary2clogicalary(src);
        break;
    default:
        rb_raise(rb_eTypeError, "expect logical array");
        break;
    }

    return rtn;
}

/*
 * dcl_freecxxxary() : free c xxx type array
 *                     allocated by ary2cxxxary() or na2cxxxary()
 *   dcl_freeccharary()
 *   dcl_freecintegerary()
 *   dcl_freecrealary()
 *   dcl_freeccomplexary() : not implemented
 *   dcl_freeclogicalary()
 */
void
dcl_freeccharary(cary)
    char *cary;
{
    if ( cary != NULL ) {
	free(cary);
    }
    return;
}

void
dcl_freecintegerary(cary)
    integer *cary;
{
    if ( cary != NULL ) {
	free(cary);
    }
    return;
}

void
dcl_freecrealary(cary)
    real *cary;
{
    if ( cary != NULL ) {
	free(cary);
    }
    return;
}

/* not implemented
void
dcl_freeccomplexary(cary)
    complex *cary;
{
    if ( cary != NULL ) {
	free(cary);
    }
    return;
}
*/

void
dcl_freeclogicalary(cary)
    logical *cary;
{
    if ( cary != NULL ) {
	free(cary);
    }
    return;
}


/*
 *  ary2cxxxary() : convert Array object to c xxx type array
 *                  called by obj2cxxxary()
 *   ary2ccharary()
 *   ary2cintegerary()
 *   ary2crealary()
 *   ary2ccomplexary() : not implemented
 *   ary2clogicalary()
 */
static char *
ary2ccharary(src, size, charlen)
    VALUE src;
    int size;
    int charlen;
{
    VALUE *ptr;
    long len, i, j;
#if RUBY_VERSION_CODE > 170
    long rlen;
#else
    int rlen;
#endif
    char *rtn, *wk, *rwk;

    Check_Type(src, T_ARRAY);

    len = RARRAY(src)->len;
    ptr = RARRAY(src)->ptr;

    rtn = ALLOC_N(char, size);
    memset(rtn, '\0', size);
    wk = rtn;
    for (i = 0; i < len; i++) {
	rwk = rb_str2cstr(ptr[i], &rlen);
	j = rlen;
        strncpy(wk, rwk, charlen);
        while (j < charlen) {
            wk[j++] = ' ';
        }
        wk += charlen;
    }
    return rtn;
}

static integer *
ary2cintegerary(src)
    VALUE src;
{
    VALUE *ptr;
    int len, i;
    integer *rtn;

    Check_Type(src, T_ARRAY);

    len = RARRAY(src)->len;
    ptr = RARRAY(src)->ptr;

    rtn = ALLOC_N(integer, len);

    for (i = 0; i < len; i++) {
        rtn[i] = BE_INTEGER(ptr[i]);
    }

    return rtn;
}

static real *
ary2crealary(src)
    VALUE src;
{
    VALUE *ptr;
    int len, i;
    real *rtn;

    Check_Type(src, T_ARRAY);

    len = RARRAY(src)->len;
    ptr = RARRAY(src)->ptr;

    rtn = ALLOC_N(real, len);

    for (i = 0; i < len; i++) {
	rtn[i] = BE_REAL(ptr[i]);
    }

    return rtn;
}

/* not implemented
static complex *
ary2ccomplexary(src)
     VALUE src;
{
    VALUE *ptr;
    int len, i;
    complex *rtn;

    Check_Type(src, T_ARRAY);

    len = RARRAY(src)->len;
    ptr = RARRAY(src)->ptr;

    rtn = ALLOC_N(complex, len);

    for (i = 0; i < len; i++) {
      rtn[i] = BE_COMPLEX(src...);
    }

    return rtn;
}
*/

static logical *
ary2clogicalary(src)
    VALUE src;
{
    VALUE *ptr;
    int len, i;
    logical *rtn;

    Check_Type(src, T_ARRAY);

    len = RARRAY(src)->len;
    ptr = RARRAY(src)->ptr;

    rtn = ALLOC_N(logical, len);

    for (i = 0; i < len; i++) {
        rtn[i] = BE_LOGICAL(ptr[i]);
    }

    return rtn;
}


#define NA2PTR(obj) ((NA*)DATA_PTR(obj))->bna->ptr
#define NA2LEN(obj) ((NA*)DATA_PTR(obj))->bna->len

/*
 *  na2cxxxary() : convert NArray object to c xxx type array
 *                 called by obj2cxxxary()
 *   na2cintegerary() : not implemented
 *   na2crealary()
 *   na2ccomplexary() : not implemented
 *   na2clogicalary()
 */
static real *
na2crealary(src)
    VALUE src;
{
    VALUE chk;
    int len, i;
    real *rtn;
    float *ptr;
    struct NARRAY *na;

    chk = rb_obj_is_kind_of(src, cNArray);
    if (chk == Qfalse) {
        rb_raise(rb_eTypeError, "expect NArray");
    }

    src = na_cast_object(src, NA_SFLOAT);
    GetNArray(src, na);
    len = na->total;
    ptr = (float *)NA_PTR(na, 0);

    rtn = ALLOC_N(real, len);

    for (i = 0; i < len; i++) {
	rtn[i] = (real)ptr[i];
    }
    
    return rtn;
}
static integer *
na2cintegerary(src)
    VALUE src;
{
    VALUE chk;
    int len, i;
    integer *rtn;
    int32_t *ptr;
    struct NARRAY *na;

    chk = rb_obj_is_kind_of(src, cNArray);
    if (chk == Qfalse) {
        rb_raise(rb_eTypeError, "expect NArray");
    }

    src = na_cast_object(src, NA_LINT);
    GetNArray(src, na);
    len = na->total;
    ptr = (int32_t *)NA_PTR(na, 0);

    rtn = ALLOC_N(integer, len);

    for (i = 0; i < len; i++) {
	rtn[i] = (integer)ptr[i];
    }
    
    return rtn;
}

static logical *
na2clogicalary(src)
    VALUE src;
{
    VALUE chk;
    struct NARRAY *na;
    int len, i;
    logical *rtn;
    unsigned char *ptr;

    chk = rb_obj_is_kind_of(src, cNArray);
    if (chk == Qfalse) {
        rb_raise(rb_eTypeError, "expect NArray");
    }

    src = na_cast_object(src, NA_BYTE);
    GetNArray(src, na);
    len = na->total;
    ptr = (unsigned char *)NA_PTR(na, 0);

    rtn = ALLOC_N(logical, len);

    for (i = 0; i < len; i++) {
	rtn[i] = (logical)ptr[i];
    }
    
    return rtn;
}
syntax highlighted by Code2HTML, v. 0.9.1