From 13b7f8c506a08220d3b8eda689eb591dfbd38ff4 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 9 Apr 2008 23:25:30 +0000
Subject: [PATCH] Add checked-struct-info.

svn: r9227
---
 collects/scheme/private/define-struct.ss    | 64 +++++++++++++++------
 collects/scribblings/reference/struct.scrbl |  9 ++-
 2 files changed, 55 insertions(+), 18 deletions(-)

diff --git a/collects/scheme/private/define-struct.ss b/collects/scheme/private/define-struct.ss
index a76542f7b9..a092f2fa5d 100644
--- a/collects/scheme/private/define-struct.ss
+++ b/collects/scheme/private/define-struct.ss
@@ -11,7 +11,32 @@
 
   (#%provide define-struct*
              define-struct/derived
-             struct-field-index)
+             struct-field-index
+             (for-syntax 
+	      (rename checked-struct-info-rec? checked-struct-info?)))
+  
+  (define-values-for-syntax
+    (struct:checked-struct-info 
+     make-checked-struct-info 
+     checked-struct-info-rec?
+     checked-struct-info-ref
+     checked-struct-info-set!)
+    (make-struct-type 'struct-info struct:struct-info
+                      0 0 #f
+                      null (current-inspector)
+                      (lambda (v stx)
+                        (raise-syntax-error
+                         #f
+                         "identifier for static struct-type information cannot be used as an expression"
+                         stx))
+                      null
+                      (lambda (proc info)
+                        (if (and (procedure? proc)
+                                 (procedure-arity-includes? proc 0))
+                            proc
+                            (raise-type-error 'make-struct-info
+                                              "procedure (arity 0)"
+                                              proc)))))
 
   (define-syntax-parameter struct-field-index
     (lambda (stx)
@@ -249,20 +274,22 @@
                              "bad syntax; expected <id> for structure-type name or (<id> <id>) for name and supertype name"
                              stx
                              #'id)]))])
-         (let ([super-info 
-                (and super-id
-                     (let ([v (syntax-local-value super-id (lambda () #f))])
-                       (if (struct-info? v)
-                           (extract-struct-info v)
-                           (raise-syntax-error
-                            #f
-                            (format "parent struct type not defined~a"
-                                    (if v
-                                        (format " (~a does not name struct type information)"
-                                                (syntax-e super-id))
-                                        ""))
-                            stx
-                            super-id))))])
+         (let-values ([(super-info super-info-checked?)
+		       (if super-id
+			   (let ([v (syntax-local-value super-id (lambda () #f))])
+			     (if (struct-info? v)
+				 (values (extract-struct-info v) (checked-struct-info-rec? v))
+				 (raise-syntax-error
+				  #f
+				  (format "parent struct type not defined~a"
+					  (if v
+					      (format " (~a does not name struct type information)"
+						      (syntax-e super-id))
+					      ""))
+				  stx
+				  super-id)))
+			   ;; if there's no super type, it's like it was checked
+			   (values #f #t))])
            (when (and super-info
                       (not (car super-info)))
              (raise-syntax-error
@@ -397,11 +424,14 @@
                                              (and sel
                                                   (if (syntax-e sel)
                                                       #`(c (quote-syntax #,sel))
-                                                      sel)))])
+                                                      sel)))]
+				  [mk-info (if super-info-checked?
+					       #'make-checked-struct-info
+					       #'make-struct-info)])
                               (quasisyntax/loc stx
                                 (define-syntaxes (#,id)
                                   (let ([c (syntax-local-certifier)])
-                                    (make-struct-info
+                                    (#,mk-info
                                      (lambda ()
                                        (list
                                         (c (quote-syntax #,struct:))
diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl
index f03156860f..9a43b1caa6 100644
--- a/collects/scribblings/reference/struct.scrbl
+++ b/collects/scribblings/reference/struct.scrbl
@@ -534,10 +534,17 @@ type.
 
 @defproc[(struct-info? [v any/c]) boolean?]{
 
-Returns @scheme[#f] if @scheme[v] is either a six-element list with
+Returns @scheme[#t] if @scheme[v] is either a six-element list with
 the correct shape for representing structure-type information, or a
 procedure encapsulated by @scheme[make-struct-info].}
 
+@defproc[(checked-struct-info? [v any/c]) boolean?]{
+
+Returns @scheme[#t] if @scheme[v] is a structure encapsulated by 
+@scheme[make-struct-info] and produced by @scheme[define-struct]. Such
+values may be relied upon to accurately represent a structure and have
+correct super-type information.}
+
 @defproc[(make-struct-info [thunk (-> (and/c struct-info? list?))])
          struct-info?]{