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