libguile/vm-i-scheme.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 /* This file is included in vm_engine.c */
  19
  20 \f
  21 /*
  22  * Predicates
  23  */
  24
  25 #define ARGS1(a1)       SCM a1 = sp[0];
  26 #define ARGS2(a1,a2)    SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
  27 #define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
  28
  29 #define RETURN(x)       do { *sp = x; NEXT; } while (0)
  30
  31 VM_DEFINE_FUNCTION (80, not, "not", 1)
  32 {
  33   ARGS1 (x);
  34   RETURN (SCM_BOOL (SCM_FALSEP (x)));
  35 }
  36
  37 VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
  38 {
  39   ARGS1 (x);
  40   RETURN (SCM_BOOL (!SCM_FALSEP (x)));
  41 }
  42
  43 VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
  44 {
  45   ARGS2 (x, y);
  46   RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
  47 }
  48
  49 VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
  50 {
  51   ARGS2 (x, y);
  52   RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
  53 }
  54
  55 VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
  56 {
  57   ARGS1 (x);
  58   RETURN (SCM_BOOL (SCM_NULLP (x)));
  59 }
  60
  61 VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
  62 {
  63   ARGS1 (x);
  64   RETURN (SCM_BOOL (!SCM_NULLP (x)));
  65 }
  66
  67 VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
  68 {
  69   ARGS2 (x, y);
  70   if (SCM_EQ_P (x, y))
  71     RETURN (SCM_BOOL_T);
  72   if (SCM_IMP (x) || SCM_IMP (y))
  73     RETURN (SCM_BOOL_F);
  74   SYNC_REGISTER ();
  75   RETURN (scm_eqv_p (x, y));
  76 }
  77
  78 VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
  79 {
  80   ARGS2 (x, y);
  81   if (SCM_EQ_P (x, y))
  82     RETURN (SCM_BOOL_T);
  83   if (SCM_IMP (x) || SCM_IMP (y))
  84     RETURN (SCM_BOOL_F);
  85   SYNC_REGISTER ();
  86   RETURN (scm_equal_p (x, y));
  87 }
  88
  89 VM_DEFINE_FUNCTION (88, pairp, "pair?", 1)
  90 {
  91   ARGS1 (x);
  92   RETURN (SCM_BOOL (SCM_CONSP (x)));
  93 }
  94
  95 VM_DEFINE_FUNCTION (89, listp, "list?", 1)
  96 {
  97   ARGS1 (x);
  98   RETURN (SCM_BOOL (scm_ilength (x) >= 0));
  99 }
 100
 101 \f
 102 /*
 103  * Basic data
 104  */
 105
 106 VM_DEFINE_FUNCTION (90, cons, "cons", 2)
 107 {
 108   ARGS2 (x, y);
 109   CONS (x, x, y);
 110   RETURN (x);
 111 }
 112
 113 #define VM_VALIDATE_CONS(x)                     \
 114   if (SCM_UNLIKELY (!scm_is_pair (x)))          \
 115     { finish_args = x;                          \
 116       goto vm_error_not_a_pair;                 \
 117     }
 118
 119 VM_DEFINE_FUNCTION (91, car, "car", 1)
 120 {
 121   ARGS1 (x);
 122   VM_VALIDATE_CONS (x);
 123   RETURN (SCM_CAR (x));
 124 }
 125
 126 VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
 127 {
 128   ARGS1 (x);
 129   VM_VALIDATE_CONS (x);
 130   RETURN (SCM_CDR (x));
 131 }
 132
 133 VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2)
 134 {
 135   ARGS2 (x, y);
 136   VM_VALIDATE_CONS (x);
 137   SCM_SETCAR (x, y);
 138   RETURN (SCM_UNSPECIFIED);
 139 }
 140
 141 VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
 142 {
 143   ARGS2 (x, y);
 144   VM_VALIDATE_CONS (x);
 145   SCM_SETCDR (x, y);
 146   RETURN (SCM_UNSPECIFIED);
 147 }
 148
 149 \f
 150 /*
 151  * Numeric relational tests
 152  */
 153
 154 #undef REL
 155 #define REL(crel,srel)                                          \
 156 {                                                               \
 157   ARGS2 (x, y);                                                 \
 158   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))                       \
 159     RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y)));     \
 160   SYNC_REGISTER ();                                             \
 161   RETURN (srel (x, y));                                         \
 162 }
 163
 164 VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
 165 {
 166   REL (==, scm_num_eq_p);
 167 }
 168
 169 VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
 170 {
 171   REL (<, scm_less_p);
 172 }
 173
 174 VM_DEFINE_FUNCTION (97, le, "le?", 2)
 175 {
 176   REL (<=, scm_leq_p);
 177 }
 178
 179 VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
 180 {
 181   REL (>, scm_gr_p);
 182 }
 183
 184 VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
 185 {
 186   REL (>=, scm_geq_p);
 187 }
 188
 189 \f
 190 /*
 191  * Numeric functions
 192  */
 193
 194 #undef FUNC2
 195 #define FUNC2(CFUNC,SFUNC)                              \
 196 {                                                       \
 197   ARGS2 (x, y);                                         \
 198   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))               \
 199     {                                                   \
 200       scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
 201       if (SCM_FIXABLE (n))                              \
 202         RETURN (SCM_I_MAKINUM (n));                     \
 203     }                                                   \
 204   SYNC_REGISTER ();                                     \
 205   RETURN (SFUNC (x, y));                                \
 206 }
 207
 208 VM_DEFINE_FUNCTION (100, add, "add", 2)
 209 {
 210   FUNC2 (+, scm_sum);
 211 }
 212
 213 VM_DEFINE_FUNCTION (101, sub, "sub", 2)
 214 {
 215   FUNC2 (-, scm_difference);
 216 }
 217
 218 VM_DEFINE_FUNCTION (102, mul, "mul", 2)
 219 {
 220   ARGS2 (x, y);
 221   SYNC_REGISTER ();
 222   RETURN (scm_product (x, y));
 223 }
 224
 225 VM_DEFINE_FUNCTION (103, div, "div", 2)
 226 {
 227   ARGS2 (x, y);
 228   SYNC_REGISTER ();
 229   RETURN (scm_divide (x, y));
 230 }
 231
 232 VM_DEFINE_FUNCTION (104, quo, "quo", 2)
 233 {
 234   ARGS2 (x, y);
 235   SYNC_REGISTER ();
 236   RETURN (scm_quotient (x, y));
 237 }
 238
 239 VM_DEFINE_FUNCTION (105, rem, "rem", 2)
 240 {
 241   ARGS2 (x, y);
 242   SYNC_REGISTER ();
 243   RETURN (scm_remainder (x, y));
 244 }
 245
 246 VM_DEFINE_FUNCTION (106, mod, "mod", 2)
 247 {
 248   ARGS2 (x, y);
 249   SYNC_REGISTER ();
 250   RETURN (scm_modulo (x, y));
 251 }
 252
 253 \f
 254 /*
 255  * GOOPS support
 256  */
 257 VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
 258 {
 259   size_t slot;
 260   ARGS2 (instance, idx);
 261   slot = SCM_I_INUM (idx);
 262   RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 263 }
 264
 265 VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3)
 266 {
 267   size_t slot;
 268   ARGS3 (instance, idx, val);
 269   slot = SCM_I_INUM (idx);
 270   SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
 271   RETURN (SCM_UNSPECIFIED);
 272 }
 273
 274 /*
 275 (defun renumber-ops ()
 276   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
 277   (interactive "")
 278   (save-excursion
 279     (let ((counter 79)) (goto-char (point-min))
 280       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
 281         (replace-match
 282          (number-to-string (setq counter (1+ counter)))
 283           t t nil 1)))))
 284 */
 285
 286 /*
 287   Local Variables:
 288   c-file-style: "gnu"
 289   End:
 290 */