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                         /* printf("EXECUTE %d\n",env.w->primitive); */
  49                         EXECUTE(env.w);
  50                 }
  51                 else
  52                 {
  53                         /* printf("DPUSH %d\n",type_of(next)); */
  54                         dpush(env.dt);
  55                         env.dt = next;
  56                 }
  57         }
  58 }
  59
  60 /* XT of deferred words */
  61 void undefined()
  62 {
  63         general_error(ERROR_UNDEFINED_WORD,tag_word(env.w));
  64 }
  65
  66 /* XT of compound definitions */
  67 void call()
  68 {
  69         /* tail call optimization */
  70         if(env.cf != F)
  71                 cpush(env.cf);
  72         /* the parameter is the colon def */
  73         env.cf = env.w->parameter;
  74 }
  75
  76
  77 void primitive_execute(void)
  78 {
  79         WORD* word = untag_word(env.dt);
  80         env.dt = dpop();
  81         env.w = word;
  82         EXECUTE(env.w);
  83 }
  84
  85 void primitive_call(void)
  86 {
  87         CELL calling = env.dt;
  88         env.dt = dpop();
  89         if(env.cf != F)
  90                 cpush(env.cf);
  91         env.cf = calling;
  92 }
  93
  94 void primitive_ifte(void)
  95 {
  96         CELL f = env.dt;
  97         CELL t = dpop();
  98         CELL cond = dpop();
  99         CELL calling = (untag_boolean(cond) ? t : f);
 100         env.dt = dpop();
 101         if(env.cf != F)
 102                 cpush(env.cf);
 103         env.cf = calling;
 104 }
 105
 106 void primitive_getenv(void)
 107 {
 108         FIXNUM e = to_fixnum(env.dt);
 109         if(e < 0 || e >= USER_ENV)
 110                 range_error(F,e,USER_ENV);
 111         env.dt = env.user[e];
 112 }
 113
 114 void primitive_setenv(void)
 115 {
 116         FIXNUM e = to_fixnum(env.dt);
 117         CELL value = dpop();
 118         if(e < 0 || e >= USER_ENV)
 119                 range_error(F,e,USER_ENV);
 120         check_non_empty(value);
 121         env.user[e] = value;
 122         env.dt = dpop();
 123 }
 124
 125 void primitive_exit(void)
 126 {
 127         exit(to_fixnum(env.dt));
 128 }