libguile/eq.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009 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 "libguile/_scm.h"
  25 #include "libguile/array-map.h"
  26 #include "libguile/stackchk.h"
  27 #include "libguile/strorder.h"
  28 #include "libguile/async.h"
  29 #include "libguile/root.h"
  30 #include "libguile/smob.h"
  31 #include "libguile/arrays.h"
  32 #include "libguile/vectors.h"
  33
  34 #include "libguile/struct.h"
  35 #include "libguile/goops.h"
  36 #include "libguile/objects.h"
  37
  38 #include "libguile/validate.h"
  39 #include "libguile/eq.h"
  40
  41 #include "libguile/private-options.h"
  42
  43 \f
  44
  45 #ifdef HAVE_STRING_H
  46 #include <string.h>
  47 #endif
  48 \f
  49
  50 SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
  51              (SCM x, SCM y),
  52             "Return @code{#t} if @var{x} and @var{y} are the same object,\n"
  53             "except for numbers and characters.  For example,\n"
  54             "\n"
  55             "@example\n"
  56             "(define x (vector 1 2 3))\n"
  57             "(define y (vector 1 2 3))\n"
  58             "\n"
  59             "(eq? x x)  @result{} #t\n"
  60             "(eq? x y)  @result{} #f\n"
  61             "@end example\n"
  62             "\n"
  63             "Numbers and characters are not equal to any other object, but\n"
  64             "the problem is they're not necessarily @code{eq?} to themselves\n"
  65             "either.  This is even so when the number comes directly from a\n"
  66             "variable,\n"
  67             "\n"
  68             "@example\n"
  69             "(let ((n (+ 2 3)))\n"
  70             "  (eq? n n))       @result{} *unspecified*\n"
  71             "@end example\n"
  72             "\n"
  73             "Generally @code{eqv?} should be used when comparing numbers or\n"
  74             "characters.  @code{=} or @code{char=?} can be used too.\n"
  75             "\n"
  76             "It's worth noting that end-of-list @code{()}, @code{#t},\n"
  77             "@code{#f}, a symbol of a given name, and a keyword of a given\n"
  78             "name, are unique objects.  There's just one of each, so for\n"
  79             "instance no matter how @code{()} arises in a program, it's the\n"
  80             "same object and can be compared with @code{eq?},\n"
  81             "\n"
  82             "@example\n"
  83             "(define x (cdr '(123)))\n"
  84             "(define y (cdr '(456)))\n"
  85             "(eq? x y) @result{} #t\n"
  86             "\n"
  87             "(define x (string->symbol \"foo\"))\n"
  88             "(eq? x 'foo) @result{} #t\n"
  89             "@end example")
  90 #define FUNC_NAME s_scm_eq_p
  91 {
  92   return scm_from_bool (scm_is_eq (x, y));
  93 }
  94 #undef FUNC_NAME
  95
  96 /* We compare doubles in a special way for 'eqv?' to be able to
  97    distinguish plus and minus zero and to identify NaNs.
  98 */
  99
 100 static int
 101 real_eqv (double x, double y)
 102 {
 103   return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
 104 }
 105
 106 #include <stdio.h>
 107 SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
 108              (SCM x, SCM y),
 109             "Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
 110             "for characters and numbers the same value.\n"
 111             "\n"
 112             "On objects except characters and numbers, @code{eqv?} is the\n"
 113             "same as @code{eq?}, it's true if @var{x} and @var{y} are the\n"
 114             "same object.\n"
 115             "\n"
 116             "If @var{x} and @var{y} are numbers or characters, @code{eqv?}\n"
 117             "compares their type and value.  An exact number is not\n"
 118             "@code{eqv?} to an inexact number (even if their value is the\n"
 119             "same).\n"
 120             "\n"
 121             "@example\n"
 122             "(eqv? 3 (+ 1 2)) @result{} #t\n"
 123             "(eqv? 1 1.0)     @result{} #f\n"
 124             "@end example")
 125 #define FUNC_NAME s_scm_eqv_p
 126 {
 127   if (scm_is_eq (x, y))
 128     return SCM_BOOL_T;
 129   if (SCM_IMP (x))
 130     return SCM_BOOL_F;
 131   if (SCM_IMP (y))
 132     return SCM_BOOL_F;
 133   /* this ensures that types and scm_length are the same. */
 134
 135   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
 136     {
 137       /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
 138          but this checks the entire type word, so fractions may be accidentally
 139          flagged here as unequal.  Perhaps I should use the 4th double_cell word?
 140       */
 141
 142       /* treat mixes of real and complex types specially */
 143       if (SCM_INEXACTP (x))
 144         {
 145           if (SCM_REALP (x))
 146             return scm_from_bool (SCM_COMPLEXP (y)
 147                              && real_eqv (SCM_REAL_VALUE (x),
 148                                           SCM_COMPLEX_REAL (y))
 149                              && SCM_COMPLEX_IMAG (y) == 0.0);
 150           else
 151             return scm_from_bool (SCM_REALP (y)
 152                              && real_eqv (SCM_COMPLEX_REAL (x),
 153                                           SCM_REAL_VALUE (y))
 154                              && SCM_COMPLEX_IMAG (x) == 0.0);
 155         }
 156
 157       if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
 158         return scm_i_fraction_equalp (x, y);
 159       return SCM_BOOL_F;
 160     }
 161   if (SCM_NUMP (x))
 162     {
 163       if (SCM_BIGP (x)) {
 164         return scm_from_bool (scm_i_bigcmp (x, y) == 0);
 165       } else if (SCM_REALP (x)) {
 166         return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
 167       } else if (SCM_FRACTIONP (x)) {
 168         return scm_i_fraction_equalp (x, y);
 169       } else { /* complex */
 170         return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
 171                                    SCM_COMPLEX_REAL (y))
 172                          && real_eqv (SCM_COMPLEX_IMAG (x),
 173                                       SCM_COMPLEX_IMAG (y)));
 174       }
 175     }
 176   if (SCM_UNPACK (g_scm_eqv_p))
 177     return scm_call_generic_2 (g_scm_eqv_p, x, y);
 178   else
 179     return SCM_BOOL_F;
 180 }
 181 #undef FUNC_NAME
 182
 183
 184 SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
 185                          (SCM x, SCM y),
 186             "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
 187             "their contents or value are equal.\n"
 188             "\n"
 189             "For a pair, string, vector or array, @code{equal?} compares the\n"
 190             "contents, and does so using using the same @code{equal?}\n"
 191             "recursively, so a deep structure can be traversed.\n"
 192             "\n"
 193             "@example\n"
 194             "(equal? (list 1 2 3) (list 1 2 3))   @result{} #t\n"
 195             "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
 196             "@end example\n"
 197             "\n"
 198             "For other objects, @code{equal?} compares as per @code{eqv?},\n"
 199             "which means characters and numbers are compared by type and\n"
 200             "value (and like @code{eqv?}, exact and inexact numbers are not\n"
 201             "@code{equal?}, even if their value is the same).\n"
 202             "\n"
 203             "@example\n"
 204             "(equal? 3 (+ 1 2)) @result{} #t\n"
 205             "(equal? 1 1.0)     @result{} #f\n"
 206             "@end example\n"
 207             "\n"
 208             "Hash tables are currently only compared as per @code{eq?}, so\n"
 209             "two different tables are not @code{equal?}, even if their\n"
 210             "contents are the same.\n"
 211             "\n"
 212             "@code{equal?} does not support circular data structures, it may\n"
 213             "go into an infinite loop if asked to compare two circular lists\n"
 214             "or similar.\n"
 215             "\n"
 216             "New application-defined object types (Smobs) have an\n"
 217             "@code{equalp} handler which is called by @code{equal?}.  This\n"
 218             "lets an application traverse the contents or control what is\n"
 219             "considered @code{equal?} for two such objects.  If there's no\n"
 220             "handler, the default is to just compare as per @code{eq?}.")
 221 #define FUNC_NAME s_scm_equal_p
 222 {
 223   SCM_CHECK_STACK;
 224  tailrecurse:
 225   SCM_TICK;
 226   if (scm_is_eq (x, y))
 227     return SCM_BOOL_T;
 228   if (SCM_IMP (x))
 229     return SCM_BOOL_F;
 230   if (SCM_IMP (y))
 231     return SCM_BOOL_F;
 232   if (scm_is_pair (x) && scm_is_pair (y))
 233     {
 234       if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
 235         return SCM_BOOL_F;
 236       x = SCM_CDR(x);
 237       y = SCM_CDR(y);
 238       goto tailrecurse;
 239     }
 240   if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string)
 241     return scm_string_equal_p (x, y);
 242   if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
 243     {
 244       int i = SCM_SMOBNUM (x);
 245       if (!(i < scm_numsmob))
 246         return SCM_BOOL_F;
 247       if (scm_smobs[i].equalp)
 248         return (scm_smobs[i].equalp) (x, y);
 249       else
 250         goto generic_equal;
 251     }
 252   /* This ensures that types and scm_length are the same.  */
 253   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
 254     {
 255       /* treat mixes of real and complex types specially */
 256       if (SCM_INEXACTP (x) && SCM_INEXACTP (y))
 257         {
 258           if (SCM_REALP (x))
 259             return scm_from_bool (SCM_COMPLEXP (y)
 260                              && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)
 261                              && SCM_COMPLEX_IMAG (y) == 0.0);
 262           else
 263             return scm_from_bool (SCM_REALP (y)
 264                              && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
 265                              && SCM_COMPLEX_IMAG (x) == 0.0);
 266         }
 267
 268       /* Vectors can be equal to one-dimensional arrays.
 269        */
 270       if (SCM_I_ARRAYP (x) || SCM_I_ARRAYP (y))
 271         return scm_array_equal_p (x, y);
 272
 273       return SCM_BOOL_F;
 274     }
 275   switch (SCM_TYP7 (x))
 276     {
 277     default:
 278       break;
 279     case scm_tc7_number:
 280       switch SCM_TYP16 (x)
 281         {
 282         case scm_tc16_big:
 283           return scm_bigequal (x, y);
 284         case scm_tc16_real:
 285           return scm_real_equalp (x, y);
 286         case scm_tc16_complex:
 287           return scm_complex_equalp (x, y);
 288         case scm_tc16_fraction:
 289           return scm_i_fraction_equalp (x, y);
 290         }
 291     case scm_tc7_vector:
 292     case scm_tc7_wvect:
 293       return scm_i_vector_equal_p (x, y);
 294     }
 295
 296   /* Check equality between structs of equal type (see cell-type test above)
 297      that are not GOOPS instances.  GOOPS instances are treated via the
 298      generic function.  */
 299   if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
 300     return scm_i_struct_equalp (x, y);
 301
 302  generic_equal:
 303   if (SCM_UNPACK (g_scm_equal_p))
 304     return scm_call_generic_2 (g_scm_equal_p, x, y);
 305   else
 306     return SCM_BOOL_F;
 307 }
 308 #undef FUNC_NAME
 309
 310
 311 \f
 312
 313
 314
 315 void
 316 scm_init_eq ()
 317 {
 318 #include "libguile/eq.x"
 319 }
 320
 321
 322 /*
 323   Local Variables:
 324   c-file-style: "gnu"
 325   End:
 326 */