| 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 | |
| 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 | */ |