From 674c88a752fcf6b66be6d636d4e48e93e999eae4 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Mon, 25 Jan 2010 18:38:56 +0000
Subject: [PATCH] Improve `internal-forms' First step to custom predicates in
 `define-typed-struct-internal'

svn: r17820

original commit: bb541fd03fa0b35e22f0c82f6c9b3a8a6d5b0591
---
 .../typed-scheme/typecheck/internal-forms.ss  | 23 +++++++++++--------
 collects/typed-scheme/typecheck/tc-structs.ss |  7 +++++-
 2 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/collects/typed-scheme/typecheck/internal-forms.ss b/collects/typed-scheme/typecheck/internal-forms.ss
index a0ce6e9c..5c5b6387 100644
--- a/collects/typed-scheme/typecheck/internal-forms.ss
+++ b/collects/typed-scheme/typecheck/internal-forms.ss
@@ -1,16 +1,21 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base))
+(require (for-syntax scheme/base)
+	 syntax/parse)
 
-(define-syntax-rule (internal-forms nms ...)
+(define-syntax-rule (internal-forms set-name nms ...)
   (begin
-    (provide nms ...)
+    (provide nms ... set-name)
+    (define-literal-set set-name (nms ...))
     (define-syntax (nms stx) (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...))
 
-(internal-forms require/typed-internal define-type-alias-internal
-                define-typed-struct-internal
-                define-typed-struct/exec-internal
-                assert-predicate-internal
-                declare-refinement-internal
-                :-internal)
+(internal-forms internal-literals
+ require/typed-internal
+ define-type-alias-internal
+ define-type-internal
+ define-typed-struct-internal
+ define-typed-struct/exec-internal
+ assert-predicate-internal
+ declare-refinement-internal
+ :-internal)
 
diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss
index 99fd72e6..634d1dd9 100644
--- a/collects/typed-scheme/typecheck/tc-structs.ss
+++ b/collects/typed-scheme/typecheck/tc-structs.ss
@@ -90,6 +90,7 @@
                          #:mutable [setters? #f]
                          #:proc-ty [proc-ty #f]
                          #:maker [maker* #f]
+                         #:predicate [pred* #f]
                          #:constructor-return [cret #f]
                          #:poly? [poly? #f]
                          #:type-only [type-only #f])
@@ -107,6 +108,7 @@
                                #:type-wrapper type-wrapper
                                #:pred-wrapper pred-wrapper
                                #:maker (or maker* maker)
+                               #:predicate (or pred* pred)
                                #:constructor-return cret))))
 
 ;; generate names, and register the approriate types give field types and structure type
@@ -117,6 +119,7 @@
                                #:type-wrapper [type-wrapper values]
                                #:pred-wrapper [pred-wrapper values]
                                #:maker [maker* #f]
+                               #:predicate [pred* #f]
                                #:constructor-return [cret #f])
   ;; create the approriate names that define-struct will bind
   (define-values (maker pred getters setters) (struct-names nm flds setters?))
@@ -127,7 +130,7 @@
     (append 
      (list (cons (or maker* maker) 
                  (wrapper (->* external-fld-types (if cret cret name))))
-           (cons pred
+           (cons (or pred* pred)
                  (make-pred-ty (pred-wrapper name))))
      (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
        (let ([func (if setters? 
@@ -185,6 +188,7 @@
 ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
 (define (tc/struct nm/par flds tys [proc-ty #f] 
                    #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
+                   #:predicate [pred #f]
                    #:type-only [type-only #f])
   ;; get the parent info and create some types and type variables
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
@@ -200,6 +204,7 @@
                    ;; procedure
                    #:proc-ty proc-ty-parsed
                    #:maker maker
+                   #:predicate pred
 		   #:constructor-return (and cret (parse-type cret))
                    #:mutable mutable
                    #:type-only type-only))