Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e MV |
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. | |
0f2d19dd | 7 | * |
73be1d9e MV |
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. | |
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 | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
1bbd0b84 | 17 | |
0f2d19dd | 18 | \f |
1f4d02c2 RB |
19 | #if HAVE_CONFIG_H |
20 | # include <config.h> | |
21 | #endif | |
9540b68f | 22 | |
a0599745 MD |
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" | |
0f2d19dd | 32 | |
a0599745 MD |
33 | #include "libguile/validate.h" |
34 | #include "libguile/eq.h" | |
0f2d19dd | 35 | \f |
9540b68f GH |
36 | |
37 | #ifdef HAVE_STRING_H | |
38 | #include <string.h> | |
39 | #endif | |
40 | \f | |
41 | ||
c3ee7520 | 42 | SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr, |
1bbd0b84 | 43 | (SCM x, SCM y), |
602d32dd KR |
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" | |
4450a227 KR |
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" | |
602d32dd KR |
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" | |
4450a227 | 79 | "(define x (string->symbol \"foo\"))\n" |
602d32dd KR |
80 | "(eq? x 'foo) @result{} #t\n" |
81 | "@end example") | |
1bbd0b84 | 82 | #define FUNC_NAME s_scm_eq_p |
0f2d19dd | 83 | { |
bc36d050 | 84 | return scm_from_bool (scm_is_eq (x, y)); |
0f2d19dd | 85 | } |
1bbd0b84 | 86 | #undef FUNC_NAME |
0f2d19dd | 87 | |
96d00047 MV |
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 | { | |
0e12d408 | 95 | return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y); |
96d00047 | 96 | } |
0f2d19dd | 97 | |
f92e85f7 | 98 | #include <stdio.h> |
47cd67db | 99 | SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, |
1bbd0b84 | 100 | (SCM x, SCM y), |
602d32dd KR |
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") | |
1bbd0b84 | 117 | #define FUNC_NAME s_scm_eqv_p |
0f2d19dd | 118 | { |
bc36d050 | 119 | if (scm_is_eq (x, y)) |
950cc72b MD |
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; | |
0f2d19dd | 125 | /* this ensures that types and scm_length are the same. */ |
f92e85f7 | 126 | |
fbd485ba | 127 | if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
950cc72b | 128 | { |
f92e85f7 MV |
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 | ||
950cc72b | 134 | /* treat mixes of real and complex types specially */ |
6b412e91 | 135 | if (SCM_INEXACTP (x)) |
950cc72b | 136 | { |
6b412e91 | 137 | if (SCM_REALP (x)) |
7888309b | 138 | return scm_from_bool (SCM_COMPLEXP (y) |
96d00047 MV |
139 | && real_eqv (SCM_REAL_VALUE (x), |
140 | SCM_COMPLEX_REAL (y)) | |
6b412e91 | 141 | && SCM_COMPLEX_IMAG (y) == 0.0); |
950cc72b | 142 | else |
7888309b | 143 | return scm_from_bool (SCM_REALP (y) |
96d00047 MV |
144 | && real_eqv (SCM_COMPLEX_REAL (x), |
145 | SCM_REAL_VALUE (y)) | |
950cc72b MD |
146 | && SCM_COMPLEX_IMAG (x) == 0.0); |
147 | } | |
f92e85f7 MV |
148 | |
149 | if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) | |
150 | return scm_i_fraction_equalp (x, y); | |
950cc72b MD |
151 | return SCM_BOOL_F; |
152 | } | |
153 | if (SCM_NUMP (x)) | |
154 | { | |
eb42e2f0 | 155 | if (SCM_BIGP (x)) { |
7888309b | 156 | return scm_from_bool (scm_i_bigcmp (x, y) == 0); |
6b412e91 | 157 | } else if (SCM_REALP (x)) { |
7888309b | 158 | return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); |
f92e85f7 MV |
159 | } else if (SCM_FRACTIONP (x)) { |
160 | return scm_i_fraction_equalp (x, y); | |
eb42e2f0 | 161 | } else { /* complex */ |
7888309b | 162 | return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x), |
96d00047 MV |
163 | SCM_COMPLEX_REAL (y)) |
164 | && real_eqv (SCM_COMPLEX_IMAG (x), | |
165 | SCM_COMPLEX_IMAG (y))); | |
eb42e2f0 | 166 | } |
950cc72b | 167 | } |
47cd67db MD |
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; | |
0f2d19dd | 172 | } |
1bbd0b84 | 173 | #undef FUNC_NAME |
0f2d19dd JB |
174 | |
175 | ||
a48d60b1 MD |
176 | SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, |
177 | (SCM x, SCM y), | |
602d32dd KR |
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?}.") | |
1bbd0b84 | 213 | #define FUNC_NAME s_scm_equal_p |
0f2d19dd JB |
214 | { |
215 | SCM_CHECK_STACK; | |
950cc72b MD |
216 | tailrecurse: |
217 | SCM_TICK; | |
bc36d050 | 218 | if (scm_is_eq (x, y)) |
950cc72b MD |
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; | |
d2e53ed6 | 224 | if (scm_is_pair (x) && scm_is_pair (y)) |
950cc72b | 225 | { |
7888309b | 226 | if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y)))) |
950cc72b MD |
227 | return SCM_BOOL_F; |
228 | x = SCM_CDR(x); | |
229 | y = SCM_CDR(y); | |
230 | goto tailrecurse; | |
231 | } | |
baa84a20 | 232 | if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string) |
950cc72b | 233 | return scm_string_equal_p (x, y); |
789d2fc8 MV |
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 | } | |
950cc72b | 244 | /* This ensures that types and scm_length are the same. */ |
fbd485ba | 245 | if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
950cc72b MD |
246 | { |
247 | /* treat mixes of real and complex types specially */ | |
f92e85f7 | 248 | if (SCM_INEXACTP (x) && SCM_INEXACTP (y)) |
950cc72b | 249 | { |
6b412e91 | 250 | if (SCM_REALP (x)) |
7888309b | 251 | return scm_from_bool (SCM_COMPLEXP (y) |
950cc72b | 252 | && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y) |
6b412e91 | 253 | && SCM_COMPLEX_IMAG (y) == 0.0); |
950cc72b | 254 | else |
7888309b | 255 | return scm_from_bool (SCM_REALP (y) |
950cc72b MD |
256 | && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) |
257 | && SCM_COMPLEX_IMAG (x) == 0.0); | |
0f2d19dd | 258 | } |
f92e85f7 | 259 | |
af4f8612 MV |
260 | /* Vectors can be equal to one-dimensional arrays. |
261 | */ | |
262 | if (SCM_I_ARRAYP (x) || SCM_I_ARRAYP (y)) | |
263 | return scm_array_equal_p (x, y); | |
264 | ||
950cc72b MD |
265 | return SCM_BOOL_F; |
266 | } | |
267 | switch (SCM_TYP7 (x)) | |
268 | { | |
269 | default: | |
a48d60b1 | 270 | break; |
534c55a9 DH |
271 | case scm_tc7_number: |
272 | switch SCM_TYP16 (x) | |
273 | { | |
274 | case scm_tc16_big: | |
275 | return scm_bigequal (x, y); | |
276 | case scm_tc16_real: | |
277 | return scm_real_equalp (x, y); | |
278 | case scm_tc16_complex: | |
279 | return scm_complex_equalp (x, y); | |
f92e85f7 MV |
280 | case scm_tc16_fraction: |
281 | return scm_i_fraction_equalp (x, y); | |
534c55a9 | 282 | } |
950cc72b MD |
283 | case scm_tc7_vector: |
284 | case scm_tc7_wvect: | |
354116f7 | 285 | return scm_i_vector_equal_p (x, y); |
950cc72b | 286 | } |
789d2fc8 | 287 | generic_equal: |
a48d60b1 MD |
288 | if (SCM_UNPACK (g_scm_equal_p)) |
289 | return scm_call_generic_2 (g_scm_equal_p, x, y); | |
290 | else | |
291 | return SCM_BOOL_F; | |
0f2d19dd | 292 | } |
1bbd0b84 | 293 | #undef FUNC_NAME |
0f2d19dd JB |
294 | |
295 | ||
296 | \f | |
297 | ||
298 | ||
1cc91f1b | 299 | |
0f2d19dd JB |
300 | void |
301 | scm_init_eq () | |
0f2d19dd | 302 | { |
a0599745 | 303 | #include "libguile/eq.x" |
0f2d19dd JB |
304 | } |
305 | ||
89e00824 ML |
306 | |
307 | /* | |
308 | Local Variables: | |
309 | c-file-style: "gnu" | |
310 | End: | |
311 | */ |