Commit bda0a507 authored by Erick's avatar Erick

R7RS: equal?, assoc and member work now on circular lists

parent 281c896e
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 12-Oct-2018 17:19 (eg)
;;;; Last file update: 27-Nov-2018 17:46 (eg)
;;;;
......@@ -31,6 +31,13 @@
;;;; ----------------------------------------------------------------------
;;;; 6.1 Equivalence predicate
;;;; ----------------------------------------------------------------------
(define equal-simple? equal?)
(set! equal? %equiv?) ;; equiv? is defined in equiv.stk
;;;; ----------------------------------------------------------------------
;;;; 6.3 Booleans
;;;; ----------------------------------------------------------------------
......@@ -68,6 +75,15 @@ doc>
(define (make-list k :optional (fill (void)))
(vector->list (make-vector k fill)))
;;
;; Define versions of member and assoc which use equiv? instead of equal?
;;
(define member-simple member)
(define assoc-simple assoc)
(define (member x y :optional (compar %equiv?)) (member-simple x y compar))
(define (assoc x y :optional (compar %equiv?)) (assoc-simple x y compar))
;;;; ----------------------------------------------------------------------
;;;; 6.5 Symbols
......
(register-exit-function! (lambda (n)
(eprintf "In exit function #1 retcode = ~S\n" n)))
(register-exit-function! (lambda (n)
(eprintf "In exit function #2 retcode = ~S\n" n)))
(dynamic-wind
(lambda() (display 1))
(lambda()
(display 2)
(dynamic-wind
(lambda () (display 3))
(lambda () (display 4) (exit 42) (display 5))
(lambda () (display 6) (newline)))
(display 7))
(lambda() (display 8)(newline)))
......@@ -22,13 +22,16 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 26-Mar-2018 10:06 (eg)
* Last file update: 26-Nov-2018 16:20 (eg)
*/
#include "stklos.h"
#include "object.h"
#include "struct.h"
#define MAX_EQUAL_CALLS 100000 // Maximum calls of %try-equal
DEFINE_PRIMITIVE("not", not, subr1, (SCM x))
/*
<doc not
......@@ -358,6 +361,90 @@ DEFINE_PRIMITIVE("equal?", equal, subr2, (SCM x, SCM y))
return STk_false;
}
/*
* The equal-count function is a variant of equal which is bounded in
* recursion calls. This function returns a boolean (AND a boolean
* which tells the caller if a cycle was detected)
*/
static SCM equal_count(SCM x, SCM y, int max, int *cycle)
{
Top:
if (STk_eqv(x, y) == STk_true) return STk_true;
if (!max--) { *cycle = 1; return STk_false; }
switch (STYPE(x)) {
case tc_cons:
if (CONSP(y)) {
if (equal_count(CAR(x), CAR(y), max, cycle) == STk_false) return STk_false;
x = CDR(x); y = CDR(y);
goto Top;
}
break;
case tc_string:
if (STRINGP(y)) {
return STk_streq(x, y);
}
break;
case tc_vector:
if (VECTORP(y)) {
long lx, ly, i;
SCM *vx, *vy;
lx = VECTOR_SIZE(x); ly = VECTOR_SIZE(y);
if (lx == ly) {
vx = VECTOR_DATA(x);
vy = VECTOR_DATA(y);
for (i=0; i < lx; i++) {
if (equal_count(vx[i], vy[i], max, cycle) == STk_false) return STk_false;
}
return STk_true;
}
}
break;
case tc_instance:
if (STk_oo_initialized) {
SCM fg, res;
fg = STk_lookup(STk_intern("object-equal?"),STk_current_module(),
&res,FALSE);
res = STk_C_apply(fg, 2, x, y);
return res;
}
break;
case tc_struct:
if (STRUCTP(y) && (STRUCT_TYPE(x) == STRUCT_TYPE(y)))
return equal_count(STk_struct2list(x), STk_struct2list(y), max, cycle);
break;
case tc_box:
if (BOXP(y))
return equal_count(BOX_VALUE(x), BOX_VALUE(y), max, cycle);
break;
case tc_uvector:
if (BOXED_TYPE_EQ(y, tc_uvector))
return MAKE_BOOLEAN(STk_uvector_equal(x, y));
break;
#ifdef FIXME
//EG: default:
//EG: if (EXTENDEDP(x) && EXTENDEDP(y) && TYPE(x) == TYPE(y))
//EG: return STk_extended_compare(x, y, TRUE);
#endif
default: break;
}
return STk_false;
}
/* %equal-try returns a boolean when it doesn't detect a cycle (in a
* given amount of calls). It returns '() when it suspects a cycle.
*/
DEFINE_PRIMITIVE("%equal-try", equal_try, subr2, (SCM x, SCM y))
{
int cycle = 0;
SCM res = equal_count(x, y, MAX_EQUAL_CALLS, &cycle);
return (cycle) ? STk_nil : res;
}
int STk_init_boolean(void)
{
ADD_PRIMITIVE(not);
......@@ -365,5 +452,6 @@ int STk_init_boolean(void)
ADD_PRIMITIVE(eq);
ADD_PRIMITIVE(eqv);
ADD_PRIMITIVE(equal);
ADD_PRIMITIVE(equal_try);
return TRUE;
}
......@@ -22,13 +22,85 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 21-Sep-2018 10:01 (eg)
;;;; Last file update: 27-Nov-2018 17:48 (eg)
;;;;
(require "test")
(test-section "R7RS")
(test-subsection "Equivalence Predicates")
(test "eqv?.1" #t (eqv? 'a 'a))
(test "eqv?.2" #f (eqv? 'a 'b))
(test "eqv?.3" #t (eqv? 2 2))
(test "eqv?.4" #f (eqv? 2 2.0))
(test "eqv?.5" #t (eqv? '() '()))
(test "eqv?.6" #t (eqv? 100000000 100000000))
(test "eqv?.7" #f (eqv? 0.0 +nan.0))
(test "eqv?.8" #f (eqv? (cons 1 2) (cons 1 2)))
(test "eqv?.9" #f (eqv? (lambda () 1)
(lambda () 2)))
(test "eqv?.10" #t (let ((p (lambda (x) x)))
(eqv? p p)))
(test "eqv?.11" #f (eqv? #f 'nil))
(let ()
(define gen-counter
(lambda ()
(let ((n 0))
(lambda () (set! n (+ n 1)) n))))
(define gen-loser
(lambda ()
(let ((n 0))
(lambda () (set! n (+ n 1)) 27))))
(test "gen-counter.1" #t
(let ((g (gen-counter)))
(eqv? g g)))
(test "gen-counter.2" #f
(eqv? (gen-counter) (gen-counter)))
(test "gen-loser" #t
(let ((g (gen-loser)))
(eqv? g g))))
(test "eqv?12" #f
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
(g (lambda () (if (eqv? f g) 'g 'both))))
(eqv? f g)))
(test "eq?.1" #t (eq? 'a 'a))
(test "eq?.2" #t (boolean? (eq? '(a) '(a))))
(test "eq?.3" #f (eq? (list 'a) (list 'a)))
(test "eq?.4" #t (boolean? (eq? "a" "a")))
(test "eq?.5" #t (boolean? (eq? "" "")))
(test "eq?.6" #t (eq? '() '()))
(test "eq?.7" #t (eq? 2 2))
(test "eq?.8" #t (eq? #\A #\A))
(test "eq?.9" #t (eq? car car))
(test "eq?.10" #t (let ((n (+ 2 3)))
(eq? n n)))
(test "eq?.11" #t (let ((x '(a)))
(eq? x x)))
(test "eq?.12" #t (let ((x '#()))
(eq? x x)))
(test "eq?.13" #t (let ((p (lambda (x) x)))
(eq? p p)))
(test "equal?.1" #t (equal? '(a (b) c)
'(a (b) c)))
(test "equal?.2" #t (equal? (make-vector 5 'a)
(make-vector 5 'a)))
(test "equal?.3" #t (equal? '#0=(a b . #0#)
'#1=(a b a b . #1#)))
(test "equal?.4" #f (equal? '#0=(a b a . #0#)
'#1=(a b a b . #1#)))
;;------------------------------------------------------------------
(test-subsection "Control features")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment