Add `tech-equal?'.

This refuses to work on inexact numbers and procedures.  Use it in
`check-expect' & friends.

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)

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))

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))

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)

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))))])
+                                  #f))))]
-    (let ? ([a a][b b])
+	 [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

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))