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