libguile/eq.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 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 License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * 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
  16  * 02110-1301 USA
  17  */
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include <math.h>
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/array-map.h"
  28 #include "libguile/stackchk.h"
  29 #include "libguile/strorder.h"
  30 #include "libguile/async.h"
  31 #include "libguile/root.h"
  32 #include "libguile/smob.h"
  33 #include "libguile/arrays.h"
  34 #include "libguile/vectors.h"
  35 #include "libguile/hashtab.h"
  36 #include "libguile/bytevectors.h"
  37
  38 #include "libguile/struct.h"
  39 #include "libguile/goops.h"
  40
  41 #include "libguile/validate.h"
  42 #include "libguile/eq.h"
  43
  44 #include "libguile/private-options.h"
  45
  46 \f
  47
  48 #ifdef HAVE_STRING_H
  49 #include <string.h>
  50 #endif
  51 \f
  52
  53 static SCM scm_i_eq_p (SCM x, SCM y, SCM rest);
  54 SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1,
  55             (SCM x, SCM y, SCM rest),
  56             "Return @code{#t} if @var{x} and @var{y} are the same object,\n"
  57             "except for numbers and characters.  For example,\n"
  58             "\n"
  59             "@example\n"
  60             "(define x (vector 1 2 3))\n"
  61             "(define y (vector 1 2 3))\n"
  62             "\n"
  63             "(eq? x x)  @result{} #t\n"
  64             "(eq? x y)  @result{} #f\n"
  65             "@end example\n"
  66             "\n"
  67             "Numbers and characters are not equal to any other object, but\n"
  68             "the problem is they're not necessarily @code{eq?} to themselves\n"
  69             "either.  This is even so when the number comes directly from a\n"
  70             "variable,\n"
  71             "\n"
  72             "@example\n"
  73             "(let ((n (+ 2 3)))\n"
  74             "  (eq? n n))       @result{} *unspecified*\n"
  75             "@end example\n"
  76             "\n"
  77             "Generally @code{eqv?} should be used when comparing numbers or\n"
  78             "characters.  @code{=} or @code{char=?} can be used too.\n"
  79             "\n"
  80             "It's worth noting that end-of-list @code{()}, @code{#t},\n"
  81             "@code{#f}, a symbol of a given name, and a keyword of a given\n"
  82             "name, are unique objects.  There's just one of each, so for\n"
  83             "instance no matter how @code{()} arises in a program, it's the\n"
  84             "same object and can be compared with @code{eq?},\n"
  85             "\n"
  86             "@example\n"
  87             "(define x (cdr '(123)))\n"
  88             "(define y (cdr '(456)))\n"
  89             "(eq? x y) @result{} #t\n"
  90             "\n"
  91             "(define x (string->symbol \"foo\"))\n"
  92             "(eq? x 'foo) @result{} #t\n"
  93             "@end example")
  94 #define FUNC_NAME s_scm_i_eq_p
  95 {
  96   if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
  97     return SCM_BOOL_T;
  98   while (scm_is_pair (rest))
  99     {
 100       if (!scm_is_eq (x, y))
 101         return SCM_BOOL_F;
 102       x = y;
 103       y = scm_car (rest);
 104       rest = scm_cdr (rest);
 105     }
 106   return scm_from_bool (scm_is_eq (x, y));
 107 }
 108 #undef FUNC_NAME
 109
 110 SCM
 111 scm_eq_p (SCM x, SCM y)
 112 {
 113   return scm_from_bool (scm_is_eq (x, y));
 114 }
 115
 116 /* We compare doubles in a special way for 'eqv?' to be able to
 117    distinguish plus and minus zero and to identify NaNs.
 118 */
 119
 120 static int
 121 real_eqv (double x, double y)
 122 {
 123   return !memcmp (&x, &y, sizeof(double))
 124     || (SCM_UNLIKELY (isnan (x)) && SCM_UNLIKELY (isnan (y)));
 125 }
 126
 127 SCM
 128 scm_real_equalp (SCM x, SCM y)
 129 {
 130   return scm_from_bool (real_eqv (SCM_REAL_VALUE (x),
 131                                   SCM_REAL_VALUE (y)));
 132 }
 133
 134 SCM
 135 scm_bigequal (SCM x, SCM y)
 136 {
 137   return scm_from_bool (scm_i_bigcmp (x, y) == 0);
 138 }
 139
 140 SCM
 141 scm_complex_equalp (SCM x, SCM y)
 142 {
 143   return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
 144                                   SCM_COMPLEX_REAL (y))
 145                         && real_eqv (SCM_COMPLEX_IMAG (x),
 146                                      SCM_COMPLEX_IMAG (y)));
 147 }
 148
 149 SCM
 150 scm_i_fraction_equalp (SCM x, SCM y)
 151 {
 152   return scm_from_bool
 153     (scm_is_true (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
 154                                SCM_FRACTION_NUMERATOR (y)))
 155      && scm_is_true (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
 156                                   SCM_FRACTION_DENOMINATOR (y))));
 157 }
 158
 159 static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
 160 #include <stdio.h>
 161 SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
 162             (SCM x, SCM y, SCM rest),
 163             "Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
 164             "for characters and numbers the same value.\n"
 165             "\n"
 166             "On objects except characters and numbers, @code{eqv?} is the\n"
 167             "same as @code{eq?}, it's true if @var{x} and @var{y} are the\n"
 168             "same object.\n"
 169             "\n"
 170             "If @var{x} and @var{y} are numbers or characters, @code{eqv?}\n"
 171             "compares their type and value.  An exact number is not\n"
 172             "@code{eqv?} to an inexact number (even if their value is the\n"
 173             "same).\n"
 174             "\n"
 175             "@example\n"
 176             "(eqv? 3 (+ 1 2)) @result{} #t\n"
 177             "(eqv? 1 1.0)     @result{} #f\n"
 178             "@end example")
 179 #define FUNC_NAME s_scm_i_eqv_p
 180 {
 181   if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
 182     return SCM_BOOL_T;
 183   while (!scm_is_null (rest))
 184     {
 185       if (!scm_is_true (scm_eqv_p (x, y)))
 186         return SCM_BOOL_F;
 187       x = y;
 188       y = scm_car (rest);
 189       rest = scm_cdr (rest);
 190     }
 191   return scm_eqv_p (x, y);
 192 }
 193 #undef FUNC_NAME
 194
 195 SCM scm_eqv_p (SCM x, SCM y)
 196 #define FUNC_NAME s_scm_i_eqv_p
 197 {
 198   if (scm_is_eq (x, y))
 199     return SCM_BOOL_T;
 200   if (SCM_IMP (x))
 201     return SCM_BOOL_F;
 202   if (SCM_IMP (y))
 203     return SCM_BOOL_F;
 204
 205   /* this ensures that types and scm_length are the same. */
 206   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
 207     return SCM_BOOL_F;
 208   switch (SCM_TYP7 (x))
 209     {
 210     default:
 211       break;
 212     case scm_tc7_number:
 213       switch SCM_TYP16 (x)
 214         {
 215         case scm_tc16_big:
 216           return scm_bigequal (x, y);
 217         case scm_tc16_real:
 218           return scm_real_equalp (x, y);
 219         case scm_tc16_complex:
 220           return scm_complex_equalp (x, y);
 221         case scm_tc16_fraction:
 222           return scm_i_fraction_equalp (x, y);
 223         }
 224     }
 225   return SCM_BOOL_F;
 226 }
 227 #undef FUNC_NAME
 228
 229
 230 static SCM scm_i_equal_p (SCM, SCM, SCM);
 231 SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1,
 232                        (SCM x, SCM y, SCM rest),
 233                        "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
 234                        "their contents or value are equal.\n"
 235                        "\n"
 236                        "For a pair, string, vector or array, @code{equal?} compares the\n"
 237                        "contents, and does so using using the same @code{equal?}\n"
 238                        "recursively, so a deep structure can be traversed.\n"
 239                        "\n"
 240                        "@example\n"
 241                        "(equal? (list 1 2 3) (list 1 2 3))   @result{} #t\n"
 242                        "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
 243                        "@end example\n"
 244                        "\n"
 245                        "For other objects, @code{equal?} compares as per @code{eqv?},\n"
 246                        "which means characters and numbers are compared by type and\n"
 247                        "value (and like @code{eqv?}, exact and inexact numbers are not\n"
 248                        "@code{equal?}, even if their value is the same).\n"
 249                        "\n"
 250                        "@example\n"
 251                        "(equal? 3 (+ 1 2)) @result{} #t\n"
 252                        "(equal? 1 1.0)     @result{} #f\n"
 253                        "@end example\n"
 254                        "\n"
 255                        "Hash tables are currently only compared as per @code{eq?}, so\n"
 256                        "two different tables are not @code{equal?}, even if their\n"
 257                        "contents are the same.\n"
 258                        "\n"
 259                        "@code{equal?} does not support circular data structures, it may\n"
 260                        "go into an infinite loop if asked to compare two circular lists\n"
 261                        "or similar.\n"
 262                        "\n"
 263                        "New application-defined object types (Smobs) have an\n"
 264                        "@code{equalp} handler which is called by @code{equal?}.  This\n"
 265                        "lets an application traverse the contents or control what is\n"
 266                        "considered @code{equal?} for two such objects.  If there's no\n"
 267                        "handler, the default is to just compare as per @code{eq?}.")
 268 #define FUNC_NAME s_scm_i_equal_p
 269 {
 270   if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
 271     return SCM_BOOL_T;
 272   while (!scm_is_null (rest))
 273     {
 274       if (!scm_is_true (scm_equal_p (x, y)))
 275         return SCM_BOOL_F;
 276       x = y;
 277       y = scm_car (rest);
 278       rest = SCM_CDR (rest);
 279     }
 280   return scm_equal_p (x, y);
 281 }
 282 #undef FUNC_NAME
 283
 284 SCM
 285 scm_equal_p (SCM x, SCM y)
 286 #define FUNC_NAME s_scm_i_equal_p
 287 {
 288   SCM_CHECK_STACK;
 289  tailrecurse:
 290   SCM_TICK;
 291   if (scm_is_eq (x, y))
 292     return SCM_BOOL_T;
 293   if (SCM_IMP (x))
 294     return SCM_BOOL_F;
 295   if (SCM_IMP (y))
 296     return SCM_BOOL_F;
 297   if (scm_is_pair (x) && scm_is_pair (y))
 298     {
 299       if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
 300         return SCM_BOOL_F;
 301       x = SCM_CDR(x);
 302       y = SCM_CDR(y);
 303       goto tailrecurse;
 304     }
 305   if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
 306     {
 307       int i = SCM_SMOBNUM (x);
 308       if (!(i < scm_numsmob))
 309         return SCM_BOOL_F;
 310       if (scm_smobs[i].equalp)
 311         return (scm_smobs[i].equalp) (x, y);
 312       else
 313         goto generic_equal;
 314     }
 315
 316   /* This ensures that types and scm_length are the same.  */
 317   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
 318     {
 319       /* Vectors can be equal to one-dimensional arrays.
 320        */
 321       if (scm_is_array (x) && scm_is_array (y))
 322         return scm_array_equal_p (x, y);
 323
 324       return SCM_BOOL_F;
 325     }
 326   switch (SCM_TYP7 (x))
 327     {
 328     default:
 329       /* Check equality between structs of equal type (see cell-type test above). */
 330       if (SCM_STRUCTP (x))
 331         {
 332           if (SCM_INSTANCEP (x))
 333             goto generic_equal;
 334           else
 335             return scm_i_struct_equalp (x, y);
 336         }
 337       break;
 338     case scm_tc7_number:
 339       switch SCM_TYP16 (x)
 340         {
 341         case scm_tc16_big:
 342           return scm_bigequal (x, y);
 343         case scm_tc16_real:
 344           return scm_real_equalp (x, y);
 345         case scm_tc16_complex:
 346           return scm_complex_equalp (x, y);
 347         case scm_tc16_fraction:
 348           return scm_i_fraction_equalp (x, y);
 349         default:
 350           /* assert not reached? */
 351           return SCM_BOOL_F;
 352         }
 353     case scm_tc7_pointer:
 354       return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y));
 355     case scm_tc7_string:
 356       return scm_string_equal_p (x, y);
 357     case scm_tc7_bytevector:
 358       return scm_bytevector_eq_p (x, y);
 359     case scm_tc7_array:
 360       return scm_array_equal_p (x, y);
 361     case scm_tc7_bitvector:
 362       return scm_i_bitvector_equal_p (x, y);
 363     case scm_tc7_vector:
 364     case scm_tc7_wvect:
 365       return scm_i_vector_equal_p (x, y);
 366     }
 367
 368   /* Otherwise just return false. Dispatching to the generic is the wrong thing
 369      here, as we can hit this case for any two objects of the same type that we
 370      think are distinct, like different symbols. */
 371   return SCM_BOOL_F;
 372
 373  generic_equal:
 374   if (SCM_UNPACK (g_scm_i_equal_p))
 375     return scm_call_2 (g_scm_i_equal_p, x, y);
 376   else
 377     return SCM_BOOL_F;
 378 }
 379 #undef FUNC_NAME
 380
 381
 382 \f
 383
 384
 385
 386 void
 387 scm_init_eq ()
 388 {
 389 #include "libguile/eq.x"
 390 }
 391
 392
 393 /*
 394   Local Variables:
 395   c-file-style: "gnu"
 396   End:
 397 */