61 |
return !memcmp (&x, &y, sizeof(double)); |
return !memcmp (&x, &y, sizeof(double)); |
62 |
} |
} |
63 |
|
|
64 |
|
#include <stdio.h> |
65 |
SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, |
SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, |
66 |
(SCM x, SCM y), |
(SCM x, SCM y), |
67 |
"The @code{eqv?} procedure defines a useful equivalence relation on objects.\n" |
"The @code{eqv?} procedure defines a useful equivalence relation on objects.\n" |
78 |
if (SCM_IMP (y)) |
if (SCM_IMP (y)) |
79 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
80 |
/* this ensures that types and scm_length are the same. */ |
/* this ensures that types and scm_length are the same. */ |
81 |
|
|
82 |
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
83 |
{ |
{ |
84 |
|
/* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), |
85 |
|
but this checks the entire type word, so fractions may be accidentally |
86 |
|
flagged here as unequal. Perhaps I should use the 4th double_cell word? |
87 |
|
*/ |
88 |
|
|
89 |
/* treat mixes of real and complex types specially */ |
/* treat mixes of real and complex types specially */ |
90 |
if (SCM_INEXACTP (x)) |
if (SCM_INEXACTP (x)) |
91 |
{ |
{ |
100 |
SCM_REAL_VALUE (y)) |
SCM_REAL_VALUE (y)) |
101 |
&& SCM_COMPLEX_IMAG (x) == 0.0); |
&& SCM_COMPLEX_IMAG (x) == 0.0); |
102 |
} |
} |
103 |
|
|
104 |
|
if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) |
105 |
|
return scm_i_fraction_equalp (x, y); |
106 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
107 |
} |
} |
108 |
if (SCM_NUMP (x)) |
if (SCM_NUMP (x)) |
111 |
return SCM_BOOL (scm_i_bigcmp (x, y) == 0); |
return SCM_BOOL (scm_i_bigcmp (x, y) == 0); |
112 |
} else if (SCM_REALP (x)) { |
} else if (SCM_REALP (x)) { |
113 |
return SCM_BOOL (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); |
return SCM_BOOL (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); |
114 |
|
} else if (SCM_FRACTIONP (x)) { |
115 |
|
return scm_i_fraction_equalp (x, y); |
116 |
} else { /* complex */ |
} else { /* complex */ |
117 |
return SCM_BOOL (real_eqv (SCM_COMPLEX_REAL (x), |
return SCM_BOOL (real_eqv (SCM_COMPLEX_REAL (x), |
118 |
SCM_COMPLEX_REAL (y)) |
SCM_COMPLEX_REAL (y)) |
161 |
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) |
162 |
{ |
{ |
163 |
/* treat mixes of real and complex types specially */ |
/* treat mixes of real and complex types specially */ |
164 |
if (SCM_INEXACTP (x)) |
if (SCM_INEXACTP (x) && SCM_INEXACTP (y)) |
165 |
{ |
{ |
166 |
if (SCM_REALP (x)) |
if (SCM_REALP (x)) |
167 |
return SCM_BOOL (SCM_COMPLEXP (y) |
return SCM_BOOL (SCM_COMPLEXP (y) |
172 |
&& SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) |
&& SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) |
173 |
&& SCM_COMPLEX_IMAG (x) == 0.0); |
&& SCM_COMPLEX_IMAG (x) == 0.0); |
174 |
} |
} |
175 |
|
|
176 |
|
/* should we handle fractions here also? */ |
177 |
|
else if ((SCM_FRACTIONP (x)) && (SCM_INEXACTP (y))) |
178 |
|
{ |
179 |
|
if (SCM_REALP (y)) |
180 |
|
return SCM_BOOL (scm_i_fraction2double (x) == SCM_REAL_VALUE (y)); |
181 |
|
else |
182 |
|
return SCM_BOOL (SCM_COMPLEX_REAL (y) == scm_i_fraction2double (x) |
183 |
|
&& SCM_COMPLEX_IMAG (y) == 0.0); |
184 |
|
} |
185 |
|
else if ((SCM_FRACTIONP (y)) && (SCM_INEXACTP (x))) |
186 |
|
{ |
187 |
|
if (SCM_REALP (x)) |
188 |
|
return SCM_BOOL (scm_i_fraction2double (y) == SCM_REAL_VALUE (x)); |
189 |
|
else |
190 |
|
return SCM_BOOL (SCM_COMPLEX_REAL (x) == scm_i_fraction2double (y) |
191 |
|
&& SCM_COMPLEX_IMAG (x) == 0.0); |
192 |
|
} |
193 |
|
|
194 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
195 |
} |
} |
196 |
switch (SCM_TYP7 (x)) |
switch (SCM_TYP7 (x)) |
206 |
return scm_real_equalp (x, y); |
return scm_real_equalp (x, y); |
207 |
case scm_tc16_complex: |
case scm_tc16_complex: |
208 |
return scm_complex_equalp (x, y); |
return scm_complex_equalp (x, y); |
209 |
|
case scm_tc16_fraction: |
210 |
|
return scm_i_fraction_equalp (x, y); |
211 |
} |
} |
212 |
case scm_tc7_vector: |
case scm_tc7_vector: |
213 |
case scm_tc7_wvect: |
case scm_tc7_wvect: |