Commit | Line | Data |
---|---|---|
2e6e1933 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
0f2d19dd | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
0f2d19dd | 12 | * |
73be1d9e MV |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
0f2d19dd | 19 | \f |
dbb605f5 | 20 | #ifdef HAVE_CONFIG_H |
1f4d02c2 RB |
21 | # include <config.h> |
22 | #endif | |
9540b68f | 23 | |
2e6e1933 MW |
24 | #include <math.h> |
25 | ||
a0599745 | 26 | #include "libguile/_scm.h" |
5d1b3b2d | 27 | #include "libguile/array-map.h" |
a0599745 MD |
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" | |
2fa901a5 | 33 | #include "libguile/arrays.h" |
a0599745 | 34 | #include "libguile/vectors.h" |
c99de5aa | 35 | #include "libguile/hashtab.h" |
807e5a66 | 36 | #include "libguile/bytevectors.h" |
0f2d19dd | 37 | |
d15ad007 LC |
38 | #include "libguile/struct.h" |
39 | #include "libguile/goops.h" | |
d15ad007 | 40 | |
a0599745 MD |
41 | #include "libguile/validate.h" |
42 | #include "libguile/eq.h" | |
22fc179a HWN |
43 | |
44 | #include "libguile/private-options.h" | |
45 | ||
0f2d19dd | 46 | \f |
9540b68f GH |
47 | |
48 | #ifdef HAVE_STRING_H | |
49 | #include <string.h> | |
50 | #endif | |
51 | \f | |
52 | ||
f1d19308 | 53 | static SCM scm_i_eq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
54 | SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1, |
55 | (SCM x, SCM y, SCM rest), | |
602d32dd KR |
56 | "Return @code{#t} if @var{x} and @var{y} are the same object,\n" |
57 | "except for numbers and characters. For example,\n" | |
58 | "\n" | |
59 | "@example\n" | |
60 | "(define x (vector 1 2 3))\n" | |
61 | "(define y (vector 1 2 3))\n" | |
62 | "\n" | |
63 | "(eq? x x) @result{} #t\n" | |
64 | "(eq? x y) @result{} #f\n" | |
65 | "@end example\n" | |
66 | "\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" | |
70 | "variable,\n" | |
71 | "\n" | |
72 | "@example\n" | |
73 | "(let ((n (+ 2 3)))\n" | |
74 | " (eq? n n)) @result{} *unspecified*\n" | |
75 | "@end example\n" | |
76 | "\n" | |
77 | "Generally @code{eqv?} should be used when comparing numbers or\n" | |
78 | "characters. @code{=} or @code{char=?} can be used too.\n" | |
79 | "\n" | |
4450a227 KR |
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" | |
602d32dd KR |
85 | "\n" |
86 | "@example\n" | |
87 | "(define x (cdr '(123)))\n" | |
88 | "(define y (cdr '(456)))\n" | |
89 | "(eq? x y) @result{} #t\n" | |
90 | "\n" | |
4450a227 | 91 | "(define x (string->symbol \"foo\"))\n" |
602d32dd KR |
92 | "(eq? x 'foo) @result{} #t\n" |
93 | "@end example") | |
8a1f4f98 | 94 | #define FUNC_NAME s_scm_i_eq_p |
0f2d19dd | 95 | { |
8a1f4f98 AW |
96 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) |
97 | return SCM_BOOL_T; | |
98 | while (scm_is_pair (rest)) | |
99 | { | |
100 | if (!scm_is_eq (x, y)) | |
101 | return SCM_BOOL_F; | |
102 | x = y; | |
103 | y = scm_car (rest); | |
104 | rest = scm_cdr (rest); | |
105 | } | |
bc36d050 | 106 | return scm_from_bool (scm_is_eq (x, y)); |
0f2d19dd | 107 | } |
1bbd0b84 | 108 | #undef FUNC_NAME |
0f2d19dd | 109 | |
8a1f4f98 AW |
110 | SCM |
111 | scm_eq_p (SCM x, SCM y) | |
112 | { | |
113 | return scm_from_bool (scm_is_eq (x, y)); | |
114 | } | |
115 | ||
96d00047 MV |
116 | /* We compare doubles in a special way for 'eqv?' to be able to |
117 | distinguish plus and minus zero and to identify NaNs. | |
118 | */ | |
119 | ||
120 | static int | |
121 | real_eqv (double x, double y) | |
122 | { | |
2e6e1933 MW |
123 | return !memcmp (&x, &y, sizeof(double)) |
124 | || (SCM_UNLIKELY (isnan (x)) && SCM_UNLIKELY (isnan (y))); | |
125 | } | |
126 | ||
127 | SCM | |
128 | scm_real_equalp (SCM x, SCM y) | |
129 | { | |
130 | return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), | |
131 | SCM_REAL_VALUE (y))); | |
132 | } | |
133 | ||
134 | SCM | |
135 | scm_bigequal (SCM x, SCM y) | |
136 | { | |
137 | return scm_from_bool (scm_i_bigcmp (x, y) == 0); | |
138 | } | |
139 | ||
140 | SCM | |
141 | scm_complex_equalp (SCM x, SCM y) | |
142 | { | |
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))); | |
147 | } | |
148 | ||
149 | SCM | |
150 | scm_i_fraction_equalp (SCM x, SCM y) | |
151 | { | |
152 | return scm_from_bool | |
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)))); | |
96d00047 | 157 | } |
0f2d19dd | 158 | |
f1d19308 | 159 | static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest); |
f92e85f7 | 160 | #include <stdio.h> |
8a1f4f98 AW |
161 | SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1, |
162 | (SCM x, SCM y, SCM rest), | |
602d32dd KR |
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" | |
165 | "\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" | |
168 | "same object.\n" | |
169 | "\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" | |
173 | "same).\n" | |
174 | "\n" | |
175 | "@example\n" | |
176 | "(eqv? 3 (+ 1 2)) @result{} #t\n" | |
177 | "(eqv? 1 1.0) @result{} #f\n" | |
178 | "@end example") | |
8a1f4f98 AW |
179 | #define FUNC_NAME s_scm_i_eqv_p |
180 | { | |
181 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
182 | return SCM_BOOL_T; | |
183 | while (!scm_is_null (rest)) | |
184 | { | |
185 | if (!scm_is_true (scm_eqv_p (x, y))) | |
186 | return SCM_BOOL_F; | |
187 | x = y; | |
188 | y = scm_car (rest); | |
189 | rest = scm_cdr (rest); | |
190 | } | |
191 | return scm_eqv_p (x, y); | |
192 | } | |
193 | #undef FUNC_NAME | |
194 | ||
195 | SCM scm_eqv_p (SCM x, SCM y) | |
196 | #define FUNC_NAME s_scm_i_eqv_p | |
0f2d19dd | 197 | { |
bc36d050 | 198 | if (scm_is_eq (x, y)) |
950cc72b MD |
199 | return SCM_BOOL_T; |
200 | if (SCM_IMP (x)) | |
201 | return SCM_BOOL_F; | |
202 | if (SCM_IMP (y)) | |
203 | return SCM_BOOL_F; | |
f92e85f7 | 204 | |
2e6e1933 | 205 | /* this ensures that types and scm_length are the same. */ |
fbd485ba | 206 | if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
2e6e1933 MW |
207 | return SCM_BOOL_F; |
208 | switch (SCM_TYP7 (x)) | |
950cc72b | 209 | { |
2e6e1933 MW |
210 | default: |
211 | break; | |
212 | case scm_tc7_number: | |
213 | switch SCM_TYP16 (x) | |
214 | { | |
215 | case scm_tc16_big: | |
216 | return scm_bigequal (x, y); | |
217 | case scm_tc16_real: | |
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); | |
223 | } | |
950cc72b | 224 | } |
ab455d1f | 225 | return SCM_BOOL_F; |
0f2d19dd | 226 | } |
1bbd0b84 | 227 | #undef FUNC_NAME |
0f2d19dd JB |
228 | |
229 | ||
f1d19308 | 230 | static SCM scm_i_equal_p (SCM, SCM, SCM); |
8a1f4f98 AW |
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" | |
235 | "\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" | |
239 | "\n" | |
240 | "@example\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" | |
243 | "@end example\n" | |
244 | "\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" | |
249 | "\n" | |
250 | "@example\n" | |
251 | "(equal? 3 (+ 1 2)) @result{} #t\n" | |
252 | "(equal? 1 1.0) @result{} #f\n" | |
253 | "@end example\n" | |
254 | "\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" | |
258 | "\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" | |
261 | "or similar.\n" | |
262 | "\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 | |
269 | { | |
270 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
271 | return SCM_BOOL_T; | |
272 | while (!scm_is_null (rest)) | |
273 | { | |
274 | if (!scm_is_true (scm_equal_p (x, y))) | |
275 | return SCM_BOOL_F; | |
276 | x = y; | |
277 | y = scm_car (rest); | |
278 | rest = SCM_CDR (rest); | |
279 | } | |
280 | return scm_equal_p (x, y); | |
281 | } | |
282 | #undef FUNC_NAME | |
283 | ||
284 | SCM | |
285 | scm_equal_p (SCM x, SCM y) | |
286 | #define FUNC_NAME s_scm_i_equal_p | |
0f2d19dd JB |
287 | { |
288 | SCM_CHECK_STACK; | |
950cc72b MD |
289 | tailrecurse: |
290 | SCM_TICK; | |
bc36d050 | 291 | if (scm_is_eq (x, y)) |
950cc72b MD |
292 | return SCM_BOOL_T; |
293 | if (SCM_IMP (x)) | |
294 | return SCM_BOOL_F; | |
295 | if (SCM_IMP (y)) | |
296 | return SCM_BOOL_F; | |
d2e53ed6 | 297 | if (scm_is_pair (x) && scm_is_pair (y)) |
950cc72b | 298 | { |
7888309b | 299 | if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y)))) |
950cc72b MD |
300 | return SCM_BOOL_F; |
301 | x = SCM_CDR(x); | |
302 | y = SCM_CDR(y); | |
303 | goto tailrecurse; | |
304 | } | |
789d2fc8 MV |
305 | if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y)) |
306 | { | |
307 | int i = SCM_SMOBNUM (x); | |
308 | if (!(i < scm_numsmob)) | |
309 | return SCM_BOOL_F; | |
310 | if (scm_smobs[i].equalp) | |
311 | return (scm_smobs[i].equalp) (x, y); | |
312 | else | |
313 | goto generic_equal; | |
314 | } | |
cb2d8076 | 315 | |
950cc72b | 316 | /* This ensures that types and scm_length are the same. */ |
fbd485ba | 317 | if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
950cc72b | 318 | { |
af4f8612 MV |
319 | /* Vectors can be equal to one-dimensional arrays. |
320 | */ | |
a587d6a9 | 321 | if (scm_is_array (x) && scm_is_array (y)) |
af4f8612 MV |
322 | return scm_array_equal_p (x, y); |
323 | ||
950cc72b MD |
324 | return SCM_BOOL_F; |
325 | } | |
326 | switch (SCM_TYP7 (x)) | |
327 | { | |
328 | default: | |
f135fc3e MW |
329 | /* Check equality between structs of equal type (see cell-type test above). */ |
330 | if (SCM_STRUCTP (x)) | |
331 | { | |
332 | if (SCM_INSTANCEP (x)) | |
333 | goto generic_equal; | |
334 | else | |
335 | return scm_i_struct_equalp (x, y); | |
336 | } | |
a48d60b1 | 337 | break; |
534c55a9 DH |
338 | case scm_tc7_number: |
339 | switch SCM_TYP16 (x) | |
340 | { | |
341 | case scm_tc16_big: | |
342 | return scm_bigequal (x, y); | |
343 | case scm_tc16_real: | |
344 | return scm_real_equalp (x, y); | |
345 | case scm_tc16_complex: | |
346 | return scm_complex_equalp (x, y); | |
f92e85f7 MV |
347 | case scm_tc16_fraction: |
348 | return scm_i_fraction_equalp (x, y); | |
b2637c98 AW |
349 | default: |
350 | /* assert not reached? */ | |
351 | return SCM_BOOL_F; | |
534c55a9 | 352 | } |
b2637c98 AW |
353 | case scm_tc7_pointer: |
354 | return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y)); | |
355 | case scm_tc7_string: | |
356 | return scm_string_equal_p (x, y); | |
357 | case scm_tc7_bytevector: | |
358 | return scm_bytevector_eq_p (x, y); | |
359 | case scm_tc7_array: | |
360 | return scm_array_equal_p (x, y); | |
ff1feca9 AW |
361 | case scm_tc7_bitvector: |
362 | return scm_i_bitvector_equal_p (x, y); | |
950cc72b MD |
363 | case scm_tc7_vector: |
364 | case scm_tc7_wvect: | |
354116f7 | 365 | return scm_i_vector_equal_p (x, y); |
950cc72b | 366 | } |
d15ad007 | 367 | |
ab455d1f AW |
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. */ | |
371 | return SCM_BOOL_F; | |
372 | ||
789d2fc8 | 373 | generic_equal: |
8a1f4f98 | 374 | if (SCM_UNPACK (g_scm_i_equal_p)) |
fa075d40 | 375 | return scm_call_2 (g_scm_i_equal_p, x, y); |
a48d60b1 MD |
376 | else |
377 | return SCM_BOOL_F; | |
0f2d19dd | 378 | } |
1bbd0b84 | 379 | #undef FUNC_NAME |
0f2d19dd JB |
380 | |
381 | ||
382 | \f | |
383 | ||
384 | ||
1cc91f1b | 385 | |
0f2d19dd JB |
386 | void |
387 | scm_init_eq () | |
0f2d19dd | 388 | { |
a0599745 | 389 | #include "libguile/eq.x" |
0f2d19dd JB |
390 | } |
391 | ||
89e00824 ML |
392 | |
393 | /* | |
394 | Local Variables: | |
395 | c-file-style: "gnu" | |
396 | End: | |
397 | */ |