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