129 lines
2.5 KiB
C
129 lines
2.5 KiB
C
#include "factor.h"
|
|
|
|
F_WORD* word(CELL primitive, CELL parameter, CELL plist)
|
|
{
|
|
F_WORD* word = allot_object(WORD_TYPE,sizeof(F_WORD));
|
|
word->hashcode = (CELL)word; /* initial address */
|
|
word->xt = primitive_to_xt(primitive);
|
|
word->primitive = primitive;
|
|
word->parameter = parameter;
|
|
word->plist = plist;
|
|
word->call_count = 0;
|
|
word->allot_count = 0;
|
|
|
|
return word;
|
|
}
|
|
|
|
/* When a word is executed we jump to the value of the xt field. However this
|
|
value is an unportable function pointer, so in the image we store a primitive
|
|
number that indexes a list of xts. */
|
|
void update_xt(F_WORD* word)
|
|
{
|
|
word->xt = primitive_to_xt(word->primitive);
|
|
}
|
|
|
|
/* <word> ( primitive parameter plist -- word ) */
|
|
void primitive_word(void)
|
|
{
|
|
CELL plist, parameter;
|
|
F_FIXNUM primitive;
|
|
|
|
maybe_garbage_collection();
|
|
|
|
plist = dpop();
|
|
parameter = dpop();
|
|
primitive = to_fixnum(dpop());
|
|
dpush(tag_word(word(primitive,parameter,plist)));
|
|
}
|
|
|
|
void primitive_word_hashcode(void)
|
|
{
|
|
drepl(tag_fixnum(untag_word(dpeek())->hashcode));
|
|
}
|
|
|
|
void primitive_word_xt(void)
|
|
{
|
|
drepl(tag_cell(untag_word(dpeek())->xt));
|
|
}
|
|
|
|
void primitive_set_word_xt(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
word->xt = unbox_integer();
|
|
}
|
|
|
|
void primitive_word_primitive(void)
|
|
{
|
|
drepl(tag_fixnum(untag_word(dpeek())->primitive));
|
|
}
|
|
|
|
void primitive_set_word_primitive(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
word->primitive = to_fixnum(dpop());
|
|
update_xt(word);
|
|
}
|
|
|
|
void primitive_word_parameter(void)
|
|
{
|
|
drepl(untag_word(dpeek())->parameter);
|
|
}
|
|
|
|
void primitive_set_word_parameter(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
word->parameter = dpop();
|
|
}
|
|
|
|
void primitive_word_plist(void)
|
|
{
|
|
drepl(untag_word(dpeek())->plist);
|
|
}
|
|
|
|
void primitive_set_word_plist(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
word->plist = dpop();
|
|
}
|
|
|
|
void primitive_word_call_count(void)
|
|
{
|
|
drepl(tag_cell(untag_word(dpeek())->call_count));
|
|
}
|
|
|
|
void primitive_set_word_call_count(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
word->call_count = to_fixnum(dpop());
|
|
}
|
|
|
|
void primitive_word_allot_count(void)
|
|
{
|
|
drepl(tag_cell(untag_word(dpeek())->allot_count));
|
|
}
|
|
|
|
void primitive_set_word_allot_count(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
word->allot_count = to_fixnum(dpop());
|
|
}
|
|
|
|
void primitive_word_compiledp(void)
|
|
{
|
|
F_WORD* word = untag_word(dpop());
|
|
box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
|
|
}
|
|
|
|
void fixup_word(F_WORD* word)
|
|
{
|
|
update_xt(word);
|
|
fixup(&word->parameter);
|
|
fixup(&word->plist);
|
|
}
|
|
|
|
void collect_word(F_WORD* word)
|
|
{
|
|
copy_object(&word->parameter);
|
|
copy_object(&word->plist);
|
|
}
|