From c77e906c7afb257d94e61a01706553064150a1a6 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 15 Jun 2011 15:04:04 -0400
Subject: [PATCH] Added types and tests for equality operations.

---
 .../tests/typed-scheme/succeed/equality.rkt   | 15 ++++++++++
 collects/typed-scheme/base-env/base-env.rkt   | 29 ++++++++++++++-----
 collects/typed-scheme/types/abbrev.rkt        |  6 ++++
 3 files changed, 43 insertions(+), 7 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/equality.rkt

diff --git a/collects/tests/typed-scheme/succeed/equality.rkt b/collects/tests/typed-scheme/succeed/equality.rkt
new file mode 100644
index 0000000000..274fd21816
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/equality.rkt
@@ -0,0 +1,15 @@
+#lang typed/racket
+
+
+(boolean? true)
+(boolean? (not 6))
+(immutable? (cons 3 4))
+
+(boolean=? #t false)
+(symbol=? 'foo 'foo)
+(false? 'foo)
+
+(equal? 1 2)
+(eqv? 1 2)
+(eq? 1 2)
+(equal?/recur 'foo 'bar eq?)
diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt
index de204d6a65..bda9e6a3b4 100644
--- a/collects/typed-scheme/base-env/base-env.rkt
+++ b/collects/typed-scheme/base-env/base-env.rkt
@@ -206,10 +206,29 @@
 [null (-val null)]
 [char? (make-pred-ty -Char)]
 
+;Section 3.1
+
 [boolean? (make-pred-ty B)]
-[eq? (-> Univ Univ B)]
-[eqv? (-> Univ Univ B)]
+[not (-> Univ B)]
 [equal? (-> Univ Univ B)]
+[eqv? (-> Univ Univ B)]
+[eq? (-> Univ Univ B)]
+
+[equal?/recur (-> Univ Univ (-> Univ Univ Univ) B)]
+[immutable? (-> Univ B)]
+[prop:equal+hash -Struct-Type-Property]
+
+
+;; scheme/bool
+[true (-val #t)]
+[false (-val #f)]
+[boolean=? (B B . -> . B)]
+[symbol=? (Sym Sym . -> . B)]
+[false? (make-pred-ty (-val #f))]
+
+
+
+
 [assert (-poly (a b) (cl->*
 		      (Univ (make-pred-ty (list a) Univ b) . -> . b)
 		      (-> (Un a (-val #f)) a)))]
@@ -231,7 +250,7 @@
                               ;; 1 means predicate on second argument
                               (make-pred-ty (list (make-pred-ty (list a) c d) (-lst a)) c (-lst d) 1)
                               (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c)))]
-[not (make-pred-ty (-val #f))]
+
 [box (-poly (a) (a . -> . (-box a)))]
 [unbox (-poly (a) (cl->*
                    ((-box a) . -> . a)
@@ -968,10 +987,6 @@
 [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))]
 [tcp-listen (-Integer [-Integer Univ (-opt -String)] . ->opt . -TCP-Listener)]
 
-;; scheme/bool
-[boolean=? (B B . -> . B)]
-[symbol=? (Sym Sym . -> . B)]
-[false? (make-pred-ty (-val #f))]
 
 ;; with-stx.rkt
 [generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))]
diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt
index eea6c029f4..3f1f895042 100644
--- a/collects/typed-scheme/types/abbrev.rkt
+++ b/collects/typed-scheme/types/abbrev.rkt
@@ -177,6 +177,12 @@
 
 (define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String))
 
+(define -Struct-Type-Property
+  (make-Base 'Struct-Type-Property #'struct-type-property? struct-type-property? #'Struct-Type-Property))
+
+
+
+
 (define -top (make-Top))
 (define -bot (make-Bot))
 (define -no-filter (make-FilterSet -top -top))