lablGL/ml_raw.c

   1 /* $Id: ml_raw.c,v 1.16 2007-04-13 02:48:43 garrigue Exp $ */
   2
   3 #include <string.h>
   4 #include <caml/misc.h>
   5 #include <caml/mlvalues.h>
   6 #include <caml/memory.h>
   7 #include <caml/alloc.h>
   8 #include <caml/config.h>
   9 #include "raw_tags.h"
  10 #include "ml_raw.h"
  11
  12 #define SIZE_BYTE       sizeof(char)
  13 #define SIZE_SHORT      sizeof(short)
  14 #define SIZE_INT        sizeof(int)
  15 #define SIZE_LONG       sizeof(long)
  16 #define SIZE_FLOAT      sizeof(float)
  17 #define SIZE_DOUBLE     sizeof(double)
  18
  19 extern void caml_invalid_argument (char *) Noreturn;
  20
  21 static int raw_sizeof (value kind)
  22 {
  23     switch (kind) {
  24     case MLTAG_bitmap:
  25     case MLTAG_byte:
  26     case MLTAG_ubyte:
  27         return SIZE_BYTE;
  28     case MLTAG_short:
  29     case MLTAG_ushort:
  30         return SIZE_SHORT;
  31     case MLTAG_int:
  32     case MLTAG_uint:
  33         return SIZE_INT;
  34     case MLTAG_long:
  35     case MLTAG_ulong:
  36         return SIZE_LONG;
  37     case MLTAG_float:
  38         return SIZE_FLOAT;
  39     case MLTAG_double:
  40         return SIZE_DOUBLE;
  41     }
  42     return 0;
  43 }
  44
  45 CAMLprim value ml_raw_sizeof (value kind)  /* ML */
  46 {
  47     return Val_int(raw_sizeof(kind));
  48 }
  49
  50 static void check_size (value raw, long pos, char *msg)
  51 {
  52     if (pos < 0 ||
  53         (pos+1) * raw_sizeof(Kind_raw(raw)) > Int_val(Size_raw(raw)))
  54         caml_invalid_argument (msg);
  55 }
  56
  57 CAMLprim value ml_raw_get (value raw, value pos)  /* ML */
  58 {
  59     long i = Long_val(pos);
  60
  61     check_size (raw,i,"Raw.get");
  62     switch (Kind_raw(raw)) {
  63     case MLTAG_bitmap:
  64     case MLTAG_ubyte:
  65         return Val_long ((unsigned char) Byte_raw(raw)[i]);
  66     case MLTAG_byte:
  67         return Val_long (Byte_raw(raw)[i]);
  68     case MLTAG_short:
  69         return Val_long (Short_raw(raw)[i]);
  70     case MLTAG_ushort:
  71         return Val_long ((unsigned short) Short_raw(raw)[i]);
  72     case MLTAG_int:
  73         return Val_long (Int_raw(raw)[i]);
  74     case MLTAG_uint:
  75         return Val_long ((unsigned int) Int_raw(raw)[i]);
  76     case MLTAG_long:
  77         return Val_long (Long_raw(raw)[i]);
  78     case MLTAG_ulong:
  79         return Val_long ((unsigned long) Long_raw(raw)[i]);
  80     }
  81     return Val_unit;
  82 }
  83
  84 CAMLprim value ml_raw_read (value raw, value pos, value len)  /* ML */
  85 {
  86     int s = Int_val(pos);
  87     int i, l = Int_val(len);
  88     value ret;
  89
  90     check_size (raw,s+l-1,"Raw.read");
  91     if (l<0 || s<0) caml_invalid_argument("Raw.read");
  92     ret = caml_alloc_shr (l, 0);
  93     switch (Kind_raw(raw)) {
  94     case MLTAG_bitmap:
  95     case MLTAG_ubyte:
  96     {
  97         unsigned char *byte_raw = (unsigned char *)Byte_raw(raw)+s;
  98         for (i = 0; i < l; i++)
  99             Field(ret,i) = Val_long (*byte_raw++);
 100         break;
 101     }
 102     case MLTAG_byte:
 103     {
 104         char *byte_raw = Byte_raw(raw)+s;
 105         for (i = 0; i < l; i++)
 106             Field(ret,i) = Val_long (*byte_raw++);
 107         break;
 108     }
 109     case MLTAG_short:
 110     {
 111         short *short_raw = Short_raw(raw)+s;
 112         for (i = 0; i < l; i++)
 113             Field(ret,i) = Val_long (*short_raw++);
 114         break;
 115     }
 116     case MLTAG_ushort:
 117     {
 118         unsigned short *short_raw = (unsigned short *)Short_raw(raw)+s;
 119         for (i = 0; i < l; i++)
 120             Field(ret,i) = Val_long (*short_raw++);
 121         break;
 122     }
 123     case MLTAG_int:
 124     {
 125         int *int_raw = Int_raw(raw)+s;
 126         for (i = 0; i < l; i++)
 127             Field(ret,i) = Val_long (*int_raw++);
 128         break;
 129     }
 130     case MLTAG_uint:
 131     {
 132         unsigned int *int_raw = (unsigned int *)Int_raw(raw)+s;
 133         for (i = 0; i < l; i++)
 134             Field(ret,i) = Val_long (*int_raw++);
 135         break;
 136     }
 137     case MLTAG_long:
 138     {
 139         long *long_raw = Long_raw(raw)+s;
 140         for (i = 0; i < l; i++)
 141             Field(ret,i) = Val_long (*long_raw++);
 142         break;
 143     }
 144     case MLTAG_ulong:
 145     {
 146         unsigned long *long_raw = (unsigned long *)Long_raw(raw)+s;
 147         for (i = 0; i < l; i++)
 148             Field(ret,i) = Val_long (*long_raw++);
 149         break;
 150     }
 151     }
 152     return ret;
 153 }
 154
 155 CAMLprim value ml_raw_read_string (value raw, value pos, value len)  /* ML */
 156 {
 157     CAMLparam1(raw);
 158     int s = Int_val(pos);
 159     int l = Int_val(len);
 160     value ret;
 161
 162     if (l<0 || s<0 || s+l > Int_val(Size_raw(raw)))
 163         caml_invalid_argument("Raw.read_string");
 164     ret = caml_alloc_string (l);
 165     memcpy (Bp_val(ret), Bp_val(Addr_raw(raw))+s, l);
 166     CAMLreturn(ret);
 167 }
 168
 169 CAMLprim value ml_raw_write_string (value raw, value pos, value data)  /* ML */
 170 {
 171     int s = Int_val(pos);
 172     int l = caml_string_length(data);
 173
 174     if (s<0 || s+l > Int_val(Size_raw(raw)))
 175         caml_invalid_argument("Raw.write_string");
 176     memcpy (Bp_val(Addr_raw(raw))+s, String_val(data), l);
 177     return Val_unit;
 178 }
 179
 180 CAMLprim value ml_raw_set (value raw, value pos, value data)  /* ML */
 181 {
 182     long i = Long_val(pos);
 183
 184     check_size (raw,i,"Raw.set");
 185     switch (Kind_raw(raw)) {
 186     case MLTAG_bitmap:
 187     case MLTAG_ubyte:
 188     case MLTAG_byte:
 189         Byte_raw(raw)[i] = Long_val(data);
 190         break;
 191     case MLTAG_short:
 192     case MLTAG_ushort:
 193         Short_raw(raw)[i] = Long_val(data);
 194         break;
 195     case MLTAG_int:
 196         Int_raw(raw)[i] = Long_val(data);
 197         break;
 198     case MLTAG_uint:
 199         Int_raw(raw)[i] = Long_val((unsigned long) data);
 200         break;
 201     case MLTAG_long:
 202         Long_raw(raw)[i] = Long_val(data);
 203         break;
 204     case MLTAG_ulong:
 205         Long_raw(raw)[i] = Long_val((unsigned long) data);
 206         break;
 207     }
 208     return Val_unit;
 209 }
 210
 211 CAMLprim value ml_raw_write (value raw, value pos, value data)  /* ML */
 212 {
 213     int s = Int_val(pos);
 214     int i, l = Wosize_val(data);
 215
 216     check_size (raw,s+l-1,"Raw.write");
 217     if (s<0) caml_invalid_argument("Raw.write");
 218
 219     switch (Kind_raw(raw)) {
 220     case MLTAG_bitmap:
 221     case MLTAG_ubyte:
 222     case MLTAG_byte:
 223     {
 224         char *byte_raw = Byte_raw(raw)+s;
 225         for (i = 0; i < l; i++)
 226             *byte_raw++ = Long_val(Field(data,i));
 227         break;
 228     }
 229     case MLTAG_short:
 230     case MLTAG_ushort:
 231     {
 232         short *short_raw = Short_raw(raw)+s;
 233         for (i = 0; i < l; i++)
 234             *short_raw++ = Long_val(Field(data,i));
 235         break;
 236     }
 237     case MLTAG_int:
 238     {
 239         int *int_raw = Int_raw(raw)+s;
 240         for (i = 0; i < l; i++)
 241             *int_raw++ = Long_val(Field(data,i));
 242         break;
 243     }
 244     case MLTAG_uint:
 245     {
 246         int *int_raw = Int_raw(raw)+s;
 247         for (i = 0; i < l; i++)
 248             *int_raw++ = Long_val((unsigned long) Field(data,i));
 249         break;
 250     }
 251     case MLTAG_long:
 252     {
 253         long *long_raw = Long_raw(raw)+s;
 254         for (i = 0; i < l; i++)
 255             *long_raw++ = Long_val(Field(data,i));
 256         break;
 257     }
 258     case MLTAG_ulong:
 259     {
 260         long *long_raw = Long_raw(raw)+s;
 261         for (i = 0; i < l; i++)
 262             *long_raw++ = Long_val((unsigned long) Field(data,i));
 263         break;
 264     }
 265     }
 266     return Val_unit;
 267 }
 268
 269 CAMLprim value ml_raw_get_float (value raw, value pos)  /* ML */
 270 {
 271     long i = Long_val(pos);
 272
 273     check_size (raw,i,"Raw.get_float");
 274     if (Kind_raw(raw) == MLTAG_float)
 275         return caml_copy_double ((double) Float_raw(raw)[i]);
 276     else
 277         return caml_copy_double (Double_raw(raw)[i]);
 278 }
 279
 280 CAMLprim value ml_raw_read_float (value raw, value pos, value len)  /* ML */
 281 {
 282     int s = Int_val(pos);
 283     int i, l = Int_val(len);
 284     value ret = Val_unit;
 285
 286     check_size (raw,s+l-1,"Raw.read_float");
 287     if (l<0 || s<0) caml_invalid_argument("Raw.read_float");
 288     ret = caml_alloc_shr (l*sizeof(double)/sizeof(value), Double_array_tag);
 289     if (Kind_raw(raw) == MLTAG_float) {
 290         float *float_raw = Float_raw(raw)+s;
 291         for (i = 0; i < l; i++)
 292             Store_double_field(ret, i, (double) *float_raw++);
 293     } else {
 294         double *double_raw = Double_raw(raw)+s;
 295         for (i = 0; i < l; i++)
 296             Store_double_field(ret, i, *double_raw++);
 297     }
 298     return ret;
 299 }
 300
 301 CAMLprim value ml_raw_set_float (value raw, value pos, value data)  /* ML */
 302 {
 303     long i = Long_val(pos);
 304
 305     check_size (raw,i,"Raw.set_float");
 306     if (Kind_raw(raw) == MLTAG_float)
 307         Float_raw(raw)[i] = (float) Double_val(data);
 308     else
 309         Double_raw(raw)[i] = Double_val(data);
 310     return Val_unit;
 311 }
 312
 313 CAMLprim value ml_raw_write_float (value raw, value pos, value data)  /* ML */
 314 {
 315     int s = Int_val(pos);
 316     int i, l = Wosize_val(data)*sizeof(value)/sizeof(double);
 317
 318     check_size (raw,s+l-1,"Raw.write_float");
 319     if (s<0) caml_invalid_argument("Raw.write_float");
 320     if (Kind_raw(raw) == MLTAG_float) {
 321         float *float_raw = Float_raw(raw)+s;
 322         for (i = 0; i < l; i++)
 323             *float_raw++ = (float) Double_field(data,i);
 324     } else {
 325         double *double_raw = Double_raw(raw)+s;
 326         for (i = 0; i < l; i++)
 327             *double_raw++ = Double_field(data,i);
 328     }
 329     return Val_unit;
 330 }
 331
 332 #ifdef ARCH_BIG_ENDIAN
 333 #define HI_OFFSET 1
 334 #define LO_OFFSET 0
 335 #else
 336 #define HI_OFFSET 0
 337 #define LO_OFFSET 1
 338 #endif
 339
 340 /* Here we suppose that:
 341  *    sizeof(int)  == 2*sizeof(short)
 342  *    sizeof(long) == 2*sizeof(int)   (64-bit architectures)
 343  *    sizeof(long) == 2*sizeof(short) (otherwise)
 344  */
 345
 346 #define Hint_raw(raw) ((unsigned short *) Short_raw(raw))
 347
 348 #ifdef ARCH_SIXTYFOUR
 349 #define Hlong_raw(raw) ((unsigned int *) Int_raw(raw))
 350 #else
 351 #define Hlong_raw(raw) ((unsigned short *) Short_raw(raw))
 352 #endif
 353
 354 CAMLprim value ml_raw_get_hi (value raw, value pos)  /* ML */
 355 {
 356     long i = Long_val(pos);
 357
 358     check_size (raw,i,"Raw.get_hi");
 359     switch (Kind_raw(raw)) {
 360     case MLTAG_int:
 361     case MLTAG_uint:
 362         return Val_long (Hint_raw(raw)[2*i+HI_OFFSET]);
 363     case MLTAG_long:
 364     case MLTAG_ulong:
 365         return Val_long (Hlong_raw(raw)[2*i+HI_OFFSET]);
 366     }
 367     return Val_unit;
 368 }
 369
 370 CAMLprim value ml_raw_get_lo (value raw, value pos)  /* ML */
 371 {
 372     long i = Long_val(pos);
 373
 374     check_size (raw,i,"Raw.get_lo");
 375     switch (Kind_raw(raw)) {
 376     case MLTAG_int:
 377     case MLTAG_uint:
 378         return Val_long ((unsigned long) Hint_raw(raw)[2*i+LO_OFFSET]);
 379     case MLTAG_long:
 380     case MLTAG_ulong:
 381         return Val_long ((unsigned long) Hlong_raw(raw)[2*i+LO_OFFSET]);
 382     }
 383     return Val_unit;
 384 }
 385
 386 CAMLprim value ml_raw_set_hi (value raw, value pos, value data)  /* ML */
 387 {
 388     long i = Long_val(pos);
 389
 390     check_size (raw,i,"Raw.set_hi");
 391     switch (Kind_raw(raw)) {
 392     case MLTAG_int:
 393     case MLTAG_uint:
 394         Hint_raw(raw)[2*i+HI_OFFSET] = Long_val(data);
 395         break;
 396     case MLTAG_long:
 397     case MLTAG_ulong:
 398         Hlong_raw(raw)[2*i+HI_OFFSET] = Long_val(data);
 399         break;
 400     }
 401     return Val_unit;
 402 }
 403
 404 CAMLprim value ml_raw_set_lo (value raw, value pos, value data)  /* ML */
 405 {
 406     long i = Long_val(pos);
 407
 408     check_size (raw,i,"Raw.set_lo");
 409     switch (Kind_raw(raw)) {
 410     case MLTAG_int:
 411     case MLTAG_uint:
 412         Hint_raw(raw)[2*i+LO_OFFSET] = Long_val(data);
 413         break;
 414     case MLTAG_long:
 415     case MLTAG_ulong:
 416         Hlong_raw(raw)[2*i+LO_OFFSET] = Long_val(data);
 417         break;
 418     }
 419     return Val_unit;
 420 }
 421
 422 CAMLprim value ml_raw_get_long (value raw, value pos)  /* ML */
 423 {
 424     long i = Long_val(pos);
 425
 426     check_size (raw,i,"Raw.get_long");
 427     switch (Kind_raw(raw)) {
 428     case MLTAG_int:
 429     case MLTAG_uint:
 430         return caml_copy_nativeint (Int_raw(raw)[i]);
 431     case MLTAG_long:
 432     case MLTAG_ulong:
 433         return caml_copy_nativeint (Long_raw(raw)[i]);
 434     }
 435     return Val_unit;
 436 }
 437
 438 CAMLprim value ml_raw_set_long (value raw, value pos, value data)  /* ML */
 439 {
 440     long i = Long_val(pos);
 441
 442     check_size (raw,i,"Raw.set_long");
 443     switch (Kind_raw(raw)) {
 444     case MLTAG_int:
 445     case MLTAG_uint:
 446         Int_raw(raw)[i] = Nativeint_val(data);
 447         break;
 448     case MLTAG_long:
 449     case MLTAG_ulong:
 450         Long_raw(raw)[i] = Nativeint_val(data);
 451         break;
 452     }
 453     return Val_unit;
 454 }
 455
 456 CAMLprim value ml_raw_alloc (value kind, value len)  /* ML */
 457 {
 458     CAMLparam0();
 459     CAMLlocal1(data);
 460     value raw;
 461     int size = raw_sizeof(kind) * Int_val(len);
 462     int offset = 0;
 463
 464     if (kind == MLTAG_double && sizeof(double) > sizeof(value)) {
 465         data = caml_alloc_shr ((size-1)/sizeof(value)+2, Abstract_tag);
 466         offset = (data % sizeof(double) ? sizeof(value) : 0);
 467     } else data = caml_alloc_shr ((size-1)/sizeof(value)+1, Abstract_tag);
 468     raw = caml_alloc_small (SIZE_RAW,0);
 469     Kind_raw(raw) = kind;
 470     Size_raw(raw) = Val_int(size);
 471     Base_raw(raw) = data;
 472     Offset_raw(raw) = Val_int(offset);
 473     Static_raw(raw) = Val_false;
 474     CAMLreturn(raw);
 475 }
 476
 477 CAMLprim value ml_raw_alloc_static (value kind, value len)  /* ML */
 478 {
 479     value raw;
 480     void  *data;
 481     int size = raw_sizeof(kind) * Int_val(len);
 482     int offset = 0;
 483
 484     if (kind == MLTAG_double && sizeof(double) > sizeof(long)) {
 485         data = caml_stat_alloc (size+sizeof(long));
 486         offset = ((long)data % sizeof(double) ? sizeof(value) : 0);
 487     } else data = caml_stat_alloc (size);
 488     raw = caml_alloc_small (SIZE_RAW, 0);
 489     Kind_raw(raw) = kind;
 490     Size_raw(raw) = Val_int(size);
 491     Base_raw(raw) = (value) data;
 492     Offset_raw(raw) = Val_int(offset);
 493     Static_raw(raw) = Val_true;
 494     return raw;
 495 }
 496
 497 CAMLprim value ml_raw_free_static (value raw)  /* ML */
 498 {
 499     if (Static_raw(raw) != Val_int(1)) caml_invalid_argument ("Raw.free_static");
 500     caml_stat_free (Void_raw(raw));
 501     Base_raw(raw) = Val_unit;
 502     Size_raw(raw) = Val_unit;
 503     Offset_raw(raw) = Val_unit;
 504     Static_raw(raw) = Val_false;
 505     return Val_unit;
 506 }