static SLang_Foreach_Context_Type *
cl_foreach_open (SLtype type, unsigned int num)
{
SLang_Foreach_Context_Type *c;
(void) type;
if (num != 0)
{
_pSLang_verror (SL_NOT_IMPLEMENTED,
"%s does not support 'foreach using' form",
SLclass_get_datatype_name (type));
return NULL;
}
if (NULL == (c = (SLang_Foreach_Context_Type *) SLcalloc (1, sizeof (SLang_Foreach_Context_Type))))
return NULL;
if (-1 == pop_list (&c->list))
{
SLfree ((char *) c);
return NULL;
}
return c;
}
static char *arith_string (SLtype type, VOID_STAR v)
{
char buf [1024];
char *s;
s = buf;
switch (type)
{
default:
s = (char *) SLclass_get_datatype_name (type);
break;
case SLANG_CHAR_TYPE:
sprintf (s, "%d", *(char *) v);
break;
case SLANG_UCHAR_TYPE:
sprintf (s, "%u", *(unsigned char *) v);
break;
case SLANG_SHORT_TYPE:
sprintf (s, "%d", *(short *) v);
break;
case SLANG_USHORT_TYPE:
sprintf (s, "%u", *(unsigned short *) v);
break;
case SLANG_INT_TYPE:
sprintf (s, "%d", *(int *) v);
break;
case SLANG_UINT_TYPE:
sprintf (s, "%u", *(unsigned int *) v);
break;
case SLANG_LONG_TYPE:
sprintf (s, "%ld", *(long *) v);
break;
case SLANG_ULONG_TYPE:
sprintf (s, "%lu", *(unsigned long *) v);
break;
#ifdef HAVE_LONG_LONG
case SLANG_LLONG_TYPE:
sprintf (s, "%lld", *(long long *) v);
break;
case SLANG_ULLONG_TYPE:
sprintf (s, "%llu", *(unsigned long long *) v);
break;
#endif
#if SLANG_HAS_FLOAT
case SLANG_FLOAT_TYPE:
if (EOF == SLsnprintf (buf, sizeof (buf), Double_Format, *(float *) v))
sprintf (s, "%e", *(float *) v);
break;
case SLANG_DOUBLE_TYPE:
if (EOF == SLsnprintf (buf, sizeof (buf), Double_Format, *(double *) v))
sprintf (s, "%e", *(double *) v);
break;
#endif
}
return SLmake_string (s);
}
static int method_undefined_error (SLtype type, SLCONST char *method, SLCONST char *name)
{
if (name == NULL) name = SLclass_get_datatype_name (type);
_pSLang_verror (SL_TYPE_MISMATCH, "%s method not defined for %s",
method, name);
return -1;
}
static char *default_string (SLtype stype, VOID_STAR v)
{
char buf [256];
char *s;
#if SLANG_HAS_COMPLEX
double *cplx;
#endif
s = buf;
switch (stype)
{
case SLANG_STRING_TYPE:
s = *(char **) v;
break;
case SLANG_NULL_TYPE:
s = (char *) "NULL";
break;
case SLANG_DATATYPE_TYPE:
s = (char *) SLclass_get_datatype_name ((SLtype) *(int *)v);
break;
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
cplx = *(double **) v;
if (cplx[1] < 0)
sprintf (s, "(%g - %gi)", cplx [0], -cplx [1]);
else
sprintf (s, "(%g + %gi)", cplx [0], cplx [1]);
break;
#endif
default:
s = (char *) SLclass_get_datatype_name (stype);
}
return SLmake_string (s);
}
int (*_pSLclass_get_typecast (SLtype from, SLtype to, int is_implicit))
(SLtype, VOID_STAR, unsigned int,
SLtype, VOID_STAR)
{
SL_Typecast_Type *t;
SLang_Class_Type *cl_from;
cl_from = _pSLclass_get_class (from);
t = cl_from->cl_typecast_funs;
while (t != NULL)
{
if (t->data_type != to)
{
t = t->next;
continue;
}
if (is_implicit && (t->allow_implicit == 0))
break;
return t->typecast;
}
if (to == SLANG_ANY_TYPE)
return &_pSLanytype_typecast;
if ((is_implicit == 0)
&& (cl_from->cl_void_typecast != NULL))
return cl_from->cl_void_typecast;
_pSLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
cl_from->cl_name,
SLclass_get_datatype_name (to));
return NULL;
}
static void print_array (void) /*{{{*/
{
enum
{
screen_rows=24,
screen_cols=10
};
SLang_Array_Type *at;
unsigned int i, num_rows, num_cols;
unsigned char type;
VOID_STAR v;
FILE *fp;
int just_one_line;
unsigned int num;
if (-1 == pop_matrix (&at, &num_rows, &num_cols))
return;
type = at->data_type;
switch (type)
{
case SLANG_CHAR_TYPE:
case SLANG_UCHAR_TYPE:
case SLANG_SHORT_TYPE:
case SLANG_USHORT_TYPE:
case SLANG_INT_TYPE:
case SLANG_UINT_TYPE:
case SLANG_LONG_TYPE:
case SLANG_ULONG_TYPE:
case SLANG_DOUBLE_TYPE:
case SLANG_FLOAT_TYPE:
case SLANG_COMPLEX_TYPE:
break;
case SLANG_STRING_TYPE:
break;
default:
SLang_verror (SL_TYPE_MISMATCH, "print_array: %s is not supported",
SLclass_get_datatype_name (type));
SLang_free_array (at);
return;
}
fp = NULL;
if ((num_rows > screen_rows) || (num_cols > screen_cols))
fp = isis_open_pager ();
if (fp == NULL) fp = stdout;
v = at->data;
just_one_line = 0;
num = 0;
for (i = 0; i < num_rows; i++)
{
unsigned int j;
for (j = 0; j < num_cols; j++)
{
int ok;
switch (type)
{
case SLANG_CHAR_TYPE:
ok = fprintf (fp, "%d\t", (int)((char *)v)[num]);
break;
case SLANG_UCHAR_TYPE:
ok = fprintf (fp, "%d\t", (int)((unsigned char *)v)[num]);
break;
case SLANG_SHORT_TYPE:
ok = fprintf (fp, "%hd\t", ((short *)v)[num]);
break;
case SLANG_USHORT_TYPE:
ok = fprintf (fp, "%hu\t", ((unsigned short *)v)[num]);
break;
case SLANG_INT_TYPE:
ok = fprintf (fp, "%d\t", ((int *)v)[num]);
break;
case SLANG_UINT_TYPE:
ok = fprintf (fp, "%u\t", ((unsigned int *)v)[num]);
break;
case SLANG_LONG_TYPE:
ok = fprintf (fp, "%ld\t", ((long *)v)[num]);
break;
case SLANG_ULONG_TYPE:
ok = fprintf (fp, "%lu\t", ((unsigned long *)v)[num]);
break;
case SLANG_FLOAT_TYPE:
ok = fprintf (fp, "%e ", ((float *)v)[num]);
break;
case SLANG_DOUBLE_TYPE:
ok = fprintf (fp, "%e ", ((double *)v)[num]);
break;
case SLANG_STRING_TYPE:
ok = fprintf (fp, "\"%s\" ", ((char **)v)[num]);
break;
case SLANG_COMPLEX_TYPE:
ok = fprintf (fp, "(%e, %e) ",
((double *)v)[num], ((double *)v)[num+1]);
num++;
break;
default:
ok = -1;
}
if (ok <= 0)
goto done;
num++;
}
if (fputs ("\n", fp) < 0)
break;
if ((Isis_Batch_Mode == 0)
&& (fp == stdout)
&& (((num_rows > screen_rows && (0 == (num_rows % screen_rows))) && (num_rows != 0))
|| just_one_line))
{
unsigned int key;
if (just_one_line == 0)
fprintf (stdout, "Press SPACE to continue");
fflush (stdout);
key = isis_getkey ();
if (key == ' ')
just_one_line = 0;
else if (key == '\r')
just_one_line = 1;
else break;
}
}
done:
if (fp != stdout)
isis_close_pager (fp);
fputs ("\n", stdout);
SLang_free_array (at);
}
static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction,
int dim_specified, int *use_this_dim,
VOID_STAR clientdata)
{
int k, use_all_dims;
SLang_Array_Type *at, *new_at;
SLindex_Type *old_dims;
SLindex_Type old_dims_buf[SLARRAY_MAX_DIMS];
SLindex_Type sub_dims[SLARRAY_MAX_DIMS];
SLindex_Type tmp_dims[SLARRAY_MAX_DIMS];
unsigned int i, j, old_num_dims, sub_num_dims;
SLtype new_data_type, old_data_type;
char *old_data, *new_data;
SLindex_Type w[SLARRAY_MAX_DIMS], wk;
size_t old_sizeof_type, new_sizeof_type;
SLuindex_Type dims_k;
int from_type;
SLCONST SLarray_Map_Type *csave;
SLarray_Map_Fun_Type *fmap;
SLarray_Contract_Fun_Type *fcon;
use_all_dims = 1;
k = 0;
if (dim_specified)
{
if (use_this_dim != NULL)
{
k = *use_this_dim;
use_all_dims = 0;
}
}
else if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_integer (&k))
return -1;
use_all_dims = 0;
}
if (-1 == (from_type = SLang_peek_at_stack1 ()))
return -1;
csave = c;
while (c->f != NULL)
{
if (c->from_type == (SLtype) from_type)
break;
c++;
}
/* Look for a more generic version */
if (c->f != NULL)
{
if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
return -1;
}
else
{
/* Look for a wildcard match */
c = csave;
while (c->f != NULL)
{
if (c->from_type == SLANG_VOID_TYPE)
break;
c++;
}
if (c->f == NULL)
{
_pSLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type));
return -1;
}
/* Found it. So, typecast it to appropriate type */
if (c->typecast_to_type == SLANG_VOID_TYPE)
{
if (-1 == SLang_pop_array (&at, 1))
return -1;
}
else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
return -1;
}
old_data_type = at->data_type;
if (SLANG_VOID_TYPE == (new_data_type = c->result_type))
new_data_type = old_data_type;
old_num_dims = at->num_dims;
if (use_all_dims == 0)
{
if (k < 0)
k += old_num_dims;
if ((k < 0) || (k >= (int)old_num_dims))
{
_pSLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array",
k, old_num_dims);
SLang_free_array (at);
return -1;
}
old_dims = at->dims;
}
else
{
old_dims = old_dims_buf;
old_dims[0] = (SLindex_Type)at->num_elements;
old_num_dims = 1;
}
fcon = (SLarray_Contract_Fun_Type *) c->f;
fmap = c->f;
if (use_contraction
&& (use_all_dims || (old_num_dims == 1)))
{
SLang_Class_Type *cl;
VOID_STAR buf;
int status = 0;
cl = _pSLclass_get_class (new_data_type);
buf = cl->cl_transfer_buf;
if (at->num_elements == 0)
{
/* If there are no elements, the fcon may or may not
* compute a value. So, clear the buffer
*/
memset ((char *)buf, 0, cl->cl_sizeof_type);
}
if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf))
|| (-1 == SLang_push_value (new_data_type, buf)))
status = -1;
SLang_free_array (at);
return status;
}
/* The offset for the index i_0,i_1,...i_{N-1} is
* i_0*W_0 + i_1*W_1 + ... i_{N-1}*W{N-1}
* where W_j = d_{j+1}d_{j+2}...d_{N-1}
* and d_k is the number of elements of the kth dimension.
*
* For a specified value of k, we
* So, summing over all elements in the kth dimension of the array
* means using the set of offsets given by
*
* i_k*W_k + sum(j!=k) i_j*W_j.
*
* So, we want to loop of all dimensions except for the kth using an
* offset given by sum(j!=k)i_jW_j, and an increment W_k between elements.
*/
wk = 1;
i = old_num_dims;
while (i != 0)
{
i--;
w[i] = wk;
wk *= old_dims[i];
}
wk = w[k];
/* Now set up the sub array */
j = 0;
for (i = 0; i < old_num_dims; i++)
{
if (i == (unsigned int) k)
continue;
sub_dims[j] = old_dims[i];
w[j] = w[i];
tmp_dims[j] = 0;
j++;
}
sub_num_dims = old_num_dims - 1;
if (use_contraction)
new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1);
else
new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1);
if (new_at == NULL)
{
SLang_free_array (at);
return -1;
}
new_data = (char *)new_at->data;
old_data = (char *)at->data;
old_sizeof_type = at->sizeof_type;
new_sizeof_type = new_at->sizeof_type;
dims_k = old_dims[k] * wk;
/* Skip this for cases such as sum(Double_Type[0,0], 1). Otherwise,
* (*fcon) will write to new_data, which has no length
*/
if (new_at->num_elements) do
{
size_t offset = 0;
int status;
for (i = 0; i < sub_num_dims; i++)
offset += w[i] * tmp_dims[i];
if (use_contraction)
{
status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk,
dims_k, (VOID_STAR) new_data);
new_data += new_sizeof_type;
}
else
{
status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type),
wk, dims_k,
new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type),
clientdata);
}
if (status == -1)
{
SLang_free_array (new_at);
SLang_free_array (at);
return -1;
}
}
while (-1 != _pSLarray_next_index (tmp_dims, sub_dims, sub_num_dims));
SLang_free_array (at);
return SLang_push_array (new_at, 1);
}
int
SLclass_typecast (SLtype to_type, int is_implicit, int allow_array)
{
SLtype from_type;
SLang_Class_Type *cl_to, *cl_from;
SLang_Object_Type obj;
VOID_STAR ap;
VOID_STAR bp;
int status;
if (-1 == SLang_pop (&obj))
return -1;
from_type = obj.o_data_type;
if (from_type == to_type)
return SLang_push (&obj);
cl_from = _pSLclass_get_class (from_type);
cl_to = _pSLclass_get_class (to_type);
/* Check for alias, e.g., int and long */
if (cl_from == cl_to)
{
obj.o_data_type = to_type;
return SLang_push (&obj);
}
/* Since the typecast functions are designed to work on arrays,
* get the pointer to the value instead of just &obj.v.
*/
ap = _pSLclass_get_ptr_to_value (cl_from, &obj);
if ((from_type == SLANG_ARRAY_TYPE)
&& (allow_array || (to_type != SLANG_ANY_TYPE)))
{
if (allow_array == 0)
goto return_error;
cl_to = _pSLclass_get_class (SLANG_ARRAY_TYPE);
bp = cl_to->cl_transfer_buf;
status = _pSLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit);
}
else
{
int (*t) (SLtype, VOID_STAR, unsigned int, SLtype, VOID_STAR);
if (NULL == (t = _pSLclass_get_typecast (from_type, to_type, is_implicit)))
{
SLang_free_object (&obj);
return -1;
}
bp = cl_to->cl_transfer_buf;
status = (*t) (from_type, ap, 1, to_type, bp);
}
if (1 == status)
{
/* AnyType apush will do a reference, which is undesirable here.
* So, to avoid that, perform push instead of apush. Yes, this is
* an ugly hack.
*/
if (to_type == SLANG_ANY_TYPE)
status = (*cl_to->cl_push)(to_type, bp);
else
status = (*cl_to->cl_apush)(to_type, bp);
if (status == -1)
{
(*cl_to->cl_adestroy) (to_type, bp);
SLang_free_object (&obj);
return -1;
}
/* cl_apush will push a copy, so destry this one */
(*cl_to->cl_adestroy) (to_type, bp);
SLang_free_object (&obj);
return 0;
}
return_error:
_pSLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
cl_from->cl_name,
SLclass_get_datatype_name (to_type));
SLang_free_object (&obj);
return -1;
}
/* Misc */
void _pSLclass_type_mismatch_error (SLtype a, SLtype b)
{
_pSLang_verror (SL_TYPE_MISMATCH, "Expecting %s, found %s",
SLclass_get_datatype_name (a),
SLclass_get_datatype_name (b));
}
