guile18/libguile/eq.c

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