libguile/vm-i-scheme.c

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