diff --git a/collects/scheme/private/struct-info.ss b/collects/scheme/private/struct-info.ss index 8ccef0325c..067feef6cb 100644 --- a/collects/scheme/private/struct-info.ss +++ b/collects/scheme/private/struct-info.ss @@ -8,7 +8,18 @@ (#%provide make-struct-info struct-info? extract-struct-info - struct:struct-info) + struct:struct-info + prop:struct-info) + + (define-values (prop:struct-info has-struct-info-prop? struct-info-prop-ref) + (make-struct-type-property 'struct-info + (lambda (v type-info) + (if (and (procedure? v) + (procedure-arity-includes? v 1)) + v + (raise-type-error 'guard-for-prop:struct-info + "procedure (arity 1)" + v))))) (define-values (struct:struct-info make-struct-info struct-info-rec? struct-info-ref struct-info-set!) @@ -31,21 +42,34 @@ (define-values (extract-struct-info) (lambda (si) - (if (struct-info-rec? si) - (let ([p (struct-info-ref si 0)]) - (let ([v (p)]) - (if (struct-declaration-info? v) - v - (error 'extract-struct-info - "struct-info procedure result not properly formed: ~e" - v)))) - (if (set!-transformer? si) - (extract-struct-info (set!-transformer-procedure si)) - si)))) + (cond + [(struct-info-rec? si) + (let ([p (struct-info-ref si 0)]) + (let ([v (p)]) + (if (struct-declaration-info? v) + v + (error 'extract-struct-info + "struct-info procedure result not properly formed: ~e" + v))))] + [(has-struct-info-prop? si) + (let ([v ((struct-info-prop-ref si) si)]) + (if (struct-declaration-info? v) + v + (error 'extract-struct-info + "prop:struct-info procedure result not properly formed: ~e" + v)))] + [(set!-transformer? si) + (extract-struct-info (set!-transformer-procedure si))] + [(struct-declaration-info? si) si] + [else (raise-type-error 'extract-struct-info + "struct-info" + si)]))) (define-values (struct-info?) (lambda (si) (or (struct-info-rec? si) + (and (has-struct-info-prop? si) + (not (struct-type? si))) (struct-declaration-info? si) (and (set!-transformer? si) (struct-info-rec? (set!-transformer-procedure si)))))) diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index b2191d06ab..951c6d9aab 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -318,7 +318,7 @@ Creates a new structure type property and returns three values: If the optional @scheme[guard] is supplied as a procedure, it is called by @scheme[make-struct-type] before attaching the property to a -new structure type. The @scheme[guard-proc] must accept two arguments: +new structure type. The @scheme[guard] must accept two arguments: a value for the property supplied to @scheme[make-struct-type], and a list containing information about the new structure type. The list contains the values that @scheme[struct-type-info] would return for @@ -596,14 +596,17 @@ encapsulated procedure must return): ] -Instead of this direct representation, the representation can -be a structure created by @scheme[make-struct-info] (or an instance of -a subtype of @scheme[struct:struct-info]), which encapsulates a +Instead of this direct representation, the representation can be a +structure created by @scheme[make-struct-info] (or an instance of a +subtype of @scheme[struct:struct-info]), which encapsulates a procedure that takes no arguments and returns a list of six -elements. Finally, the representation can be an instance of a -structure type derived from @scheme[struct:struct-info] that also -implements @scheme[prop:procedure], and where the instance is further -is wrapped by @scheme[make-set!-transformer]. +elements. Alternately, the representation can be a structure whose +type has the @scheme[prop:struct-info] @tech{structure type property}. +Finally, the representation can be an instance of a structure type +derived from @scheme[struct:struct-info] or with the +@scheme[prop:struct-info] property that also implements +@scheme[prop:procedure], and where the instance is further is wrapped +by @scheme[make-set!-transformer]. Use @scheme[struct-info?] to recognize all allowed forms of the information, and use @scheme[extract-struct-info] to obtain a list @@ -626,9 +629,10 @@ type. Returns @scheme[#t] if @scheme[v] is either a six-element list with the correct shape for representing structure-type information, a -procedure encapsulated by @scheme[make-struct-info], or a structure -type derived from @scheme[struct:struct-info] and wrapped with -@scheme[make-set!-transformer].} +procedure encapsulated by @scheme[make-struct-info], a structure with +the @scheme[prop:struct-info] property, or a structure type derived +from @scheme[struct:struct-info] or with @scheme[prop:struct-info] and +wrapped with @scheme[make-set!-transformer].} @defproc[(checked-struct-info? [v any/c]) boolean?]{ @@ -657,6 +661,13 @@ mostly useful for creating structure subtypes. The structure type includes a guard that checks an instance's first field in the same way as @scheme[make-struct-info].} +@defthing[prop:struct-info struct-type-property?]{ + +The @tech{structure type property} for creating new structure types +like @scheme[struct:struct-info]. The property value must a procedure +of one argument that takes an instance structure and returns +structure-type information in list form.} + @; ---------------------------------------------------------------------- @close-eval[struct-eval] diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss index cd2cb095c8..f4ad365af6 100644 --- a/collects/tests/mzscheme/struct.ss +++ b/collects/tests/mzscheme/struct.ss @@ -977,4 +977,32 @@ ;; ---------------------------------------- +(require (for-syntax scheme/struct-info)) + +(let () + (define-struct a (x y)) + (define-syntax foo (make-struct-info + (lambda () + (list #'struct:a #'make-a #'a? + (list #'a-y #'a-x) + (list #f #f) + #f)))) + (define-syntax foo2 (let () + (define-struct si (pred) + #:property + prop:struct-info + (lambda (v) + (list #'struct:a #'make-a (si-pred v) + (list #'a-y #'a-x) + (list #f #f) + #f))) + (make-si #'a?))) + (test (list 1 2) 'match (match (make-a 1 2) + [(struct foo (x y)) (list x y)])) + (test (list 1 2) 'match (match (make-a 1 2) + [(struct foo2 (x y)) (list x y)]))) + + +;; ---------------------------------------- + (report-errs)