Commit | Line | Data |
---|---|---|
5d1b3b2d | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009 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 | |
a0599745 | 24 | #include "libguile/_scm.h" |
5d1b3b2d | 25 | #include "libguile/array-map.h" |
a0599745 MD |
26 | #include "libguile/stackchk.h" |
27 | #include "libguile/strorder.h" | |
28 | #include "libguile/async.h" | |
29 | #include "libguile/root.h" | |
30 | #include "libguile/smob.h" | |
2fa901a5 | 31 | #include "libguile/arrays.h" |
a0599745 | 32 | #include "libguile/vectors.h" |
c99de5aa | 33 | #include "libguile/hashtab.h" |
807e5a66 | 34 | #include "libguile/bytevectors.h" |
0f2d19dd | 35 | |
d15ad007 LC |
36 | #include "libguile/struct.h" |
37 | #include "libguile/goops.h" | |
d15ad007 | 38 | |
a0599745 MD |
39 | #include "libguile/validate.h" |
40 | #include "libguile/eq.h" | |
22fc179a HWN |
41 | |
42 | #include "libguile/private-options.h" | |
43 | ||
0f2d19dd | 44 | \f |
9540b68f GH |
45 | |
46 | #ifdef HAVE_STRING_H | |
47 | #include <string.h> | |
48 | #endif | |
49 | \f | |
50 | ||
8a1f4f98 AW |
51 | SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1, |
52 | (SCM x, SCM y, SCM rest), | |
602d32dd KR |
53 | "Return @code{#t} if @var{x} and @var{y} are the same object,\n" |
54 | "except for numbers and characters. For example,\n" | |
55 | "\n" | |
56 | "@example\n" | |
57 | "(define x (vector 1 2 3))\n" | |
58 | "(define y (vector 1 2 3))\n" | |
59 | "\n" | |
60 | "(eq? x x) @result{} #t\n" | |
61 | "(eq? x y) @result{} #f\n" | |
62 | "@end example\n" | |
63 | "\n" | |
64 | "Numbers and characters are not equal to any other object, but\n" | |
65 | "the problem is they're not necessarily @code{eq?} to themselves\n" | |
66 | "either. This is even so when the number comes directly from a\n" | |
67 | "variable,\n" | |
68 | "\n" | |
69 | "@example\n" | |
70 | "(let ((n (+ 2 3)))\n" | |
71 | " (eq? n n)) @result{} *unspecified*\n" | |
72 | "@end example\n" | |
73 | "\n" | |
74 | "Generally @code{eqv?} should be used when comparing numbers or\n" | |
75 | "characters. @code{=} or @code{char=?} can be used too.\n" | |
76 | "\n" | |
4450a227 KR |
77 | "It's worth noting that end-of-list @code{()}, @code{#t},\n" |
78 | "@code{#f}, a symbol of a given name, and a keyword of a given\n" | |
79 | "name, are unique objects. There's just one of each, so for\n" | |
80 | "instance no matter how @code{()} arises in a program, it's the\n" | |
81 | "same object and can be compared with @code{eq?},\n" | |
602d32dd KR |
82 | "\n" |
83 | "@example\n" | |
84 | "(define x (cdr '(123)))\n" | |
85 | "(define y (cdr '(456)))\n" | |
86 | "(eq? x y) @result{} #t\n" | |
87 | "\n" | |
4450a227 | 88 | "(define x (string->symbol \"foo\"))\n" |
602d32dd KR |
89 | "(eq? x 'foo) @result{} #t\n" |
90 | "@end example") | |
8a1f4f98 | 91 | #define FUNC_NAME s_scm_i_eq_p |
0f2d19dd | 92 | { |
8a1f4f98 AW |
93 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) |
94 | return SCM_BOOL_T; | |
95 | while (scm_is_pair (rest)) | |
96 | { | |
97 | if (!scm_is_eq (x, y)) | |
98 | return SCM_BOOL_F; | |
99 | x = y; | |
100 | y = scm_car (rest); | |
101 | rest = scm_cdr (rest); | |
102 | } | |
bc36d050 | 103 | return scm_from_bool (scm_is_eq (x, y)); |
0f2d19dd | 104 | } |
1bbd0b84 | 105 | #undef FUNC_NAME |
0f2d19dd | 106 | |
8a1f4f98 AW |
107 | SCM |
108 | scm_eq_p (SCM x, SCM y) | |
109 | { | |
110 | return scm_from_bool (scm_is_eq (x, y)); | |
111 | } | |
112 | ||
96d00047 MV |
113 | /* We compare doubles in a special way for 'eqv?' to be able to |
114 | distinguish plus and minus zero and to identify NaNs. | |
115 | */ | |
116 | ||
117 | static int | |
118 | real_eqv (double x, double y) | |
119 | { | |
0e12d408 | 120 | return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y); |
96d00047 | 121 | } |
0f2d19dd | 122 | |
f92e85f7 | 123 | #include <stdio.h> |
8a1f4f98 AW |
124 | SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1, |
125 | (SCM x, SCM y, SCM rest), | |
602d32dd KR |
126 | "Return @code{#t} if @var{x} and @var{y} are the same object, or\n" |
127 | "for characters and numbers the same value.\n" | |
128 | "\n" | |
129 | "On objects except characters and numbers, @code{eqv?} is the\n" | |
130 | "same as @code{eq?}, it's true if @var{x} and @var{y} are the\n" | |
131 | "same object.\n" | |
132 | "\n" | |
133 | "If @var{x} and @var{y} are numbers or characters, @code{eqv?}\n" | |
134 | "compares their type and value. An exact number is not\n" | |
135 | "@code{eqv?} to an inexact number (even if their value is the\n" | |
136 | "same).\n" | |
137 | "\n" | |
138 | "@example\n" | |
139 | "(eqv? 3 (+ 1 2)) @result{} #t\n" | |
140 | "(eqv? 1 1.0) @result{} #f\n" | |
141 | "@end example") | |
8a1f4f98 AW |
142 | #define FUNC_NAME s_scm_i_eqv_p |
143 | { | |
144 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
145 | return SCM_BOOL_T; | |
146 | while (!scm_is_null (rest)) | |
147 | { | |
148 | if (!scm_is_true (scm_eqv_p (x, y))) | |
149 | return SCM_BOOL_F; | |
150 | x = y; | |
151 | y = scm_car (rest); | |
152 | rest = scm_cdr (rest); | |
153 | } | |
154 | return scm_eqv_p (x, y); | |
155 | } | |
156 | #undef FUNC_NAME | |
157 | ||
158 | SCM scm_eqv_p (SCM x, SCM y) | |
159 | #define FUNC_NAME s_scm_i_eqv_p | |
0f2d19dd | 160 | { |
bc36d050 | 161 | if (scm_is_eq (x, y)) |
950cc72b MD |
162 | return SCM_BOOL_T; |
163 | if (SCM_IMP (x)) | |
164 | return SCM_BOOL_F; | |
165 | if (SCM_IMP (y)) | |
166 | return SCM_BOOL_F; | |
0f2d19dd | 167 | /* this ensures that types and scm_length are the same. */ |
f92e85f7 | 168 | |
fbd485ba | 169 | if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
950cc72b | 170 | { |
f92e85f7 MV |
171 | /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), |
172 | but this checks the entire type word, so fractions may be accidentally | |
173 | flagged here as unequal. Perhaps I should use the 4th double_cell word? | |
174 | */ | |
175 | ||
950cc72b | 176 | /* treat mixes of real and complex types specially */ |
6b412e91 | 177 | if (SCM_INEXACTP (x)) |
950cc72b | 178 | { |
6b412e91 | 179 | if (SCM_REALP (x)) |
7888309b | 180 | return scm_from_bool (SCM_COMPLEXP (y) |
96d00047 MV |
181 | && real_eqv (SCM_REAL_VALUE (x), |
182 | SCM_COMPLEX_REAL (y)) | |
6b412e91 | 183 | && SCM_COMPLEX_IMAG (y) == 0.0); |
950cc72b | 184 | else |
7888309b | 185 | return scm_from_bool (SCM_REALP (y) |
96d00047 MV |
186 | && real_eqv (SCM_COMPLEX_REAL (x), |
187 | SCM_REAL_VALUE (y)) | |
950cc72b MD |
188 | && SCM_COMPLEX_IMAG (x) == 0.0); |
189 | } | |
f92e85f7 MV |
190 | |
191 | if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) | |
192 | return scm_i_fraction_equalp (x, y); | |
950cc72b MD |
193 | return SCM_BOOL_F; |
194 | } | |
195 | if (SCM_NUMP (x)) | |
196 | { | |
eb42e2f0 | 197 | if (SCM_BIGP (x)) { |
7888309b | 198 | return scm_from_bool (scm_i_bigcmp (x, y) == 0); |
6b412e91 | 199 | } else if (SCM_REALP (x)) { |
7888309b | 200 | return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); |
f92e85f7 MV |
201 | } else if (SCM_FRACTIONP (x)) { |
202 | return scm_i_fraction_equalp (x, y); | |
eb42e2f0 | 203 | } else { /* complex */ |
7888309b | 204 | return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x), |
96d00047 MV |
205 | SCM_COMPLEX_REAL (y)) |
206 | && real_eqv (SCM_COMPLEX_IMAG (x), | |
207 | SCM_COMPLEX_IMAG (y))); | |
eb42e2f0 | 208 | } |
950cc72b | 209 | } |
ab455d1f | 210 | return SCM_BOOL_F; |
0f2d19dd | 211 | } |
1bbd0b84 | 212 | #undef FUNC_NAME |
0f2d19dd JB |
213 | |
214 | ||
8a1f4f98 AW |
215 | SCM scm_i_equal_p (SCM, SCM, SCM); |
216 | SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1, | |
217 | (SCM x, SCM y, SCM rest), | |
218 | "Return @code{#t} if @var{x} and @var{y} are the same type, and\n" | |
219 | "their contents or value are equal.\n" | |
220 | "\n" | |
221 | "For a pair, string, vector or array, @code{equal?} compares the\n" | |
222 | "contents, and does so using using the same @code{equal?}\n" | |
223 | "recursively, so a deep structure can be traversed.\n" | |
224 | "\n" | |
225 | "@example\n" | |
226 | "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n" | |
227 | "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n" | |
228 | "@end example\n" | |
229 | "\n" | |
230 | "For other objects, @code{equal?} compares as per @code{eqv?},\n" | |
231 | "which means characters and numbers are compared by type and\n" | |
232 | "value (and like @code{eqv?}, exact and inexact numbers are not\n" | |
233 | "@code{equal?}, even if their value is the same).\n" | |
234 | "\n" | |
235 | "@example\n" | |
236 | "(equal? 3 (+ 1 2)) @result{} #t\n" | |
237 | "(equal? 1 1.0) @result{} #f\n" | |
238 | "@end example\n" | |
239 | "\n" | |
240 | "Hash tables are currently only compared as per @code{eq?}, so\n" | |
241 | "two different tables are not @code{equal?}, even if their\n" | |
242 | "contents are the same.\n" | |
243 | "\n" | |
244 | "@code{equal?} does not support circular data structures, it may\n" | |
245 | "go into an infinite loop if asked to compare two circular lists\n" | |
246 | "or similar.\n" | |
247 | "\n" | |
248 | "New application-defined object types (Smobs) have an\n" | |
249 | "@code{equalp} handler which is called by @code{equal?}. This\n" | |
250 | "lets an application traverse the contents or control what is\n" | |
251 | "considered @code{equal?} for two such objects. If there's no\n" | |
252 | "handler, the default is to just compare as per @code{eq?}.") | |
253 | #define FUNC_NAME s_scm_i_equal_p | |
254 | { | |
255 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
256 | return SCM_BOOL_T; | |
257 | while (!scm_is_null (rest)) | |
258 | { | |
259 | if (!scm_is_true (scm_equal_p (x, y))) | |
260 | return SCM_BOOL_F; | |
261 | x = y; | |
262 | y = scm_car (rest); | |
263 | rest = SCM_CDR (rest); | |
264 | } | |
265 | return scm_equal_p (x, y); | |
266 | } | |
267 | #undef FUNC_NAME | |
268 | ||
269 | SCM | |
270 | scm_equal_p (SCM x, SCM y) | |
271 | #define FUNC_NAME s_scm_i_equal_p | |
0f2d19dd JB |
272 | { |
273 | SCM_CHECK_STACK; | |
950cc72b MD |
274 | tailrecurse: |
275 | SCM_TICK; | |
bc36d050 | 276 | if (scm_is_eq (x, y)) |
950cc72b MD |
277 | return SCM_BOOL_T; |
278 | if (SCM_IMP (x)) | |
279 | return SCM_BOOL_F; | |
280 | if (SCM_IMP (y)) | |
281 | return SCM_BOOL_F; | |
d2e53ed6 | 282 | if (scm_is_pair (x) && scm_is_pair (y)) |
950cc72b | 283 | { |
7888309b | 284 | if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y)))) |
950cc72b MD |
285 | return SCM_BOOL_F; |
286 | x = SCM_CDR(x); | |
287 | y = SCM_CDR(y); | |
288 | goto tailrecurse; | |
289 | } | |
baa84a20 | 290 | if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string) |
950cc72b | 291 | return scm_string_equal_p (x, y); |
807e5a66 LC |
292 | if (SCM_TYP7 (x) == scm_tc7_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector) |
293 | return scm_bytevector_eq_p (x, y); | |
789d2fc8 MV |
294 | if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y)) |
295 | { | |
296 | int i = SCM_SMOBNUM (x); | |
297 | if (!(i < scm_numsmob)) | |
298 | return SCM_BOOL_F; | |
299 | if (scm_smobs[i].equalp) | |
300 | return (scm_smobs[i].equalp) (x, y); | |
301 | else | |
302 | goto generic_equal; | |
303 | } | |
950cc72b | 304 | /* This ensures that types and scm_length are the same. */ |
fbd485ba | 305 | if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
950cc72b MD |
306 | { |
307 | /* treat mixes of real and complex types specially */ | |
f92e85f7 | 308 | if (SCM_INEXACTP (x) && SCM_INEXACTP (y)) |
950cc72b | 309 | { |
6b412e91 | 310 | if (SCM_REALP (x)) |
7888309b | 311 | return scm_from_bool (SCM_COMPLEXP (y) |
950cc72b | 312 | && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y) |
6b412e91 | 313 | && SCM_COMPLEX_IMAG (y) == 0.0); |
950cc72b | 314 | else |
7888309b | 315 | return scm_from_bool (SCM_REALP (y) |
950cc72b MD |
316 | && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) |
317 | && SCM_COMPLEX_IMAG (x) == 0.0); | |
0f2d19dd | 318 | } |
f92e85f7 | 319 | |
af4f8612 MV |
320 | /* Vectors can be equal to one-dimensional arrays. |
321 | */ | |
322 | if (SCM_I_ARRAYP (x) || SCM_I_ARRAYP (y)) | |
323 | return scm_array_equal_p (x, y); | |
324 | ||
950cc72b MD |
325 | return SCM_BOOL_F; |
326 | } | |
327 | switch (SCM_TYP7 (x)) | |
328 | { | |
329 | default: | |
a48d60b1 | 330 | break; |
534c55a9 DH |
331 | case scm_tc7_number: |
332 | switch SCM_TYP16 (x) | |
333 | { | |
334 | case scm_tc16_big: | |
335 | return scm_bigequal (x, y); | |
336 | case scm_tc16_real: | |
337 | return scm_real_equalp (x, y); | |
338 | case scm_tc16_complex: | |
339 | return scm_complex_equalp (x, y); | |
f92e85f7 MV |
340 | case scm_tc16_fraction: |
341 | return scm_i_fraction_equalp (x, y); | |
534c55a9 | 342 | } |
950cc72b MD |
343 | case scm_tc7_vector: |
344 | case scm_tc7_wvect: | |
354116f7 | 345 | return scm_i_vector_equal_p (x, y); |
950cc72b | 346 | } |
ab455d1f AW |
347 | /* Check equality between structs of equal type (see cell-type test above). */ |
348 | if (SCM_STRUCTP (x)) | |
349 | { | |
350 | if (SCM_INSTANCEP (x)) | |
351 | goto generic_equal; | |
352 | else | |
353 | return scm_i_struct_equalp (x, y); | |
354 | } | |
d15ad007 | 355 | |
ab455d1f AW |
356 | /* Otherwise just return false. Dispatching to the generic is the wrong thing |
357 | here, as we can hit this case for any two objects of the same type that we | |
358 | think are distinct, like different symbols. */ | |
359 | return SCM_BOOL_F; | |
360 | ||
789d2fc8 | 361 | generic_equal: |
8a1f4f98 AW |
362 | if (SCM_UNPACK (g_scm_i_equal_p)) |
363 | return scm_call_generic_2 (g_scm_i_equal_p, x, y); | |
a48d60b1 MD |
364 | else |
365 | return SCM_BOOL_F; | |
0f2d19dd | 366 | } |
1bbd0b84 | 367 | #undef FUNC_NAME |
0f2d19dd JB |
368 | |
369 | ||
370 | \f | |
371 | ||
372 | ||
1cc91f1b | 373 | |
0f2d19dd JB |
374 | void |
375 | scm_init_eq () | |
0f2d19dd | 376 | { |
a0599745 | 377 | #include "libguile/eq.x" |
0f2d19dd JB |
378 | } |
379 | ||
89e00824 ML |
380 | |
381 | /* | |
382 | Local Variables: | |
383 | c-file-style: "gnu" | |
384 | End: | |
385 | */ |