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