native/types.c

   1 #include "factor.h"
   2
   3 bool typep(CELL type, CELL tagged)
   4 {
   5         if(type < HEADER_TYPE)
   6         {
   7                 if(TAG(tagged) == type)
   8                         return true;
   9         }
  10         else if(type >= HEADER_TYPE)
  11         {
  12                 if(TAG(tagged) == OBJECT_TYPE)
  13                 {
  14                         if(untag_header(get(UNTAG(tagged))) == type)
  15                                 return true;
  16                 }
  17         }
  18
  19         return false;
  20 }
  21
  22 CELL type_of(CELL tagged)
  23 {
  24         CELL tag = TAG(tagged);
  25         if(tag != OBJECT_TYPE)
  26                 return tag;
  27         else
  28                 return untag_header(get(UNTAG(tagged)));
  29 }
  30
  31 void type_check(CELL type, CELL tagged)
  32 {
  33         if(type < HEADER_TYPE)
  34         {
  35                 if(TAG(tagged) == type)
  36                         return;
  37         }
  38         else if(type >= HEADER_TYPE)
  39         {
  40                 if(TAG(tagged) == OBJECT_TYPE)
  41                 {
  42                         if(untag_header(get(UNTAG(tagged))) == type)
  43                                 return;
  44                 }
  45         }
  46
  47         type_error(type,tagged);
  48 }
  49
  50 /*
  51  * It is up to the caller to fill in the object's fields in a meaningful
  52  * fashion!
  53  */
  54 void* allot_object(CELL type, CELL length)
  55 {
  56         CELL* object = allot(length);
  57         *object = tag_header(type);
  58         return object;
  59 }
  60
  61 CELL object_size(CELL pointer)
  62 {
  63         CELL size;
  64
  65         switch(TAG(pointer))
  66         {
  67         case FIXNUM_TYPE:
  68                 size = 0;
  69                 break;
  70         case CONS_TYPE:
  71                 size = sizeof(CONS);
  72                 break;
  73         case WORD_TYPE:
  74                 size = sizeof(WORD);
  75                 break;
  76         case RATIO_TYPE:
  77                 size = sizeof(RATIO);
  78                 break;
  79         case COMPLEX_TYPE:
  80                 size = sizeof(COMPLEX);
  81                 break;
  82         case OBJECT_TYPE:
  83                 size = untagged_object_size(UNTAG(pointer));
  84                 break;
  85         default:
  86                 critical_error("Cannot determine size",pointer);
  87                 size = 0; /* Can't happen */
  88                 break;
  89         }
  90
  91         return align8(size);
  92 }
  93
  94 CELL untagged_object_size(CELL pointer)
  95 {
  96         CELL size;
  97
  98         switch(untag_header(get(pointer)))
  99         {
 100         case WORD_TYPE:
 101                 return align8(sizeof(WORD));
 102         case F_TYPE:
 103         case T_TYPE:
 104         case EMPTY_TYPE:
 105                 size = CELLS * 2;
 106                 break;
 107         case ARRAY_TYPE:
 108                 size = ASIZE(pointer);
 109                 break;
 110         case VECTOR_TYPE:
 111                 size = sizeof(VECTOR);
 112                 break;
 113         case STRING_TYPE:
 114                 size = SSIZE(pointer);
 115                 break;
 116         case SBUF_TYPE:
 117                 size = sizeof(SBUF);
 118                 break;
 119         case BIGNUM_TYPE:
 120                 size = sizeof(BIGNUM);
 121                 break;
 122         case FLOAT_TYPE:
 123                 size = sizeof(FLOAT);
 124                 break;
 125         case HANDLE_TYPE:
 126                 size = sizeof(HANDLE);
 127                 break;
 128         default:
 129                 critical_error("Cannot determine size",relocating);
 130                 size = -1;/* can't happen */
 131                 break;
 132         }
 133
 134         return align8(size);
 135 }
 136
 137 void primitive_type_of(void)
 138 {
 139         check_non_empty(env.dt);
 140         env.dt = tag_fixnum(type_of(env.dt));
 141 }
 142
 143 void primitive_size_of(void)
 144 {
 145         check_non_empty(env.dt);
 146         env.dt = tag_fixnum(object_size(env.dt));
 147 }