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