Fix corner case
[llpp.git] / lablGL / ml_raw.c
blob35d163b03bff8d75622156cbea00c2adff428314
1 /* $Id: ml_raw.c,v 1.16 2007-04-13 02:48:43 garrigue Exp $ */
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"
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)
19 extern void invalid_argument (char *) Noreturn;
20 extern void raise_out_of_memory (void) Noreturn;
22 static int raw_sizeof (value kind)
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;
43 return 0;
46 CAMLprim value ml_raw_sizeof (value kind) /* ML */
48 return Val_int(raw_sizeof(kind));
51 static void check_size (value raw, long pos, char *msg)
53 if (pos < 0 ||
54 (pos+1) * raw_sizeof(Kind_raw(raw)) > Int_val(Size_raw(raw)))
55 invalid_argument (msg);
58 CAMLprim value ml_raw_get (value raw, value pos) /* ML */
60 long i = Long_val(pos);
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]);
82 return Val_unit;
85 CAMLprim value ml_raw_read (value raw, value pos, value len) /* ML */
87 int s = Int_val(pos);
88 int i, l = Int_val(len);
89 value ret;
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:
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;
103 case MLTAG_byte:
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;
110 case MLTAG_short:
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;
117 case MLTAG_ushort:
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;
124 case MLTAG_int:
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;
131 case MLTAG_uint:
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;
138 case MLTAG_long:
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;
145 case MLTAG_ulong:
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;
153 return ret;
156 CAMLprim value ml_raw_read_string (value raw, value pos, value len) /* ML */
158 CAMLparam1(raw);
159 int s = Int_val(pos);
160 int l = Int_val(len);
161 value ret;
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);
170 CAMLprim value ml_raw_write_string (value raw, value pos, value data) /* ML */
172 int s = Int_val(pos);
173 int l = string_length(data);
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;
181 CAMLprim value ml_raw_set (value raw, value pos, value data) /* ML */
183 long i = Long_val(pos);
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;
209 return Val_unit;
212 CAMLprim value ml_raw_write (value raw, value pos, value data) /* ML */
214 int s = Int_val(pos);
215 int i, l = Wosize_val(data);
217 check_size (raw,s+l-1,"Raw.write");
218 if (s<0) invalid_argument("Raw.write");
220 switch (Kind_raw(raw)) {
221 case MLTAG_bitmap:
222 case MLTAG_ubyte:
223 case MLTAG_byte:
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;
230 case MLTAG_short:
231 case MLTAG_ushort:
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;
238 case MLTAG_int:
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;
245 case MLTAG_uint:
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;
252 case MLTAG_long:
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;
259 case MLTAG_ulong:
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;
267 return Val_unit;
270 CAMLprim value ml_raw_get_float (value raw, value pos) /* ML */
272 long i = Long_val(pos);
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]);
281 CAMLprim value ml_raw_read_float (value raw, value pos, value len) /* ML */
283 int s = Int_val(pos);
284 int i, l = Int_val(len);
285 value ret = Val_unit;
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++);
299 return ret;
302 CAMLprim value ml_raw_set_float (value raw, value pos, value data) /* ML */
304 long i = Long_val(pos);
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;
314 CAMLprim value ml_raw_write_float (value raw, value pos, value data) /* ML */
316 int s = Int_val(pos);
317 int i, l = Wosize_val(data)*sizeof(value)/sizeof(double);
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);
330 return Val_unit;
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
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)
347 #define Hint_raw(raw) ((unsigned short *) Short_raw(raw))
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
355 CAMLprim value ml_raw_get_hi (value raw, value pos) /* ML */
357 long i = Long_val(pos);
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]);
368 return Val_unit;
371 CAMLprim value ml_raw_get_lo (value raw, value pos) /* ML */
373 long i = Long_val(pos);
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]);
384 return Val_unit;
387 CAMLprim value ml_raw_set_hi (value raw, value pos, value data) /* ML */
389 long i = Long_val(pos);
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;
402 return Val_unit;
405 CAMLprim value ml_raw_set_lo (value raw, value pos, value data) /* ML */
407 long i = Long_val(pos);
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;
420 return Val_unit;
423 CAMLprim value ml_raw_get_long (value raw, value pos) /* ML */
425 long i = Long_val(pos);
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]);
436 return Val_unit;
439 CAMLprim value ml_raw_set_long (value raw, value pos, value data) /* ML */
441 long i = Long_val(pos);
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;
454 return Val_unit;
457 CAMLprim value ml_raw_alloc (value kind, value len) /* ML */
459 CAMLparam0();
460 CAMLlocal1(data);
461 value raw;
462 int size = raw_sizeof(kind) * Int_val(len);
463 int offset = 0;
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);
478 CAMLprim value ml_raw_alloc_static (value kind, value len) /* ML */
480 value raw;
481 void *data;
482 int size = raw_sizeof(kind) * Int_val(len);
483 int offset = 0;
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;
498 CAMLprim value ml_raw_free_static (value raw) /* ML */
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;