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