vm/types.c

   1 #include "factor.h"
   2
   3 /* FFI calls this */
   4 void box_boolean(bool value)
   5 {
   6         dpush(value ? T : F);
   7 }
   8
   9 /* FFI calls this */
  10 bool unbox_boolean(void)
  11 {
  12         return (dpop() != F);
  13 }
  14
  15 /* the array is full of undefined data, and must be correctly filled before the
  16 next GC. size is in cells */
  17 F_ARRAY *allot_array_internal(CELL type, F_FIXNUM capacity)
  18 {
  19         F_ARRAY *array;
  20
  21         if(capacity < 0)
  22         {
  23                 simple_error(ERROR_NEGATIVE_ARRAY_SIZE,allot_integer(capacity),F);
  24                 return NULL;
  25         }
  26         else
  27         {
  28                 array = allot_object(type,array_size(capacity));
  29                 array->capacity = tag_fixnum(capacity);
  30                 return array;
  31         }
  32 }
  33
  34 /* make a new array with an initial element */
  35 F_ARRAY *allot_array(CELL type, F_FIXNUM capacity, CELL fill)
  36 {
  37         int i;
  38         REGISTER_ROOT(fill);
  39         F_ARRAY* array = allot_array_internal(type, capacity);
  40         UNREGISTER_ROOT(fill);
  41         for(i = 0; i < capacity; i++)
  42                 set_array_nth(array,i,fill);
  43         return array;
  44 }
  45
  46 /* size is in bytes this time */
  47 F_ARRAY *allot_byte_array(F_FIXNUM size)
  48 {
  49         if(size < 0)
  50         {
  51                 simple_error(ERROR_NEGATIVE_ARRAY_SIZE,allot_integer(size),F);
  52                 return NULL;
  53         }
  54
  55         CELL byte_size = (size + sizeof(CELL) - 1) / sizeof(CELL);
  56         return allot_array(BYTE_ARRAY_TYPE,byte_size,0);
  57 }
  58
  59 /* push a new array on the stack */
  60 void primitive_array(void)
  61 {
  62         CELL initial = dpop();
  63         F_FIXNUM size = unbox_signed_cell();
  64         dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
  65 }
  66
  67 /* push a new byte on the stack */
  68 void primitive_byte_array(void)
  69 {
  70         F_FIXNUM size = unbox_signed_cell();
  71         dpush(tag_object(allot_byte_array(size)));
  72 }
  73
  74 CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
  75 {
  76         REGISTER_ROOT(v1);
  77         REGISTER_ROOT(v2);
  78         REGISTER_ROOT(v3);
  79         REGISTER_ROOT(v4);
  80         F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
  81         UNREGISTER_ROOT(v4);
  82         UNREGISTER_ROOT(v3);
  83         UNREGISTER_ROOT(v2);
  84         UNREGISTER_ROOT(v1);
  85         set_array_nth(a,0,v1);
  86         set_array_nth(a,1,v2);
  87         set_array_nth(a,2,v3);
  88         set_array_nth(a,3,v4);
  89         return tag_object(a);
  90 }
  91
  92 F_ARRAY *reallot_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
  93 {
  94         int i;
  95         F_ARRAY* new_array;
  96
  97         CELL to_copy = array_capacity(array);
  98         if(capacity < to_copy)
  99                 to_copy = capacity;
 100
 101         REGISTER_ARRAY(array);
 102         REGISTER_ROOT(fill);
 103
 104         new_array = allot_array_internal(untag_header(array->header),capacity);
 105
 106         UNREGISTER_ROOT(fill);
 107         UNREGISTER_ARRAY(array);
 108
 109         memcpy(new_array + 1,array + 1,to_copy * CELLS);
 110
 111         for(i = to_copy; i < capacity; i++)
 112                 set_array_nth(new_array,i,fill);
 113
 114         return new_array;
 115 }
 116
 117 void primitive_resize_array(void)
 118 {
 119         F_ARRAY* array = untag_array(dpop());
 120         F_FIXNUM capacity = unbox_signed_cell();
 121         dpush(tag_object(reallot_array(array,capacity,F)));
 122 }
 123
 124 void primitive_become(void)
 125 {
 126         CELL type = unbox_signed_cell();
 127         CELL obj = dpeek();
 128         put(SLOT(UNTAG(obj),0),tag_header(type));
 129 }
 130
 131 void primitive_array_to_vector(void)
 132 {
 133         F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
 134         F_ARRAY *array = untag_array(dpeek());
 135         vector->top = array->capacity;
 136         vector->array = tag_object(array);
 137         drepl(tag_object(vector));
 138 }
 139
 140 /* untagged */
 141 F_STRING* allot_string_internal(F_FIXNUM capacity)
 142 {
 143         F_STRING* string;
 144
 145         if(capacity < 0)
 146         {
 147                 simple_error(ERROR_NEGATIVE_ARRAY_SIZE,allot_integer(capacity),F);
 148                 return NULL;
 149         }
 150         else
 151         {
 152                 string = allot_object(STRING_TYPE,
 153                         sizeof(F_STRING) + (capacity + 1) * CHARS);
 154                 /* strings are null-terminated in memory, even though they also
 155                 have a length field. The null termination allows us to add
 156                 the sizeof(F_STRING) to a Factor string to get a C-style
 157                 UTF16 string for C library calls. */
 158                 cput(SREF(string,capacity),(u16)'\0');
 159                 string->length = tag_fixnum(capacity);
 160                 string->hashcode = F;
 161                 return string;
 162         }
 163 }
 164
 165 /* call this after constructing a string */
 166 void rehash_string(F_STRING* str)
 167 {
 168         s32 hash = 0;
 169         CELL i;
 170         CELL capacity = string_capacity(str);
 171         for(i = 0; i < capacity; i++)
 172                 hash = (31*hash + string_nth(str,i));
 173         str->hashcode = (s32)tag_fixnum(hash);
 174 }
 175
 176 void primitive_rehash_string(void)
 177 {
 178         rehash_string(untag_string(dpop()));
 179 }
 180
 181 /* untagged */
 182 F_STRING *allot_string(F_FIXNUM capacity, CELL fill)
 183 {
 184         CELL i;
 185
 186         F_STRING* string = allot_string_internal(capacity);
 187
 188         for(i = 0; i < capacity; i++)
 189                 cput(SREF(string,i),fill);
 190
 191         rehash_string(string);
 192
 193         return string;
 194 }
 195
 196 void primitive_string(void)
 197 {
 198         CELL initial = unbox_unsigned_cell();
 199         F_FIXNUM length = unbox_signed_cell();
 200         dpush(tag_object(allot_string(length,initial)));
 201 }
 202
 203 F_STRING* reallot_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
 204 {
 205         /* later on, do an optimization: if end of array is here, just grow */
 206         CELL i;
 207         CELL to_copy = string_capacity(string);
 208
 209         if(capacity < to_copy)
 210                 to_copy = capacity;
 211
 212         REGISTER_STRING(string);
 213
 214         F_STRING *new_string = allot_string_internal(capacity);
 215
 216         UNREGISTER_STRING(string);
 217
 218         memcpy(new_string + 1,string + 1,to_copy * CHARS);
 219
 220         for(i = to_copy; i < capacity; i++)
 221                 cput(SREF(new_string,i),fill);
 222
 223         return new_string;
 224 }
 225
 226 void primitive_resize_string(void)
 227 {
 228         F_STRING* string = untag_string(dpop());
 229         F_FIXNUM capacity = unbox_signed_cell();
 230         dpush(tag_object(reallot_string(string,capacity,0)));
 231 }
 232
 233 /* Some ugly macros to prevent a 2x code duplication */
 234
 235 #define MEMORY_TO_STRING(type,utype) \
 236         F_STRING *memory_to_##type##_string(const type *string, CELL length) \
 237         { \
 238                 REGISTER_C_STRING(string); \
 239                 F_STRING* s = allot_string_internal(length); \
 240                 UNREGISTER_C_STRING(string); \
 241                 CELL i; \
 242                 for(i = 0; i < length; i++) \
 243                 { \
 244                         cput(SREF(s,i),(utype)*string); \
 245                         string++; \
 246                 } \
 247                 rehash_string(s); \
 248                 return s; \
 249         } \
 250         void primitive_memory_to_##type##_string(void) \
 251         { \
 252                 CELL length = unbox_unsigned_cell(); \
 253                 const type *string = (const type*)unbox_unsigned_cell(); \
 254                 dpush(tag_object(memory_to_##type##_string(string,length))); \
 255         } \
 256         F_STRING *from_##type##_string(const type *str) \
 257         { \
 258                 CELL length = 0; \
 259                 const type *scan = str; \
 260                 while(*scan++) length++; \
 261                 return memory_to_##type##_string(str,length); \
 262         } \
 263         void box_##type##_string(const type *str) \
 264         { \
 265                 dpush(str ? tag_object(from_##type##_string(str)) : F); \
 266         } \
 267         void primitive_alien_to_##type##_string(void) \
 268         { \
 269                 drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
 270         }
 271
 272 MEMORY_TO_STRING(char,u8)
 273 MEMORY_TO_STRING(u16,u16)
 274
 275 bool check_string(F_STRING *s, CELL max)
 276 {
 277         CELL capacity = string_capacity(s);
 278         CELL i;
 279         for(i = 0; i < capacity; i++)
 280         {
 281                 u16 ch = string_nth(s,i);
 282                 if(ch == '\0' || ch >= (1 << (max * 8)))
 283                         return false;
 284         }
 285         return true;
 286 }
 287
 288 F_ARRAY *allot_c_string(CELL capacity, CELL size)
 289 {
 290         return allot_array_internal(BYTE_ARRAY_TYPE,capacity * size / CELLS + 1);
 291 }
 292
 293 #define STRING_TO_MEMORY(type) \
 294         void type##_string_to_memory(F_STRING *s, type *string) \
 295         { \
 296                 CELL i; \
 297                 CELL capacity = string_capacity(s); \
 298                 for(i = 0; i < capacity; i++) \
 299                         string[i] = string_nth(s,i); \
 300         } \
 301         void primitive_##type##_string_to_memory(void) \
 302         { \
 303                 type *address = (type*)unbox_unsigned_cell(); \
 304                 F_STRING *str = untag_string(dpop()); \
 305                 type##_string_to_memory(str,address); \
 306         } \
 307         F_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
 308         { \
 309                 CELL capacity = string_capacity(s); \
 310                 F_ARRAY *_c_str; \
 311                 if(check && !check_string(s,sizeof(type))) \
 312                         simple_error(ERROR_C_STRING,tag_object(s),F); \
 313                 REGISTER_STRING(s); \
 314                 _c_str = allot_c_string(capacity,sizeof(type)); \
 315                 UNREGISTER_STRING(s); \
 316                 type *c_str = (type*)(_c_str + 1); \
 317                 type##_string_to_memory(s,c_str); \
 318                 c_str[capacity] = 0; \
 319                 return _c_str; \
 320         } \
 321         type *to_##type##_string(F_STRING *s, bool check) \
 322         { \
 323                 if(sizeof(type) == sizeof(u16)) \
 324                 { \
 325                         if(check && !check_string(s,sizeof(type))) \
 326                                 simple_error(ERROR_C_STRING,tag_object(s),F); \
 327                         return (type*)(s + 1); \
 328                 } \
 329                 else \
 330                         return (type*)(string_to_##type##_alien(s,check) + 1); \
 331         } \
 332         type *unbox_##type##_string(void) \
 333         { \
 334                 return to_##type##_string(untag_string(dpop()),true); \
 335         } \
 336         void primitive_string_to_##type##_alien(void) \
 337         { \
 338                 CELL string, t; \
 339                 string = dpeek(); \
 340                 t = type_of(string); \
 341                 if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
 342                         drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
 343         }
 344
 345 STRING_TO_MEMORY(char);
 346 STRING_TO_MEMORY(u16);
 347
 348 void primitive_char_slot(void)
 349 {
 350         F_STRING* string = untag_string_fast(dpop());
 351         CELL index = untag_fixnum_fast(dpop());
 352         dpush(tag_fixnum(string_nth(string,index)));
 353 }
 354
 355 void primitive_set_char_slot(void)
 356 {
 357         F_STRING* string = untag_string_fast(dpop());
 358         CELL index = untag_fixnum_fast(dpop());
 359         CELL value = untag_fixnum_fast(dpop());
 360         set_string_nth(string,index,value);
 361 }
 362
 363 void primitive_string_to_sbuf(void)
 364 {
 365         F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
 366         F_STRING *string = untag_string(dpeek());
 367         sbuf->top = string->length;
 368         sbuf->string = tag_object(string);
 369         drepl(tag_object(sbuf));
 370 }
 371
 372 void primitive_hashtable(void)
 373 {
 374         F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
 375         hash->count = F;
 376         hash->deleted = F;
 377         hash->array = F;
 378         dpush(tag_object(hash));
 379 }
 380
 381 void update_xt(F_WORD* word)
 382 {
 383         word->compiledp = F;
 384         word->xt = primitive_to_xt(to_fixnum(word->primitive));
 385 }
 386
 387 /* <word> ( name vocabulary -- word ) */
 388 F_WORD *allot_word(CELL vocab, CELL name)
 389 {
 390         REGISTER_ROOT(vocab);
 391         REGISTER_ROOT(name);
 392         F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
 393         UNREGISTER_ROOT(name);
 394         UNREGISTER_ROOT(vocab);
 395         word->hashcode = tag_fixnum(rand());
 396         word->vocabulary = vocab;
 397         word->name = name;
 398         word->primitive = tag_fixnum(0);
 399         word->def = F;
 400         word->props = F;
 401         update_xt(word);
 402         return word;
 403 }
 404
 405 void primitive_word(void)
 406 {
 407         CELL vocab = dpop();
 408         CELL name = dpop();
 409         dpush(tag_word(allot_word(vocab,name)));
 410 }
 411
 412 void primitive_update_xt(void)
 413 {
 414         update_xt(untag_word(dpop()));
 415 }
 416
 417 void primitive_word_xt(void)
 418 {
 419         F_WORD *word = untag_word(dpeek());
 420         drepl(allot_cell(word->xt));
 421 }
 422
 423 void fixup_word(F_WORD* word)
 424 {
 425         /* If this is a compiled word, relocate the code pointer. Otherwise,
 426         reset it based on the primitive number of the word. */
 427         if(word->compiledp != F)
 428                 code_fixup(&word->xt);
 429         else
 430                 update_xt(word);
 431 }
 432
 433 void primitive_wrapper(void)
 434 {
 435         F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
 436         wrapper->object = dpeek();
 437         drepl(tag_wrapper(wrapper));
 438 }