suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: repairs for equal?/recur, especially on hash tables

Browse Source
This commit is contained in:
Matthew Flatt 2020-01-12 09:10:53 -07:00
parent 96ac646284
commit 15d107d373
4 changed files with 50 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -3106,6 +3106,33 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test #f equal?/recur 1 2 (lambda (a b) 'yes))
(test #t equal?/recur 1 1 (lambda (a b) 'yes))
(test #t equal?/recur '(1 . 2) '(1 . 2) (lambda (a b) 'yes))
(test #f equal?/recur '(1 . 2) '(1 . 2) (lambda (a b) (eq? a 1)))
(test #t equal?/recur '(1 . 1) '(1 . 2) (lambda (a b) (or (eq? a b) (eq? a 1))))
(test #t equal?/recur '#(1 2 3) '#(1 2 3) (lambda (a b) 'yes))
(test #f equal?/recur '#(1 2 3) '#(1 2 3) (lambda (a b) (not (eqv? a 2))))
(test #t equal?/recur '#&1 '#&1 (lambda (a b) 'yes))
(test #f equal?/recur '#&1 '#&1 (lambda (a b) #f))
(test #t equal?/recur '#hash((1 . x)) '#hash((1 . x)) (lambda (a b) 'yes))
(test #t equal?/recur '#hash((1 . x)) '#hash((1 . z)) (lambda (a b) (or (eq? a b) (eq? 'z b))))
(test #f equal?/recur '#hash(("2" . x)) (hash (string-copy "2") 'x) (lambda (a b) (eq? a b)))
(test #t equal?/recur '#hash(("2" . x)) (hash (string-copy "2") 'x) (lambda (a b) (or (eq? a b) (eq? "2" a))))
(test #f equal?/recur '#hash((1 . x)) '#hash((1 . x)) (lambda (a b) #f))
(test #f equal?/recur '#hash((1 . x)) '#hash((1 . x)) (lambda (a b) (eq? a 1)))
(test #f equal?/recur '#hash((1 . x)) '#hash((1 . x)) (lambda (a b) (eq? a 'x)))
(let ()
(struct a (x) #:transparent)
(test #t equal?/recur (a 1) (a 2) (lambda (a b) 'yes))
(test #f equal?/recur (a 1) (a 1) (lambda (a b) (not (eq? a 1)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)
"last item in file"

20
racket/src/cs/rumble/equal.ss
View File

@ -73,7 +73,9 @@
(or (check-union-find ctx a b)
(if eql?
(and (eql? (car a) (car b))
(eql? (cdr a) (cdr b)))
(eql? (cdr a) (cdr b))
;; In case `eql?` doesn't return a boolean:
#t)
(let ([ctx (deeper-context ctx)])
(and
(equal? (car a) (car b) ctx)
@ -85,16 +87,18 @@
(immutable-box? b)))
(or (check-union-find ctx a b)
(if eql?
(eql? (unbox orig-a) (unbox orig-b))
(and (eql? (unbox orig-a) (unbox orig-b))
#t)
(let ([ctx (deeper-context ctx)])
(equal? (unbox orig-a) (unbox orig-b) ctx)))))]
[(authentic-hash? a)
(and (authentic-hash? b)
(or (check-union-find ctx a b)
(let ([ctx (deeper-context ctx)])
(hash=? orig-a orig-b
(lambda (a b)
(equal? a b ctx))))))]
(hash=? orig-a orig-b
(or eql?
(let ([ctx (deeper-context ctx)])
(lambda (a b)
(equal? a b ctx)))))))]
[(record? a)
(and (record? b)
;; Check for `prop:impersonator-of`
@ -122,7 +126,9 @@
(or (check-union-find ctx a b)
(cond
[eql?
(rec-equal? orig-a orig-b eql?)]
(rec-equal? orig-a orig-b (lambda (a b)
;; Make sure record sees only booleans:
(and (eql? a b) #t)))]
[(and (eq? mode 'chaperone-of?)
(with-global-lock* (hashtable-contains? rtd-mutables (record-rtd a))))
;; Mutable records must be `eq?` for `chaperone-of?`

6
racket/src/cs/rumble/hamt-stencil.ss
View File

@ -922,7 +922,10 @@
[else
(let ([p (cnode-assoc bc (caar ac))])
(and p
(or (not eql?) (eql? (cdar ac) (cdr p)))
(or (not eql?)
(and
(eql? (caar ac) (car p)) ; needed for `equal?/recur`
(eql? (cdar ac) (cdr p))))
(loop (cdr ac))))]))))))
(define (bnode-entry-at-position n pos mode fail)
@ -1027,6 +1030,7 @@
(let ([ak (bnode-key-index-ref a i)]
[bk (bnode-key-index-ref b i)])
(and (hamt-wrapped-key=? ak bk)
(eql? (hamt-unwrap-key ak) (hamt-unwrap-key bk)) ; needed for `equal?/recur`
(eql? (bnode-val-index-ref a i) (bnode-val-index-ref b i))
(loop (fx+ j 1)))))])))]
[else

6
racket/src/cs/rumble/patricia.ss
View File

@ -370,7 +370,9 @@
;; equality
(define (intmap=? a b eql?)
(and (eq? (intmap-eqtype a) (intmap-eqtype b))
($intmap=? (intmap-eqtype a) (intmap-root a) (intmap-root b) eql?)))
($intmap=? (intmap-eqtype a) (intmap-root a) (intmap-root b) eql?)
;; in case `eql?` doesn't return a boolean
#t))
(define ($intmap=? et a b eql?)
(or
@ -388,6 +390,7 @@
[(Lf? a)
(and (Lf? b)
(key=? et (Lf-key a) (Lf-key b))
(eql? (Lf-key a) (Lf-key b)) ; for `equal?/recur`
(eql? (Lf-value a) (Lf-value b)))]
[(Co? a)
@ -400,6 +403,7 @@
[else
(let ([pair ($collision-ref et b (caar xs) values #f)])
(and pair
(eql? (caar xs) (car pair)) ; for `equal?/recur`
(eql? (cdar xs) (cdr pair))
(loop (cdr xs))))])))))]