1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
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.
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.
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
26 #include "libguile/_scm.h"
27 #include "libguile/array-map.h"
28 #include "libguile/stackchk.h"
29 #include "libguile/strorder.h"
30 #include "libguile/async.h"
31 #include "libguile/root.h"
32 #include "libguile/smob.h"
33 #include "libguile/arrays.h"
34 #include "libguile/vectors.h"
35 #include "libguile/hashtab.h"
36 #include "libguile/bytevectors.h"
38 #include "libguile/struct.h"
39 #include "libguile/goops.h"
41 #include "libguile/validate.h"
42 #include "libguile/eq.h"
44 #include "libguile/private-options.h"
53 static SCM
scm_i_eq_p (SCM x
, SCM y
, SCM rest
);
54 SCM_DEFINE (scm_i_eq_p
, "eq?", 0, 2, 1,
55 (SCM x
, SCM y
, SCM rest
),
56 "Return @code{#t} if @var{x} and @var{y} are the same object,\n"
57 "except for numbers and characters. For example,\n"
60 "(define x (vector 1 2 3))\n"
61 "(define y (vector 1 2 3))\n"
63 "(eq? x x) @result{} #t\n"
64 "(eq? x y) @result{} #f\n"
67 "Numbers and characters are not equal to any other object, but\n"
68 "the problem is they're not necessarily @code{eq?} to themselves\n"
69 "either. This is even so when the number comes directly from a\n"
73 "(let ((n (+ 2 3)))\n"
74 " (eq? n n)) @result{} *unspecified*\n"
77 "Generally @code{eqv?} should be used when comparing numbers or\n"
78 "characters. @code{=} or @code{char=?} can be used too.\n"
80 "It's worth noting that end-of-list @code{()}, @code{#t},\n"
81 "@code{#f}, a symbol of a given name, and a keyword of a given\n"
82 "name, are unique objects. There's just one of each, so for\n"
83 "instance no matter how @code{()} arises in a program, it's the\n"
84 "same object and can be compared with @code{eq?},\n"
87 "(define x (cdr '(123)))\n"
88 "(define y (cdr '(456)))\n"
89 "(eq? x y) @result{} #t\n"
91 "(define x (string->symbol \"foo\"))\n"
92 "(eq? x 'foo) @result{} #t\n"
94 #define FUNC_NAME s_scm_i_eq_p
96 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
98 while (scm_is_pair (rest
))
100 if (!scm_is_eq (x
, y
))
104 rest
= scm_cdr (rest
);
106 return scm_from_bool (scm_is_eq (x
, y
));
111 scm_eq_p (SCM x
, SCM y
)
113 return scm_from_bool (scm_is_eq (x
, y
));
116 /* We compare doubles in a special way for 'eqv?' to be able to
117 distinguish plus and minus zero and to identify NaNs.
121 real_eqv (double x
, double y
)
123 return !memcmp (&x
, &y
, sizeof(double))
124 || (SCM_UNLIKELY (isnan (x
)) && SCM_UNLIKELY (isnan (y
)));
128 scm_real_equalp (SCM x
, SCM y
)
130 return scm_from_bool (real_eqv (SCM_REAL_VALUE (x
),
131 SCM_REAL_VALUE (y
)));
135 scm_bigequal (SCM x
, SCM y
)
137 return scm_from_bool (scm_i_bigcmp (x
, y
) == 0);
141 scm_complex_equalp (SCM x
, SCM y
)
143 return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x
),
144 SCM_COMPLEX_REAL (y
))
145 && real_eqv (SCM_COMPLEX_IMAG (x
),
146 SCM_COMPLEX_IMAG (y
)));
150 scm_i_fraction_equalp (SCM x
, SCM y
)
153 (scm_is_true (scm_equal_p (SCM_FRACTION_NUMERATOR (x
),
154 SCM_FRACTION_NUMERATOR (y
)))
155 && scm_is_true (scm_equal_p (SCM_FRACTION_DENOMINATOR (x
),
156 SCM_FRACTION_DENOMINATOR (y
))));
159 static SCM
scm_i_eqv_p (SCM x
, SCM y
, SCM rest
);
161 SCM_DEFINE (scm_i_eqv_p
, "eqv?", 0, 2, 1,
162 (SCM x
, SCM y
, SCM rest
),
163 "Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
164 "for characters and numbers the same value.\n"
166 "On objects except characters and numbers, @code{eqv?} is the\n"
167 "same as @code{eq?}, it's true if @var{x} and @var{y} are the\n"
170 "If @var{x} and @var{y} are numbers or characters, @code{eqv?}\n"
171 "compares their type and value. An exact number is not\n"
172 "@code{eqv?} to an inexact number (even if their value is the\n"
176 "(eqv? 3 (+ 1 2)) @result{} #t\n"
177 "(eqv? 1 1.0) @result{} #f\n"
179 #define FUNC_NAME s_scm_i_eqv_p
181 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
183 while (!scm_is_null (rest
))
185 if (!scm_is_true (scm_eqv_p (x
, y
)))
189 rest
= scm_cdr (rest
);
191 return scm_eqv_p (x
, y
);
195 SCM
scm_eqv_p (SCM x
, SCM y
)
196 #define FUNC_NAME s_scm_i_eqv_p
198 if (scm_is_eq (x
, y
))
205 /* this ensures that types and scm_length are the same. */
206 if (SCM_CELL_TYPE (x
) != SCM_CELL_TYPE (y
))
208 switch (SCM_TYP7 (x
))
216 return scm_bigequal (x
, y
);
218 return scm_real_equalp (x
, y
);
219 case scm_tc16_complex
:
220 return scm_complex_equalp (x
, y
);
221 case scm_tc16_fraction
:
222 return scm_i_fraction_equalp (x
, y
);
230 static SCM
scm_i_equal_p (SCM
, SCM
, SCM
);
231 SCM_PRIMITIVE_GENERIC (scm_i_equal_p
, "equal?", 0, 2, 1,
232 (SCM x
, SCM y
, SCM rest
),
233 "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
234 "their contents or value are equal.\n"
236 "For a pair, string, vector or array, @code{equal?} compares the\n"
237 "contents, and does so using using the same @code{equal?}\n"
238 "recursively, so a deep structure can be traversed.\n"
241 "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n"
242 "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
245 "For other objects, @code{equal?} compares as per @code{eqv?},\n"
246 "which means characters and numbers are compared by type and\n"
247 "value (and like @code{eqv?}, exact and inexact numbers are not\n"
248 "@code{equal?}, even if their value is the same).\n"
251 "(equal? 3 (+ 1 2)) @result{} #t\n"
252 "(equal? 1 1.0) @result{} #f\n"
255 "Hash tables are currently only compared as per @code{eq?}, so\n"
256 "two different tables are not @code{equal?}, even if their\n"
257 "contents are the same.\n"
259 "@code{equal?} does not support circular data structures, it may\n"
260 "go into an infinite loop if asked to compare two circular lists\n"
263 "New application-defined object types (Smobs) have an\n"
264 "@code{equalp} handler which is called by @code{equal?}. This\n"
265 "lets an application traverse the contents or control what is\n"
266 "considered @code{equal?} for two such objects. If there's no\n"
267 "handler, the default is to just compare as per @code{eq?}.")
268 #define FUNC_NAME s_scm_i_equal_p
270 if (SCM_UNBNDP (x
) || SCM_UNBNDP (y
))
272 while (!scm_is_null (rest
))
274 if (!scm_is_true (scm_equal_p (x
, y
)))
278 rest
= SCM_CDR (rest
);
280 return scm_equal_p (x
, y
);
285 scm_equal_p (SCM x
, SCM y
)
286 #define FUNC_NAME s_scm_i_equal_p
291 if (scm_is_eq (x
, y
))
297 if (scm_is_pair (x
) && scm_is_pair (y
))
299 if (scm_is_false (scm_equal_p (SCM_CAR (x
), SCM_CAR (y
))))
305 if (SCM_TYP7 (x
) == scm_tc7_smob
&& SCM_TYP16 (x
) == SCM_TYP16 (y
))
307 int i
= SCM_SMOBNUM (x
);
308 if (!(i
< scm_numsmob
))
310 if (scm_smobs
[i
].equalp
)
311 return (scm_smobs
[i
].equalp
) (x
, y
);
316 /* This ensures that types and scm_length are the same. */
317 if (SCM_CELL_TYPE (x
) != SCM_CELL_TYPE (y
))
319 /* Vectors can be equal to one-dimensional arrays.
321 if (scm_is_array (x
) && scm_is_array (y
))
322 return scm_array_equal_p (x
, y
);
326 switch (SCM_TYP7 (x
))
329 /* Check equality between structs of equal type (see cell-type test above). */
332 if (SCM_INSTANCEP (x
))
335 return scm_i_struct_equalp (x
, y
);
342 return scm_bigequal (x
, y
);
344 return scm_real_equalp (x
, y
);
345 case scm_tc16_complex
:
346 return scm_complex_equalp (x
, y
);
347 case scm_tc16_fraction
:
348 return scm_i_fraction_equalp (x
, y
);
350 /* assert not reached? */
353 case scm_tc7_pointer
:
354 return scm_from_bool (SCM_POINTER_VALUE (x
) == SCM_POINTER_VALUE (y
));
356 return scm_string_equal_p (x
, y
);
357 case scm_tc7_bytevector
:
358 return scm_bytevector_eq_p (x
, y
);
360 return scm_array_equal_p (x
, y
);
361 case scm_tc7_bitvector
:
362 return scm_i_bitvector_equal_p (x
, y
);
365 return scm_i_vector_equal_p (x
, y
);
368 /* Otherwise just return false. Dispatching to the generic is the wrong thing
369 here, as we can hit this case for any two objects of the same type that we
370 think are distinct, like different symbols. */
374 if (SCM_UNPACK (g_scm_i_equal_p
))
375 return scm_call_generic_2 (g_scm_i_equal_p
, x
, y
);
389 #include "libguile/eq.x"