conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

- fixed equal? to terminate on all inputs as mandated by R6RS. 

(thanks to Michael Adams and Kent Dybvig for making the code
   available in its entirety in their ICFP 2008 paper)
This commit is contained in:
Abdulaziz Ghuloum 2008-11-11 00:39:02 -05:00
parent 25f40fefb0
commit 766eb7f539
6 changed files with 172 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/Makefile.am
View File

@ -28,7 +28,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
ikarus.reader.annotated.ss ikarus.pointers.ss
ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss
all: $(nodist_pkglib_DATA)

2
scheme/Makefile.in
View File

@ -183,7 +183,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
ikarus.reader.annotated.ss ikarus.pointers.ss
ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss
revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g")

166
scheme/ikarus.equal.ss Normal file
View File

@ -0,0 +1,166 @@
;;; Copied from
;;; Efficient Nondestructive Equality Checking for Trees and Graphs
;;; Michael D. Adams and R. Kent Dybvig
;;; ICFP 2008
(library (ikarus.equal)
(export equal?)
(import (except (ikarus) equal?))
(module UNSAFE
(< <= > >= = + - vector-ref vector-length car cdr)
(import
(rename (ikarus system $vectors)
($vector-length vector-length)
($vector-ref vector-ref))
(rename (ikarus system $pairs)
($car car)
($cdr cdr))
(rename (ikarus system $fx)
($fx+ +)
($fx- -)
($fx< <)
($fx> >)
($fx>= >=)
($fx<= <=)
($fx= =))))
(define eq-hashtable-ref hashtable-ref)
(define eq-hashtable-set! hashtable-set!)
(define-struct box (content))
(define (union-find ht x y)
(import UNSAFE)
(define (find b)
(let ([n (box-content b)])
(if (box? n)
(let loop ([b b] [n n])
(let ([nn (box-content n)])
(if (box? nn) (begin (set-box-content! b nn) (loop n nn)) n)))
b)))
(let ([bx (eq-hashtable-ref ht x #f)]
[by (eq-hashtable-ref ht y #f)])
(if (not bx)
(if (not by)
(let ([b (make-box 1)])
(eq-hashtable-set! ht x b)
(eq-hashtable-set! ht y b)
#f)
(let ([ry (find by)]) (eq-hashtable-set! ht x ry) #f))
(if (not by)
(let ([rx (find bx)]) (eq-hashtable-set! ht y rx) #f)
(let ([rx (find bx)] [ry (find by)])
(or (eq? rx ry)
(let ([nx (box-content rx)] [ny (box-content ry)])
(if (> nx ny)
(begin
(set-box-content! ry rx)
(set-box-content! rx (+ nx ny))
#f)
(begin
(set-box-content! rx ry)
(set-box-content! ry (+ ny nx))
#f)))))))))
(define (pre? x y k)
(import UNSAFE)
(cond
[(eq? x y) k]
[(pair? x)
(and (pair? y)
(if (<= k 0)
k
(let ([k (pre? (car x) (car y) (- k 1))])
(and k (pre? (cdr x) (cdr y) k)))))]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (= (vector-length y) n)
(let f ([i 0] [k k])
(if (or (= i n) (<= k 0))
k
(let ([k (pre?
(vector-ref x i)
(vector-ref y i)
(- k 1))])
(and k (f (+ i 1) k))))))))]
[(string? x) (and (string? y) (string=? x y) k)]
[else (and (eqv? x y) k)]))
(define (interleave? x y k)
(import UNSAFE)
(let ([ht #f])
(define (call-union-find x y)
(unless ht (set! ht (make-eq-hashtable)))
(union-find ht x y))
(define (e? x y k)
(if (<= k 0)
(if (= k kb) (fast? x y (random (* 2 k0))) (slow? x y k))
(fast? x y k)))
(define (slow? x y k)
(cond
[(eq? x y) k]
[(pair? x)
(and (pair? y)
(if (call-union-find x y)
0
(let ([k (e? (car x) (car y) (- k 1))])
(and k (e? (cdr x) (cdr y) k)))))]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (= (vector-length y) n)
(if (call-union-find x y)
0
(let f ([i 0] [k (- k 1)])
(if (= i n)
k
(let ([k (e? (vector-ref x i)
(vector-ref y i)
k)])
(and k (f (+ i 1) k)))))))))]
[(string? x) (and (string? y) (string=? x y) k)]
[else (and (eqv? x y) k)]))
(define (fast? x y k)
(let ([k (- k 1)])
(cond
[(eq? x y) k]
[(pair? x)
(and (pair? y)
(let ([k (e? (car x) (car y) k)])
(and k (e? (cdr x) (cdr y) k))))]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (= (vector-length y) n)
(let f ([i 0] [k k])
(if (= i n)
k
(let ([k (e? (vector-ref x i)
(vector-ref y i)
k)])
(and k (f (+ i 1) k))))))))]
[(string? x) (and (string? y) (string=? x y) k)]
[else (and (eqv? x y) k)])))
(and (e? x y k) #t)))
(define k0 400)
(define kb -40)
(define (interleave-equal? x y)
(interleave? x y k0))
(define (precheck/interleave-equal? x y)
(let ([k (pre? x y k0)])
(and k (or (> k 0) (interleave? x y 0)))))
(define (equal? x y)
(precheck/interleave-equal? x y))
)

37
scheme/ikarus.predicates.ss
View File

@ -20,7 +20,7 @@
number? complex? real? rational?
integer? exact? inexact? eof-object? bwp-object? immediate?
boolean? char? vector? bytevector? string? procedure? null? pair?
symbol? code? not weak-pair? eq? eqv? equal? boolean=?
symbol? code? not weak-pair? eq? eqv? boolean=?
symbol=? finite? infinite? nan? real-valued?
rational-valued? integer-valued? transcoder?)
(import
@ -28,7 +28,7 @@
number? complex? real?
rational? integer? exact? inexact? eof-object? bwp-object?
immediate? boolean? char? vector? bytevector? string? procedure?
null? pair? weak-pair? symbol? code? not eq? eqv? equal?
null? pair? weak-pair? symbol? code? not eq? eqv?
transcoder? boolean=? symbol=?
finite? infinite? nan? real-valued? rational-valued?
integer-valued?)
@ -313,39 +313,6 @@
(define-pred symbol=? sys:symbol? "not a symbol")
(define-pred boolean=? sys:boolean? "not a boolean")
(module (equal?)
(define vector-loop
(lambda (x y i n)
(or ($fx= i n)
(and (equal? ($vector-ref x i) ($vector-ref y i))
(vector-loop x y ($fxadd1 i) n)))))
(define string-loop
(lambda (x y i n)
(or ($fx= i n)
(and ($char= ($string-ref x i) ($string-ref y i))
(string-loop x y ($fxadd1 i) n)))))
(define equal?
(lambda (x y)
(cond
[(sys:eq? x y) #t]
[(pair? x)
(and (pair? y)
(equal? ($car x) ($car y))
(equal? ($cdr x) ($cdr y)))]
[(vector? x)
(and (vector? y)
(let ([n ($vector-length x)])
(and ($fx= n ($vector-length y))
(vector-loop x y 0 n))))]
[(string? x)
(and (string? y)
(let ([n ($string-length x)])
(and ($fx= n ($string-length y))
(string-loop x y 0 n))))]
[(sys:bytevector? x)
(and (sys:bytevector? y) (bytevector=? x y))]
[(number? x) (eqv? x y)]
[else #f]))))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1665
1666

1
scheme/makefile.ss
View File

@ -58,6 +58,7 @@
"ikarus.collect.ss"
"ikarus.apply.ss"
"ikarus.predicates.ss"
"ikarus.equal.ss"
"ikarus.pairs.ss"
"ikarus.lists.ss"
"ikarus.fixnums.ss"