native/run.c

   1 #include "factor.h"
   2
   3 void clear_environment(void)
   4 {
   5         int i;
   6         for(i = 0; i < USER_ENV; i++)
   7                 env.user[i] = 0;
   8 }
   9
  10 void init_environment(void)
  11 {
  12         /* + CELLS * 2 to skip header and length cell */
  13         env.ds_bot = tag_object(array(STACK_SIZE,empty));
  14         reset_datastack();
  15         env.cs_bot = tag_object(array(STACK_SIZE,empty));
  16         reset_callstack();
  17         env.cf = env.boot;
  18 }
  19
  20 #define EXECUTE(w) ((XT)(UNTAG(w->xt)))()
  21
  22 void run(void)
  23 {
  24         CELL next;
  25
  26         /* Error handling. */
  27         setjmp(toplevel);
  28
  29         for(;;)
  30         {
  31                 check_stacks();
  32
  33                 if(env.cf == F)
  34                 {
  35                         if(cpeek() == empty)
  36                                 break;
  37
  38                         env.cf = cpop();
  39                         continue;
  40                 }
  41
  42                 env.cf = (CELL)untag_cons(env.cf);
  43                 next = get(env.cf);
  44                 env.cf = get(env.cf + CELLS);
  45
  46                 if(TAG(next) == WORD_TYPE)
  47                 {
  48                         env.w = (WORD*)UNTAG(next);
  49                         EXECUTE(env.w);
  50                 }
  51                 else
  52                 {
  53                         dpush(env.dt);
  54                         env.dt = next;
  55                 }
  56         }
  57 }
  58
  59 /* XT of deferred words */
  60 void undefined()
  61 {
  62         general_error(ERROR_UNDEFINED_WORD,tag_word(env.w));
  63 }
  64
  65 /* XT of compound definitions */
  66 void call()
  67 {
  68         /* tail call optimization */
  69         if(env.cf != F)
  70                 cpush(env.cf);
  71         /* the parameter is the colon def */
  72         env.cf = env.w->parameter;
  73 }
  74
  75
  76 void primitive_execute(void)
  77 {
  78         WORD* word = untag_word(env.dt);
  79         env.dt = dpop();
  80         env.w = word;
  81         EXECUTE(env.w);
  82 }
  83
  84 void primitive_call(void)
  85 {
  86         CELL calling = env.dt;
  87         env.dt = dpop();
  88         if(env.cf != F)
  89                 cpush(env.cf);
  90         env.cf = calling;
  91 }
  92
  93 void primitive_ifte(void)
  94 {
  95         CELL f = env.dt;
  96         CELL t = dpop();
  97         CELL cond = dpop();
  98         CELL calling = (untag_boolean(cond) ? t : f);
  99         env.dt = dpop();
 100         if(env.cf != F)
 101                 cpush(env.cf);
 102         env.cf = calling;
 103 }
 104
 105 void primitive_getenv(void)
 106 {
 107         FIXNUM e = untag_fixnum(env.dt);
 108         if(e < 0 || e >= USER_ENV)
 109                 range_error(F,e,USER_ENV);
 110         env.dt = env.user[e];
 111 }
 112
 113 void primitive_setenv(void)
 114 {
 115         FIXNUM e = untag_fixnum(env.dt);
 116         CELL value = dpop();
 117         if(e < 0 || e >= USER_ENV)
 118                 range_error(F,e,USER_ENV);
 119         check_non_empty(value);
 120         env.user[e] = value;
 121         env.dt = dpop();
 122 }
 123
 124 void primitive_exit(void)
 125 {
 126         exit(untag_fixnum(env.dt));
 127 }