eqv? behavior per R7RS

This commit is contained in:
Justin Ethier 2020-05-21 18:12:54 -04:00
parent 6d0b082f37
commit 3dc451d016
4 changed files with 21 additions and 2 deletions

View file

@ -443,6 +443,7 @@ double MRG32k3a (double seed);
*/ */
/**@{*/ /**@{*/
//object Cyc_eq(object x, object y); //object Cyc_eq(object x, object y);
object Cyc_eqv(object x, object y);
#define Cyc_eq(x, y) (make_boolean(x == y)) #define Cyc_eq(x, y) (make_boolean(x == y))
int equal(object, object); int equal(object, object);
object equalp(object, object); object equalp(object, object);

View file

@ -2041,6 +2041,18 @@ object Cyc_is_procedure(void *data, object o)
// return boolean_f; // return boolean_f;
//} //}
object Cyc_eqv(object x, object y)
{
if (Cyc_eq(x, y) == boolean_t) {
return boolean_t;
} else if (Cyc_is_number(x) == boolean_t &&
equalp(x, y) == boolean_t) {
return boolean_t;
} else {
return boolean_f;
}
}
object Cyc_is_immutable(object obj) object Cyc_is_immutable(object obj)
{ {
if (is_object_type(obj) && if (is_object_type(obj) &&
@ -4838,7 +4850,7 @@ void _eq_127(void *data, object cont, object args)
void _eqv_127(void *data, object cont, object args) void _eqv_127(void *data, object cont, object args)
{ {
Cyc_check_num_args(data, "eqv?", 2, args); Cyc_check_num_args(data, "eqv?", 2, args);
_eq_127(data, cont, args); return_closcall1(data, cont, Cyc_eqv(car(args), cadr(args)));
} }
void _equal_127(void *data, object cont, object args) void _equal_127(void *data, object cont, object args)

View file

@ -662,7 +662,7 @@
((eq? p 'set-car!) "Cyc_set_car_cps") ((eq? p 'set-car!) "Cyc_set_car_cps")
((eq? p 'set-cdr!) "Cyc_set_cdr_cps") ((eq? p 'set-cdr!) "Cyc_set_cdr_cps")
((eq? p 'eq?) "Cyc_eq") ((eq? p 'eq?) "Cyc_eq")
((eq? p 'eqv?) "Cyc_eq") ((eq? p 'eqv?) "Cyc_eqv")
((eq? p 'equal?) "equalp") ((eq? p 'equal?) "equalp")
((eq? p 'Cyc-fast-member) "memberp") ((eq? p 'Cyc-fast-member) "memberp")
((eq? p 'Cyc-fast-assoc) "assoc") ((eq? p 'Cyc-fast-assoc) "assoc")

View file

@ -202,6 +202,12 @@
(assert:equal "" (symbol->string 'a/test-01) "a/test-01") (assert:equal "" (symbol->string 'a/test-01) "a/test-01")
(assert:equal "" (eq? 'a-1 'a-1) #t) (assert:equal "" (eq? 'a-1 'a-1) #t)
(assert:equal "" (eq? (string->symbol "aa") 'aa) #t) (assert:equal "" (eq? (string->symbol "aa") 'aa) #t)
(assert:equal "" (eq? 0.0 0.0) #f)
(assert:equal "" (eq? 33333333333333 3333333333333333) #f)
(assert:equal "" (eqv? 'a-1 'a-1) #t)
(assert:equal "" (eqv? (string->symbol "aa") 'aa) #t)
(assert:equal "" (eqv? 0.0 0.0) #t)
(assert:equal "" (eqv? 33333333333333 3333333333333333) #t)
(assert:equal "" (equal? (string->symbol "aa") 'aa) #t) (assert:equal "" (equal? (string->symbol "aa") 'aa) #t)
;; Map ;; Map