/[guile]/guile/guile-core/libguile/eq.c
ViewVC logotype

Diff of /guile/guile-core/libguile/eq.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.47 by dirk, Thu Sep 18 20:55:40 2003 UTC revision 1.48 by mvo, Tue Nov 18 19:59:53 2003 UTC
# Line 61  real_eqv (double x, double y) Line 61  real_eqv (double x, double y)
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"
# Line 77  SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv Line 78  SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv
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          {          {
# Line 93  SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv Line 100  SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv
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))
# Line 101  SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv Line 111  SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv
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))
# Line 149  SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "e Line 161  SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "e
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)
# Line 160  SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "e Line 172  SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "e
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))
# Line 175  SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "e Line 206  SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "e
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:

Legend:
Removed from v.1.47  
changed lines
  Added in v.1.48

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26