native/primitives.c

   1 #include "factor.h"
   2
   3 XT primitives[] = {
   4         undefined,                              /* 0 */
   5         call,                                   /* 1 */
   6         primitive_execute,                      /* 2 */
   7         primitive_call,                         /* 3 */
   8         primitive_ifte,                         /* 4 */
   9         primitive_consp,                        /* 5 */
  10         primitive_cons,                         /* 6 */
  11         primitive_car,                          /* 7 */
  12         primitive_cdr,                          /* 8 */
  13         primitive_rplaca,                       /* 9 */
  14         primitive_rplacd,                       /* 10 */
  15         primitive_vectorp,                      /* 11 */
  16         primitive_vector,                       /* 12 */
  17         primitive_vector_length,                /* 13 */
  18         primitive_set_vector_length,            /* 14 */
  19         primitive_vector_nth,                   /* 15 */
  20         primitive_set_vector_nth,               /* 16 */
  21         primitive_stringp,                      /* 17 */
  22         primitive_string_length,                /* 18 */
  23         primitive_string_nth,                   /* 19 */
  24         primitive_string_compare,               /* 20 */
  25         primitive_string_eq,                    /* 21 */
  26         primitive_string_hashcode,              /* 22 */
  27         primitive_index_of,                     /* 23 */
  28         primitive_substring,                    /* 24 */
  29         primitive_sbufp,                        /* 25 */
  30         primitive_sbuf,                         /* 26 */
  31         primitive_sbuf_length,                  /* 27 */
  32         primitive_set_sbuf_length,              /* 28 */
  33         primitive_sbuf_nth,                     /* 29 */
  34         primitive_set_sbuf_nth,                 /* 30 */
  35         primitive_sbuf_append,                  /* 31 */
  36         primitive_sbuf_to_string,               /* 32 */
  37         primitive_fixnump,                      /* 33 */
  38         primitive_bignump,                      /* 34 */
  39         primitive_add,                          /* 35 */
  40         primitive_subtract,                     /* 36 */
  41         primitive_multiply,                     /* 37 */
  42         primitive_divide,                       /* 38 */
  43         primitive_mod,                          /* 39 */
  44         primitive_divmod,                       /* 40 */
  45         primitive_and,                          /* 41 */
  46         primitive_or,                           /* 42 */
  47         primitive_xor,                          /* 43 */
  48         primitive_not,                          /* 44 */
  49         primitive_shiftleft,                    /* 45 */
  50         primitive_shiftright,                   /* 46 */
  51         primitive_less,                         /* 47 */
  52         primitive_lesseq,                       /* 48 */
  53         primitive_greater,                      /* 49 */
  54         primitive_greatereq,                    /* 50 */
  55         primitive_wordp,                        /* 51 */
  56         primitive_word,                         /* 52 */
  57         primitive_word_primitive,               /* 53 */
  58         primitive_set_word_primitive,           /* 54 */
  59         primitive_word_parameter,               /* 55 */
  60         primitive_set_word_parameter,           /* 56 */
  61         primitive_word_plist,                   /* 57 */
  62         primitive_set_word_plist,               /* 58 */
  63         primitive_drop,                         /* 59 */
  64         primitive_dup,                          /* 60 */
  65         primitive_swap,                         /* 61 */
  66         primitive_over,                         /* 62 */
  67         primitive_pick,                         /* 63 */
  68         primitive_nip,                          /* 64 */
  69         primitive_tuck,                         /* 65 */
  70         primitive_rot,                          /* 66 */
  71         primitive_to_r,                         /* 67 */
  72         primitive_from_r,                       /* 68 */
  73         primitive_eq,                           /* 69 */
  74         primitive_getenv,                       /* 70 */
  75         primitive_setenv,                       /* 71 */
  76         primitive_open_file,                    /* 72 */
  77         primitive_gc,                           /* 73 */
  78         primitive_save_image,                   /* 74 */
  79         primitive_datastack,                    /* 75 */
  80         primitive_callstack,                    /* 76 */
  81         primitive_set_datastack,                /* 77 */
  82         primitive_set_callstack,                /* 78 */
  83         primitive_handlep,                      /* 79 */
  84         primitive_exit,                         /* 80 */
  85         primitive_server_socket,                /* 81 */
  86         primitive_close_fd,                     /* 82 */
  87         primitive_accept_fd,                    /* 83 */
  88         primitive_read_line_fd_8,               /* 84 */
  89         primitive_write_fd_8,                   /* 85 */
  90         primitive_flush_fd,                     /* 86 */
  91         primitive_shutdown_fd,                  /* 87 */
  92         primitive_room                          /* 88 */
  93 };
  94
  95 CELL primitive_to_xt(CELL primitive)
  96 {
  97         if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
  98                 general_error(ERROR_BAD_PRIMITIVE,tag_fixnum(primitive));
  99
 100         return (CELL)primitives[primitive];
 101 }
 102
 103 void primitive_eq(void)
 104 {
 105         check_non_empty(env.dt);
 106         check_non_empty(dpeek());
 107         env.dt = tag_boolean(dpop() == env.dt);
 108 }