/* 1. Allocation functions doing the same work as the macros in the case where [Setup_for_gc] and [Restore_after_gc] are no-ops. 2. Convenience functions related to allocation.*/ #include <string.h>#include "alloc.h"#include "debugger.h"#include "major_gc.h"#include "memory.h"#include "mlvalues.h"#include "stacks.h" #define Setup_for_gc#define Restore_after_gc value alloc (mlsize_t wosize, tag_t tag){ value result; Assert (wosize > 0 && wosize <= Max_young_wosize); Alloc_small (result, wosize, tag); return result;} value alloc_tuple(mlsize_t n){ return alloc(n, 0);} value alloc_string(mlsize_t len){ value result; mlsize_t offset_index; mlsize_t wosize = (len + sizeof (value)) / sizeof (value); if (wosize <= Max_young_wosize) { Alloc_small (result, wosize, String_tag); }else{ result = alloc_shr (wosize, String_tag); } Field (result, wosize - 1) = 0; offset_index = Bsize_wsize (wosize) - 1; Byte (result, offset_index) = offset_index - len; return result;} value alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max){ value result = alloc_shr (len, Final_tag); Field (result, 0) = (value) fun; adjust_gc_speed (mem, max); return result;} value copy_double(double d){ value res; Alloc_small(res, Double_wosize, Double_tag); Store_double_val(res, d); return res;} value copy_string(char * s){ int len; value res; len = strlen(s); res = alloc_string(len); bcopy(s, String_val(res), len); return res;} value alloc_array(value (*funct) (char *), char ** arr){ mlsize_t nbr, n; value v; nbr = 0; while (arr[nbr] != 0) nbr++; if (nbr == 0) { return Atom(0); } else { Push_roots(r, 1); r[0] = nbr < Max_young_wosize ? alloc(nbr, 0) : alloc_shr(nbr, 0); for (n = 0; n < nbr; n++) Field(r[0], n) = Val_long(0); for (n = 0; n < nbr; n++) { v = funct(arr[n]); modify(&Field(r[0], n), v); } v = r[0]; Pop_roots(); return v; }} value copy_string_array(char ** arr){ return alloc_array(copy_string, arr);} int convert_flag_list(value list, int * flags){ int res; res = 0; while (Tag_val(list) == 1) { res |= flags[Tag_val(Field(list, 0))]; list = Field(list, 1); } return res;}
/* 1. Allocation functions doing the same work as the macros in the
case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
2. Convenience functions related to allocation.
*/
#include <string.h>
#include "alloc.h"
#include "debugger.h"
#include "major_gc.h"
#include "memory.h"
#include "mlvalues.h"
#include "stacks.h"
#define Setup_for_gc
#define Restore_after_gc
value alloc (mlsize_t wosize, tag_t tag)
{
value result;
Assert (wosize > 0 && wosize <= Max_young_wosize);
Alloc_small (result, wosize, tag);
return result;
}
value alloc_tuple(mlsize_t n)
{
return alloc(n, 0);
}
value alloc_string(mlsize_t len)
{
value result;
mlsize_t offset_index;
mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
if (wosize <= Max_young_wosize) {
Alloc_small (result, wosize, String_tag);
}else{
result = alloc_shr (wosize, String_tag);
}
Field (result, wosize - 1) = 0;
offset_index = Bsize_wsize (wosize) - 1;
Byte (result, offset_index) = offset_index - len;
return result;
}
value alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max)
{
value result = alloc_shr (len, Final_tag);
Field (result, 0) = (value) fun;
adjust_gc_speed (mem, max);
return result;
}
value copy_double(double d)
{
value res;
Alloc_small(res, Double_wosize, Double_tag);
Store_double_val(res, d);
return res;
}
value copy_string(char * s)
{
int len;
value res;
len = strlen(s);
res = alloc_string(len);
bcopy(s, String_val(res), len);
return res;
}
value alloc_array(value (*funct) (char *), char ** arr)
{
mlsize_t nbr, n;
value v;
nbr = 0;
while (arr[nbr] != 0) nbr++;
if (nbr == 0) {
return Atom(0);
} else {
Push_roots(r, 1);
r[0] = nbr < Max_young_wosize ? alloc(nbr, 0) : alloc_shr(nbr, 0);
for (n = 0; n < nbr; n++)
Field(r[0], n) = Val_long(0);
for (n = 0; n < nbr; n++) {
v = funct(arr[n]);
modify(&Field(r[0], n), v);
}
v = r[0];
Pop_roots();
return v;
}
}
value copy_string_array(char ** arr)
{
return alloc_array(copy_string, arr);
}
int convert_flag_list(value list, int * flags)
{
int res;
res = 0;
while (Tag_val(list) == 1) {
res |= flags[Tag_val(Field(list, 0))];
list = Field(list, 1);
}
return res;
}