native/word.c

   1 #include "factor.h"
   2
   3 WORD* word(FIXNUM primitive, CELL parameter, CELL plist)
   4 {
   5         WORD* word = (WORD*)allot_object(WORD_TYPE,sizeof(WORD));
   6         word->xt = primitive_to_xt(primitive);
   7         word->primitive = primitive;
   8         word->parameter = parameter;
   9         word->plist = plist;
  10
  11         return word;
  12 }
  13
  14 /* When a word is executed we jump to the value of the xt field. However this
  15    value is an unportable function pointer, so in the image we store a primitive
  16    number that indexes a list of xts. */
  17 void update_xt(WORD* word)
  18 {
  19         word->xt = primitive_to_xt(word->primitive);
  20 }
  21
  22 void primitive_wordp(void)
  23 {
  24         check_non_empty(env.dt);
  25         env.dt = tag_boolean(TAG(env.dt) == WORD_TYPE);
  26 }
  27
  28 /* <word> ( primitive parameter plist -- word ) */
  29 void primitive_word(void)
  30 {
  31         CELL plist = env.dt;
  32         FIXNUM primitive;
  33         CELL parameter = dpop();
  34         check_non_empty(plist);
  35         check_non_empty(parameter);
  36         primitive = to_fixnum(dpop());
  37         env.dt = tag_word(word(primitive,parameter,plist));
  38 }
  39
  40 void primitive_word_primitive(void)
  41 {
  42         env.dt = tag_fixnum(untag_word(env.dt)->primitive);
  43 }
  44
  45 void primitive_set_word_primitive(void)
  46 {
  47         WORD* word = untag_word(env.dt);
  48         word->primitive = to_fixnum(dpop());
  49         update_xt(word);
  50         env.dt = dpop();
  51 }
  52
  53 void primitive_word_parameter(void)
  54 {
  55         env.dt = untag_word(env.dt)->parameter;
  56 }
  57
  58 void primitive_set_word_parameter(void)
  59 {
  60         check_non_empty(dpeek());
  61         untag_word(env.dt)->parameter = dpop();
  62         env.dt = dpop();
  63 }
  64
  65 void primitive_word_plist(void)
  66 {
  67         env.dt = untag_word(env.dt)->plist;
  68 }
  69
  70 void primitive_set_word_plist(void)
  71 {
  72         check_non_empty(dpeek());
  73         untag_word(env.dt)->plist = dpop();
  74         env.dt = dpop();
  75 }
  76
  77 void fixup_word(WORD* word)
  78 {
  79         word->xt = primitive_to_xt(word->primitive);
  80         fixup(&word->parameter);
  81         fixup(&word->plist);
  82 }
  83
  84 void collect_word(WORD* word)
  85 {
  86         copy_object(&word->parameter);
  87         copy_object(&word->plist);
  88 }