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 CELL allot_object(CELL type, CELL length)
  55 {
  56         CELL object = allot(length);
  57         put(object,tag_header(type));
  58         return object;
  59 }
  60
  61 CELL object_size(CELL pointer)
  62 {
  63         switch(TAG(pointer))
  64         {
  65         case CONS_TYPE:
  66                 return align8(sizeof(CONS));
  67         case WORD_TYPE:
  68                 return align8(sizeof(WORD));
  69         case OBJECT_TYPE:
  70                 return untagged_object_size(UNTAG(pointer));
  71         default:
  72                 critical_error("Cannot determine size",pointer);
  73                 return -1;
  74         }
  75 }
  76
  77 CELL untagged_object_size(CELL pointer)
  78 {
  79         CELL size;
  80
  81         switch(untag_header(get(pointer)))
  82         {
  83         case WORD_TYPE:
  84                 return align8(sizeof(WORD));
  85         case F_TYPE:
  86         case T_TYPE:
  87         case EMPTY_TYPE:
  88                 size = CELLS * 2;
  89                 break;
  90         case ARRAY_TYPE:
  91                 size = ASIZE(pointer);
  92                 break;
  93         case VECTOR_TYPE:
  94                 size = sizeof(VECTOR);
  95                 break;
  96         case STRING_TYPE:
  97                 size = SSIZE(pointer);
  98                 break;
  99         case SBUF_TYPE:
 100                 size = sizeof(SBUF);
 101                 break;
 102         case HANDLE_TYPE:
 103                 size = sizeof(HANDLE);
 104                 break;
 105         default:
 106                 critical_error("Cannot determine size",relocating);
 107                 size = -1;/* can't happen */
 108                 break;
 109         }
 110
 111         return align8(size);
 112 }