libguile/eq.c

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