From 39541c51b5f1a2d5c20f68d8c4cdda30521803d9 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Fri, 15 Oct 2010 15:26:24 +0200 Subject: [PATCH] Add `tech-equal?'. This refuses to work on inexact numbers and procedures. Use it in `check-expect' & friends. --- collects/deinprogramm/DMdA.rkt | 6 +-- .../signature/signature-syntax.rkt | 4 +- collects/lang/private/signature-syntax.rkt | 4 +- collects/lang/private/teach.rkt | 6 +-- collects/lang/private/teachprims.rkt | 43 +++++++++++++++++-- collects/test-engine/racket-tests.rkt | 4 +- 6 files changed, 51 insertions(+), 16 deletions(-) diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index 9410d10372..d8449c94a5 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -16,7 +16,7 @@ (require deinprogramm/define-record-procedures) -(require (only-in lang/private/teachprims define-teach beginner-equal? beginner-equal~?)) +(require (only-in lang/private/teachprims define-teach teach-equal? beginner-equal~?)) (require (for-syntax deinprogramm/syntax-checkers)) @@ -1078,7 +1078,7 @@ #t)))))) (define (expect v1 v2) - (quickcheck:property () (beginner-equal? v1 v2))) + (quickcheck:property () (teach-equal? v1 v2))) (define (ensure-real who n val) (unless (real? val) @@ -1103,7 +1103,7 @@ (define (expect-member-of val . candidates) (quickcheck:property () (ormap (lambda (cand) - (beginner-equal? val cand)) + (teach-equal? val cand)) candidates))) (define property (signature (predicate (lambda (x) diff --git a/collects/deinprogramm/signature/signature-syntax.rkt b/collects/deinprogramm/signature/signature-syntax.rkt index f73075d039..bd5b66def5 100644 --- a/collects/deinprogramm/signature/signature-syntax.rkt +++ b/collects/deinprogramm/signature/signature-syntax.rkt @@ -12,7 +12,7 @@ (for-syntax scheme/base) (for-syntax syntax/stx) (for-syntax stepper/private/shared) - (only-in lang/private/teachprims beginner-equal?)) + (only-in lang/private/teachprims teach-equal?)) (define-for-syntax (phase-lift stx) (with-syntax ((?stx stx)) @@ -50,7 +50,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-signature '?name (list ?temp ...) beginner-equal? ?stx))))) + (make-case-signature '?name (list ?temp ...) teach-equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/lang/private/signature-syntax.rkt b/collects/lang/private/signature-syntax.rkt index 5b99bf7505..22a02dcc0e 100644 --- a/collects/lang/private/signature-syntax.rkt +++ b/collects/lang/private/signature-syntax.rkt @@ -11,7 +11,7 @@ (for-syntax scheme/base) (for-syntax syntax/stx) (for-syntax stepper/private/shared) - (only-in lang/private/teachprims beginner-equal?) + (only-in lang/private/teachprims teach-equal?) (for-syntax "firstorder.rkt")) (define-for-syntax (phase-lift stx) @@ -50,7 +50,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-signature '?name (list ?temp ...) beginner-equal? ?stx))))) + (make-case-signature '?name (list ?temp ...) teach-equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index a4141de947..ae4150420c 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -52,7 +52,7 @@ scheme/class "../posn.rkt" (only lang/private/teachprims - beginner-equal? beginner-equal~? + beginner-equal? beginner-equal~? teach-equal? advanced-cons advanced-list*)) (require-for-syntax "teachhelp.ss" "teach-shared.ss" @@ -3003,7 +3003,7 @@ #t)))))) (define (expect v1 v2) - (quickcheck:property () (beginner-equal? v1 v2))) + (quickcheck:property () (teach-equal? v1 v2))) (define (ensure-real who n val) (unless (real? val) @@ -3028,7 +3028,7 @@ (define (expect-member-of val . candidates) (quickcheck:property () (ormap (lambda (cand) - (beginner-equal? val cand)) + (teach-equal? val cand)) candidates))) (define Property (signature (predicate (lambda (x) diff --git a/collects/lang/private/teachprims.rkt b/collects/lang/private/teachprims.rkt index 755a3147c5..2d588519fc 100644 --- a/collects/lang/private/teachprims.rkt +++ b/collects/lang/private/teachprims.rkt @@ -242,7 +242,7 @@ namespace. (define-teach beginner exit (lambda () (exit))) -(define (tequal? a b epsilon) +(define (tequal? x y epsilon) (let* ([ht (make-hash)] ;; make-hash [union-find (lambda (a) (let loop ([prev a] @@ -264,15 +264,49 @@ namespace. #t (begin (hash-set! ht b a) - #f))))]) - (let ? ([a a][b b]) + #f))))] + [fail (lambda (fmt arg) + (raise (make-exn:fail:contract (if (or (eq? arg x) + (eq? arg y)) + (format fmt arg) + (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) + (current-continuation-marks))))]) + (let ? ([a x][b y]) (cond [(real? a) (and (real? b) (beginner-=~ a b epsilon))] + [(procedure? a) + (fail "first argument of equality cannot be a procedure, given ~e" a)] + [(procedure? b) + (fail "second argument of equality cannot be a procedure, given ~e" b)] [(union-equal!? a b) #t] [else (equal?/recur a b ?)])))) +(define (teach-equal? x y) + + (define (fail fmt arg) + (raise (make-exn:fail:contract (if (or (eq? arg x) + (eq? arg y)) + (format fmt arg) + (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) + (current-continuation-marks)))) + + (let recur ([a x] [b y]) + (cond + [(procedure? a) + (fail "first argument of equality cannot be a procedure, given ~e" a)] + [(procedure? b) + (fail "second argument of equality cannot be a procedure, given ~e" b)] + [(and (number? a) + (inexact? a)) + (fail "first argument of equality cannot be an inexact number, given ~e" a)] + [(and (number? b) + (inexact? b)) + (fail "first argument of equality cannot be an inexact number, given ~e" b)] + [else + (equal?/recur a b recur)]))) + (define-teach beginner equal? (lambda (a b) (equal? a b))) @@ -423,7 +457,8 @@ namespace. advanced-make-immutable-hash advanced-make-immutable-hasheq advanced-make-immutable-hasheqv - cyclic-list?) + cyclic-list? + teach-equal?) ;; ----------------------------------------------------------------------------- ;; auxiliary stuff, ignore diff --git a/collects/test-engine/racket-tests.rkt b/collects/test-engine/racket-tests.rkt index 898175cb87..f2154c25e2 100644 --- a/collects/test-engine/racket-tests.rkt +++ b/collects/test-engine/racket-tests.rkt @@ -156,7 +156,7 @@ actual INEXACT-NUMBERS-FMT #t) (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) (send (send test-engine get-info) add-check) - (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) + (run-and-check (lambda (v1 v2 _) (teach-equal? v1 v2)) (lambda (src format v1 v2 _) (make-unequal src format v1 v2)) test actual #f src test-engine 'check-expect)) @@ -247,7 +247,7 @@ (define (check-member-of-values-expected test first-actual actuals src test-engine) (error-check (lambda (v) (not (procedure? v))) first-actual CHECK-MEMBER-OF-FUNCTION-FMT #f) (send (send test-engine get-info) add-check) - (run-and-check (lambda (v2 v1 _) (memf (lambda (i) (beginner-equal? v1 i)) v2)) + (run-and-check (lambda (v2 v1 _) (memf (lambda (i) (teach-equal? v1 i)) v2)) (lambda (src format v1 v2 _) (make-not-mem src format v1 v2)) test (cons first-actual actuals) #f src test-engine 'check-member-of))