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_string && SCM_TYP7 (y) == scm_tc7_string)
 306     return scm_string_equal_p (x, y);
 307   if (SCM_TYP7 (x) == scm_tc7_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector)
 308     return scm_bytevector_eq_p (x, y);
 309   if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
 310     {
 311       int i = SCM_SMOBNUM (x);
 312       if (!(i < scm_numsmob))
 313         return SCM_BOOL_F;
 314       if (scm_smobs[i].equalp)
 315         return (scm_smobs[i].equalp) (x, y);
 316       else
 317         goto generic_equal;
 318     }
 319   if (SCM_POINTER_P (x) && SCM_POINTER_P (y))
 320     return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y));
 321
 322   /* This ensures that types and scm_length are the same.  */
 323   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
 324     {
 325       /* Vectors can be equal to one-dimensional arrays.
 326        */
 327       if (scm_is_array (x) && scm_is_array (y))
 328         return scm_array_equal_p (x, y);
 329
 330       return SCM_BOOL_F;
 331     }
 332   switch (SCM_TYP7 (x))
 333     {
 334     default:
 335       /* Check equality between structs of equal type (see cell-type test above). */
 336       if (SCM_STRUCTP (x))
 337         {
 338           if (SCM_INSTANCEP (x))
 339             goto generic_equal;
 340           else
 341             return scm_i_struct_equalp (x, y);
 342         }
 343       break;
 344     case scm_tc7_number:
 345       switch SCM_TYP16 (x)
 346         {
 347         case scm_tc16_big:
 348           return scm_bigequal (x, y);
 349         case scm_tc16_real:
 350           return scm_real_equalp (x, y);
 351         case scm_tc16_complex:
 352           return scm_complex_equalp (x, y);
 353         case scm_tc16_fraction:
 354           return scm_i_fraction_equalp (x, y);
 355         }
 356     case scm_tc7_vector:
 357     case scm_tc7_wvect:
 358       return scm_i_vector_equal_p (x, y);
 359     }
 360
 361   /* Otherwise just return false. Dispatching to the generic is the wrong thing
 362      here, as we can hit this case for any two objects of the same type that we
 363      think are distinct, like different symbols. */
 364   return SCM_BOOL_F;
 365
 366  generic_equal:
 367   if (SCM_UNPACK (g_scm_i_equal_p))
 368     return scm_call_generic_2 (g_scm_i_equal_p, x, y);
 369   else
 370     return SCM_BOOL_F;
 371 }
 372 #undef FUNC_NAME
 373
 374
 375 \f
 376
 377
 378
 379 void
 380 scm_init_eq ()
 381 {
 382 #include "libguile/eq.x"
 383 }
 384
 385
 386 /*
 387   Local Variables:
 388   c-file-style: "gnu"
 389   End:
 390 */