home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / runtime / alloc.c next >
Encoding:
C/C++ Source or Header  |  1993-09-24  |  2.2 KB  |  120 lines  |  [TEXT/MPS ]
  1. /* 1. Allocation functions doing the same work as the macros in the
  2.       case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
  3.    2. Convenience functions related to allocation.
  4. */
  5.  
  6. #include "alloc.h"
  7. #include "debugger.h"
  8. #include "major_gc.h"
  9. #include "memory.h"
  10. #include "mlvalues.h"
  11. #include "stacks.h"
  12.  
  13. #define Setup_for_gc
  14. #define Restore_after_gc
  15.  
  16. value alloc (wosize, tag)
  17.      mlsize_t wosize;
  18.      tag_t tag;
  19. {
  20.   value result;
  21.   
  22.   Assert (wosize > 0 && wosize <= Max_young_wosize);
  23.   Alloc_small (result, wosize, tag);
  24.   return result;
  25. }
  26.  
  27. value alloc_tuple(n)
  28.      mlsize_t n;
  29. {
  30.   return alloc(n, 0);
  31. }
  32.  
  33. value alloc_string (len)
  34.      mlsize_t len;
  35. {
  36.   value result;
  37.   mlsize_t offset_index;
  38.   mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
  39.  
  40.   if (wosize <= Max_young_wosize) {
  41.     Alloc_small (result, wosize, String_tag);
  42.   }else{
  43.     result = alloc_shr (wosize, String_tag);
  44.   }
  45.   Field (result, wosize - 1) = 0;
  46.   offset_index = Bsize_wsize (wosize) - 1;
  47.   Byte (result, offset_index) = offset_index - len;
  48.   return result;
  49. }
  50.  
  51. value copy_double(d)
  52.      double d;
  53. {
  54.   value res;
  55.  
  56.   Alloc_small(res, Double_wosize, Double_tag);
  57.   Store_double_val(res, d);
  58.   return res;
  59. }
  60.  
  61. value copy_string(s)
  62.      char * s;
  63. {
  64.   int len;
  65.   value res;
  66.  
  67.   len = strlen(s);
  68.   res = alloc_string(len);
  69.   bcopy(s, String_val(res), len);
  70.   return res;
  71. }
  72.  
  73. value alloc_array(funct, arr)
  74.      value (*funct)();
  75.      char ** arr;
  76. {
  77.   mlsize_t nbr, n;
  78.   value v;
  79.  
  80.   nbr = 0;
  81.   while (arr[nbr] != 0) nbr++;
  82.   if (nbr == 0) {
  83.     v = Atom(0);
  84.   } else {
  85.     while (extern_asp - nbr <= arg_stack_low)
  86.       realloc_stacks();
  87.     for (n = 0; n < nbr; n++)
  88.       *--extern_asp = funct(arr[n]);
  89.     if (nbr < Max_young_wosize) {
  90.       v = alloc(nbr, 0);
  91.       n = nbr;
  92.       while (n-- > 0) Field (v, n) = *extern_asp++;
  93.     } else {
  94.       v = alloc_shr(nbr, 0);
  95.       n = nbr;
  96.       while (n-- > 0) initialize (&Field(v, n), *extern_asp++);
  97.     }
  98.   }
  99.   return v;
  100. }
  101.  
  102. value copy_string_array(arr)
  103.      char ** arr;
  104. {
  105.   return alloc_array((value (*) ())copy_string, arr);
  106. }
  107.  
  108. int convert_flag_list(list, flags)
  109.      value list;
  110.      int * flags;
  111. {
  112.   int res;
  113.   res = 0;
  114.   while (Tag_val(list) == 1) {
  115.     res |= flags[Tag_val(Field(list, 0))];
  116.     list = Field(list, 1);
  117.   }
  118.   return res;
  119. }
  120.