1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
|
typedef struct _Slirp_Ref { /* Ref handling code {{{ */
#define REF_FLAG_FREE_DATA 0x01
#define REF_FLAG_IS_OPAQUE 0x02
#define REF_FLAG_COLUMN_MAJOR 0x04
#define REF_FLAG_ARRAY_EXPECTED 0x08
unsigned int flags; /* Slirp_Ref encapsulates S-Lang */
SLtype sltype; /* array, ref, and MMT types, the */
size_t sizeof_type; /* latter two of which are seen as */
void **data; /* pointing to a single object */
unsigned int vstride; /* how to find "next" vectored elem */
SLang_Array_Type *array;
SLang_Ref_Type *ref;
SLang_MMT_Type *mmt; /* mmt supports passing around C */
} Slirp_Ref; /* ptr arrays of indeterminate size */
static Slirp_Ref* ref_new(SLtype t,size_t typesize, void *d,unsigned int flags)
{
Slirp_Ref *ref;
if ((ref = (Slirp_Ref*)SLcalloc( sizeof(Slirp_Ref), 1)) != NULL) {
ref->sltype = t;
ref->sizeof_type = typesize;
ref->flags = flags;
ref->data = (void**)d;
*ref->data = NULL;
}
return ref;
}
static int ref_finalize(Slirp_Ref *r) /* {{{ */
{
int status = 0;
if (r == NULL) return 0;
if (r->ref) {
void *ref_value = NULL; SLtype ref_type = 0; double dc[2];
if (r->flags & REF_FLAG_IS_OPAQUE) { /* wrap aggregates/opaques */
#ifdef NUM_RESERVED_OPAQUES /* in mmt before ref assign */
void *opaqval = *r->data; /* the mmt w/be freed when */
if (opaqval == NULL) { /* the S-Lang object goes */
ref_value = NULL; /* out of scope */
ref_type = SLANG_NULL_TYPE;
}
else {
SLang_MMT_Type *mmt = create_opaque_mmt(r->sltype, opaqval, 0);
ref_value = &mmt;
ref_type = r->sltype;
}
#endif
}
else {
ref_type = r->sltype;
if (ref_type == SLANG_COMPLEX_TYPE && r->sizeof_type < sizeof(dc)) {
float *fc = (float*) r->data;
dc[0] = fc[0];
dc[1] = fc[1];
ref_value = dc;
}
else
ref_value = r->data;
}
status = SLang_assign_to_ref (r->ref, ref_type, ref_value);
SLang_free_ref(r->ref);
}
else if (r->array) {
#ifdef HAVE_FORTRAN_CODE
if ((r->flags & REF_FLAG_COLUMN_MAJOR) && TRANSPOSE(1,r->array) == -1)
return -1;
#endif
SLang_free_array(r->array);
}
else if (r->mmt)
SLang_free_mmt(r->mmt);
if (r->flags & REF_FLAG_FREE_DATA)
SLfree( (char*) r->data );
SLfree((char*)r);
return status;
} /* }}} */
static void finalize_refs(unsigned int nargs, ...) /* {{{ */
{
va_list ap;
va_start(ap, nargs);
while (nargs--) ref_finalize(va_arg(ap, Slirp_Ref *));
va_end(ap);
} /* }}} */
static unsigned int ref_get_size(Slirp_Ref *r, int which_dimension) /* {{{ */
{
if (r->array) {
if (which_dimension == 0)
return (unsigned int)r->array->num_elements;
else if (which_dimension < 0)
return r->array->num_dims;
else {
which_dimension--;
if ((unsigned int)which_dimension < r->array->num_dims)
return (unsigned int)r->array->dims[which_dimension];
else
return 0;
}
}
return 1;
} /* }}} */
extern LINKAGE int _SLang_get_class_type (SLtype t); /* quasi-public */
#ifdef NUM_RESERVED_OPAQUES
static SLtype sltype_to_opaque_ptr_type(SLtype sltype) /*{{{*/
{
Reserved_Opaque_Type *pt;
if (sltype > Last_Reserved_Opaque_Type) return opaque_ptr_Type;
if (sltype == void_ptr_Type) return void_ptr_Type;
pt = Reserved_Opaque_Types; /* sequential search, but s/b < O(n) */
while (pt->name) { /* since list is ordered by expected */
if (pt->masked_type == sltype) /* frequency of use for each SLtype */
return *pt->type;
pt++;
}
return 0;
} /*}}}*/
#endif
static int try_pop_mmt(SLtype type, SLang_MMT_Type **mmt) /*{{{*/
{
static SLang_Name_Type *cl_type_func; /* SLang_pop_mmt doesn't */
int classtype; /* validate that type is */
/* an MMT, so we do here */
*mmt = NULL; /* FIXME: remove v2.0.7 */
if (cl_type_func == NULL)
cl_type_func = SLang_get_function( (char*) "__class_type");
if (cl_type_func == NULL)
return 0;
if (-1 == SLang_push_datatype(type) || /* do the hard way, */
-1 == SLexecute_function(cl_type_func) || /* as C api lacks */
-1 == SLang_pop_int(&classtype)) /* get_class_type() */
return -1;
if (classtype == SLANG_CLASS_TYPE_MMT) {
*mmt = SLang_pop_mmt(type);
return 1;
}
return 0;
} /*}}}*/
#define POP_FLAG_NULLABLE 0x1
#define POP_FLAG_VECTORIZE 0x2
static int pop_array_or_ref(Slirp_Ref *r, int flags, int defaultable) /*{{{*/
{
SLtype type;
unsigned int i, objtype;
#ifdef NUM_RESERVED_OPAQUES
unsigned int is_opaque;
#endif
if (r == NULL) {
SLang_verror(SLEI, (char*)"Attempted NULL reference (out of memory?)");
return -1;
}
if (defaultable && SLang_Num_Function_Args < defaultable) {
r->ref = NULL; /* observe that only NULL can be */
*r->data = NULL; /* assigned as the default value */
return 0;
}
objtype = SLang_peek_at_stack();
if ((flags & POP_FLAG_NULLABLE) && objtype == SLANG_NULL_TYPE) {
r->ref = NULL; /* nullable flag: a pointer arg for */
*r->data = NULL; /* which NULL is a legitimate value */
return SLang_pop_null ();
}
type = r->sltype;
#ifdef NUM_RESERVED_OPAQUES
is_opaque =(type >= First_Opaque_Type && sltype_to_slirp_type(type) != NULL);
if (is_opaque) r->flags |= REF_FLAG_IS_OPAQUE;
#endif
switch(objtype) {
case SLANG_ARRAY_TYPE:
if (SLang_pop_array_of_type(&r->array, type) == -1)
return -1;
#ifdef HAVE_FORTRAN_CODE
if (r->flags & REF_FLAG_COLUMN_MAJOR) {
if (flags & POP_FLAG_VECTORIZE) /* vectorizable arrs*/
r->flags ^= REF_FLAG_COLUMN_MAJOR; /* r not transposed */
else if (TRANSPOSE(0,r->array) == -1)
return -1;
}
#endif
i = r->array->num_elements;
#ifdef NUM_RESERVED_OPAQUES
if (is_opaque) {
Slirp_Opaque *ot;
SLang_MMT_Type** mmts = (SLang_MMT_Type**)r->array->data;
void **arr = (void**)SLmalloc(i * sizeof(void*) );
if (arr == NULL) return -1;
while (i--) {
ot = (Slirp_Opaque*) SLang_object_from_mmt (mmts[i]);
if (ot == NULL) {
SLfree((char*)arr);
return -1;
}
arr[i] = ot->instance;
}
*r->data = (void*)arr; r->data = (void**)arr;
r->flags |= REF_FLAG_FREE_DATA;
}
else
#endif
if (type == SLANG_COMPLEX_TYPE &&
r->sizeof_type < r->array->sizeof_type) {
double *dc = (double*) r->array->data;
float *fc = (float *) SLmalloc(i * r->sizeof_type);
if (fc == NULL) return -1;
*r->data = fc; r->data = (void**)fc;
while (i--) { *fc++ = (float) *dc++; *fc++ = (float) *dc++; }
r->flags |= REF_FLAG_FREE_DATA;
}
else {
*r->data = r->array->data;
r->data = (void**)*r->data;
}
break;
case SLANG_REF_TYPE:
/* Refs can only send values one-way (C to S-Lang, not reverse) */
if (SLang_pop_ref(&r->ref) == -1)
return -1;
/* Ref is assumed to point to a scalar instance of the */
/* refd type, so declare enough space to hold one such. */
*r->data = (void*)SLmalloc(r->sizeof_type);
if (*r->data == NULL) return -1;
memset(*r->data, 0, r->sizeof_type);
r->flags |= REF_FLAG_FREE_DATA;
r->data = (void**)*r->data;
break;
/* Allow scalars to used as if they were 1-element arrays */
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_FLOAT_TYPE: case SLANG_DOUBLE_TYPE:
case SLANG_COMPLEX_TYPE: case SLANG_STRING_TYPE:
/* Accomodate FORTRAN-style pass by reference semantics */
if (map_scalars_to_refs &&
SLang_pop_array_of_type(&r->array,type) == 0) {
*r->data = (void*)SLmalloc(r->sizeof_type);
if (*r->data == NULL) return -1;
if (r->sizeof_type == r->array->sizeof_type)
memcpy(*r->data, r->array->data, r->sizeof_type);
else if (type == SLANG_COMPLEX_TYPE) {
double *dc = (double*) r->array->data;
float *fc = (float*) *r->data;
fc[0] = (float)dc[0];
fc[1] = (float)dc[1];
}
else {
SLang_verror(SL_TYPE_MISMATCH, (char*)
"mismatched type sizes, when popping scalar as ref");
SLang_free_array(r->array);
return -1;
}
r->data = (void**)*r->data;
r->flags |= REF_FLAG_FREE_DATA;
/* Nullify to distinguish between vectored/non-vectored args */
SLang_free_array(r->array); r->array = NULL;
break;
} /* intentional fallthrough */
default:
#ifdef NUM_RESERVED_OPAQUES
if (objtype >= First_Opaque_Type &&
sltype_to_slirp_type(objtype) != NULL) {
if (!(flags & POP_FLAG_VECTORIZE))
type = sltype_to_opaque_ptr_type(type);
if (type) {
Slirp_Opaque *otp;
if (SLang_pop_opaque(type, NULL, &otp) == -1)
return -1;
if (flags & POP_FLAG_VECTORIZE) {
void **arr = (void**) SLmalloc(sizeof(void*));
if (arr == NULL) return -1;
arr[0] = otp->instance;
*r->data = arr;
r->flags |= REF_FLAG_FREE_DATA;
}
else
*r->data = otp->instance;
r->data = (void**)*r->data;
r->mmt = otp->mmt;
return 0;
}
}
else
#endif
if ( try_pop_mmt(objtype, &r->mmt) == 1 &&
(*r->data = SLang_object_from_mmt (r->mmt)) != NULL) {
r->data = (void**)*r->data; /* not flagged for freeing */
return 0;
}
SLang_verror(SL_TYPE_MISMATCH, (char*)
"context requires array, ref, or opaque pointer");
return -1;
}
return 0;
} /*}}}*/
/* }}} */
|