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