src/vm_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 VM_DEFINE_FUNCTION (not, "not", 1)
  50 {
  51   ARGS1 (x);
  52   RETURN (SCM_BOOL (SCM_FALSEP (x)));
  53 }
  54
  55 VM_DEFINE_FUNCTION (not_not, "not-not", 1)
  56 {
  57   ARGS1 (x);
  58   RETURN (SCM_BOOL (!SCM_FALSEP (x)));
  59 }
  60
  61 VM_DEFINE_FUNCTION (eq, "eq?", 2)
  62 {
  63   ARGS2 (x, y);
  64   RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
  65 }
  66
  67 VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
  68 {
  69   ARGS2 (x, y);
  70   RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
  71 }
  72
  73 VM_DEFINE_FUNCTION (nullp, "null?", 1)
  74 {
  75   ARGS1 (x);
  76   RETURN (SCM_BOOL (SCM_NULLP (x)));
  77 }
  78
  79 VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
  80 {
  81   ARGS1 (x);
  82   RETURN (SCM_BOOL (!SCM_NULLP (x)));
  83 }
  84
  85 VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
  86 {
  87   ARGS2 (x, y);
  88   if (SCM_EQ_P (x, y))
  89     RETURN (SCM_BOOL_T);
  90   if (SCM_IMP (x) || SCM_IMP (y))
  91     RETURN (SCM_BOOL_F);
  92   SYNC_BEFORE_GC ();
  93   RETURN (scm_eqv_p (x, y));
  94 }
  95
  96 VM_DEFINE_FUNCTION (equal, "equal?", 2)
  97 {
  98   ARGS2 (x, y);
  99   if (SCM_EQ_P (x, y))
 100     RETURN (SCM_BOOL_T);
 101   if (SCM_IMP (x) || SCM_IMP (y))
 102     RETURN (SCM_BOOL_F);
 103   SYNC_BEFORE_GC ();
 104   RETURN (scm_equal_p (x, y));
 105 }
 106
 107 VM_DEFINE_FUNCTION (pairp, "pair?", 1)
 108 {
 109   ARGS1 (x);
 110   RETURN (SCM_BOOL (SCM_CONSP (x)));
 111 }
 112
 113 VM_DEFINE_FUNCTION (listp, "list?", 1)
 114 {
 115   ARGS1 (x);
 116   RETURN (SCM_BOOL (scm_ilength (x) >= 0));
 117 }
 118
 119 \f
 120 /*
 121  * Basic data
 122  */
 123
 124 VM_DEFINE_FUNCTION (cons, "cons", 2)
 125 {
 126   ARGS2 (x, y);
 127   CONS (x, x, y);
 128   RETURN (x);
 129 }
 130
 131 VM_DEFINE_FUNCTION (car, "car", 1)
 132 {
 133   ARGS1 (x);
 134   SCM_VALIDATE_CONS (1, x);
 135   RETURN (SCM_CAR (x));
 136 }
 137
 138 VM_DEFINE_FUNCTION (cdr, "cdr", 1)
 139 {
 140   ARGS1 (x);
 141   SCM_VALIDATE_CONS (1, x);
 142   RETURN (SCM_CDR (x));
 143 }
 144
 145 VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
 146 {
 147   ARGS2 (x, y);
 148   SCM_VALIDATE_CONS (1, x);
 149   SCM_SETCAR (x, y);
 150   RETURN (SCM_UNSPECIFIED);
 151 }
 152
 153 VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
 154 {
 155   ARGS2 (x, y);
 156   SCM_VALIDATE_CONS (1, x);
 157   SCM_SETCDR (x, y);
 158   RETURN (SCM_UNSPECIFIED);
 159 }
 160
 161 \f
 162 /*
 163  * Numeric relational tests
 164  */
 165
 166 #undef REL
 167 #define REL(crel,srel)                                          \
 168 {                                                               \
 169   ARGS2 (x, y);                                                 \
 170   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))                       \
 171     RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y)));     \
 172   RETURN (srel (x, y));                                         \
 173 }
 174
 175 VM_DEFINE_FUNCTION (ee, "ee?", 2)
 176 {
 177   REL (==, scm_num_eq_p);
 178 }
 179
 180 VM_DEFINE_FUNCTION (lt, "lt?", 2)
 181 {
 182   REL (<, scm_less_p);
 183 }
 184
 185 VM_DEFINE_FUNCTION (le, "le?", 2)
 186 {
 187   REL (<=, scm_leq_p);
 188 }
 189
 190 VM_DEFINE_FUNCTION (gt, "gt?", 2)
 191 {
 192   REL (>, scm_gr_p);
 193 }
 194
 195 VM_DEFINE_FUNCTION (ge, "ge?", 2)
 196 {
 197   REL (>=, scm_geq_p);
 198 }
 199
 200 \f
 201 /*
 202  * Numeric functions
 203  */
 204
 205 #undef FUNC1
 206 #define FUNC1(CEXP,SEXP)                        \
 207 {                                               \
 208   ARGS1 (x);                                    \
 209   if (SCM_I_INUMP (x))                          \
 210     {                                           \
 211       int n = CEXP;                             \
 212       if (SCM_FIXABLE (n))                      \
 213         RETURN (SCM_I_MAKINUM (n));             \
 214     }                                           \
 215   SYNC_BEFORE_GC ();                            \
 216   RETURN (SEXP);                                \
 217 }
 218
 219 #undef FUNC2
 220 #define FUNC2(CFUNC,SFUNC)                              \
 221 {                                                       \
 222   ARGS2 (x, y);                                         \
 223   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))               \
 224     {                                                   \
 225       int n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);      \
 226       if (SCM_FIXABLE (n))                              \
 227         RETURN (SCM_I_MAKINUM (n));                     \
 228     }                                                   \
 229   SYNC_BEFORE_GC ();                                    \
 230   RETURN (SFUNC (x, y));                                \
 231 }
 232
 233 VM_DEFINE_FUNCTION (add, "add", 2)
 234 {
 235   FUNC2 (+, scm_sum);
 236 }
 237
 238 VM_DEFINE_FUNCTION (sub, "sub", 2)
 239 {
 240   FUNC2 (-, scm_difference);
 241 }
 242
 243 VM_DEFINE_FUNCTION (mul, "mul", 2)
 244 {
 245   ARGS2 (x, y);
 246   SYNC_BEFORE_GC ();
 247   RETURN (scm_product (x, y));
 248 }
 249
 250 VM_DEFINE_FUNCTION (div, "div", 2)
 251 {
 252   ARGS2 (x, y);
 253   SYNC_BEFORE_GC ();
 254   RETURN (scm_divide (x, y));
 255 }
 256
 257 VM_DEFINE_FUNCTION (quo, "quo", 2)
 258 {
 259   ARGS2 (x, y);
 260   SYNC_BEFORE_GC ();
 261   RETURN (scm_quotient (x, y));
 262 }
 263
 264 VM_DEFINE_FUNCTION (rem, "rem", 2)
 265 {
 266   ARGS2 (x, y);
 267   SYNC_BEFORE_GC ();
 268   RETURN (scm_remainder (x, y));
 269 }
 270
 271 VM_DEFINE_FUNCTION (mod, "mod", 2)
 272 {
 273   ARGS2 (x, y);
 274   SYNC_BEFORE_GC ();
 275   RETURN (scm_modulo (x, y));
 276 }
 277
 278 /*
 279   Local Variables:
 280   c-file-style: "gnu"
 281   End:
 282 */