diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 14b171809e..f2ea1b5ae2 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -63,6 +63,7 @@ scheme/list (rename racket/base racket:define-struct define-struct) (only racket/base syntax->datum datum->syntax) + (rename racket/base kw-app #%app) racket/struct-info stepper/private/shared) @@ -777,12 +778,13 @@ (string->symbol (string-append (symbol->string (syntax->datum name)) "-of")))]) - (let* ([to-define-names (list* struct: constructor-name predicate-name + (let* ([to-define-names (list* constructor-name predicate-name (if setters? (append getter-names setter-names) getter-names))] - [proc-names (cdr to-define-names)]) - (with-syntax ([compile-info (build-struct-expand-info name fields #f (not setters?) #t null null)] + [proc-names to-define-names]) + (with-syntax ([compile-info (kw-app build-struct-expand-info name fields #f (not setters?) #t null null + #:omit-struct-type? #t)] [(field_/no-loc ...) (map (λ (x) (datum->syntax x (syntax->datum x) #f)) (syntax->list #'(field_ ...)))]) (let-values ([(defn0 bind-names) (wrap-func-definitions diff --git a/collects/racket/private/reqprov.rkt b/collects/racket/private/reqprov.rkt index dc1c9bf272..c664046cf5 100644 --- a/collects/racket/private/reqprov.rkt +++ b/collects/racket/private/reqprov.rkt @@ -868,8 +868,8 @@ (raise-syntax-error #f (if (null? ids) - "no import for structure-type identifier" - (format "multiple imports (~a~a~a~a) for structure-type identifier" + "no binding for structure-type identifier" + (format "multiple bindings (~a~a~a~a) for structure-type identifier" (syntax-e (car ids)) (if (null? (cddr ids)) " and " diff --git a/collects/syntax/scribblings/struct.scrbl b/collects/syntax/scribblings/struct.scrbl index 99c10be798..f792b76567 100644 --- a/collects/syntax/scribblings/struct.scrbl +++ b/collects/syntax/scribblings/struct.scrbl @@ -22,6 +22,7 @@ expression.} @defproc[(build-struct-names [name-id identifier?] [field-ids (listof identifier?)] + [#:constructor-name ctr-name (or/c identifier? #f) #f] [omit-sel? boolean?] [omit-set? boolean?] [src-stx (or/c syntax? false/c) #f]) @@ -33,7 +34,7 @@ field names. The result is a list of identifiers: @itemize[ @item{@schemeidfont{struct:}@scheme[name-id]} - @item{@schemeidfont{make-}@scheme[name-id]} + @item{@scheme[ctr-name], or @schemeidfont{make-}@scheme[name-id] if @racket[ctr-name] is @racket[#f]} @item{@scheme[name-id]@schemeidfont{?}} @item{@scheme[name-id]@schemeidfont{-}@scheme[_field], for each @scheme[_field] in @scheme[field-ids].} @@ -50,6 +51,8 @@ source location to the generated identifiers.} @defproc[(build-struct-generation [name-id identifier?] [field-ids (listof identifier?)] + + [#:constructor-name ctr-name (or/c identifier? #f) #f] [omit-sel? boolean?] [omit-set? boolean?] @@ -66,9 +69,11 @@ the structure type and return values for the identifiers created by S-expression values that are used as the corresponding arguments to @scheme[make-struct-type].} + @defproc[(build-struct-generation* [all-name-ids (listof identifier?)] [name-id identifier?] [field-ids (listof identifier?)] + [#:constructor-name ctr-name (or/c identifier? #f) #f] [omit-sel? boolean?] [omit-set? boolean?] [super-type any/c #f] @@ -81,6 +86,9 @@ Like @scheme[build-struct-generation], but given the names produced by @defproc[(build-struct-expand-info [name-id identifier?] [field-ids (listof identifier?)] + [#:omit-constructor? no-ctr? any/c #f] + [#:constructor-name ctr-name (or/c identifier? #f) #f] + [#:omit-struct-type? no-type? any/c #f] [omit-sel? boolean?] [omit-set? boolean?] [base-name (or/c identifier? boolean?)] @@ -88,14 +96,20 @@ Like @scheme[build-struct-generation], but given the names produced by [base-setters (listof (or/c identifier? false/c))]) any]{ -Takes the same arguments as @scheme[build-struct-names], plus a parent +Takes mostly the same arguments as @scheme[build-struct-names], plus a parent identifier/@scheme[#t]/@scheme[#f] and a list of accessor and mutator identifiers (possibly ending in @scheme[#f]) for a parent type, and generates an S-expression for expansion-time code to be used in the -binding for the structure name. A @scheme[#t] for the -@scheme[base-name] means no super-type, @scheme[#f] means that the -super-type (if any) is unknown, and an identifier indicates the -super-type identifier.} +binding for the structure name. + +If @racket[no-ctr?] is true, then the constructor name is omitted from +the expansion-time information. Similarly, if @racket[no-type?] is +true, then the structure-type name is omitted. + +A @scheme[#t] for the @scheme[base-name] means no super-type, +@scheme[#f] means that the super-type (if any) is unknown, and an +identifier indicates the super-type identifier.} + @defproc[(struct-declaration-info? [v any/c]) boolean?]{ @@ -103,6 +117,7 @@ Returns @scheme[#t] if @scheme[x] has the shape of expansion-time information for structure type declarations, @scheme[#f] otherwise. See @secref[#:doc refman]{structinfo}.} + @defproc[(generate-struct-declaration [orig-stx syntax?] [name-id identifier?] [super-id-or-false (or/c identifier? false/c)] diff --git a/collects/syntax/struct.rkt b/collects/syntax/struct.rkt index 440da1bcfd..e085d4c845 100644 --- a/collects/syntax/struct.rkt +++ b/collects/syntax/struct.rkt @@ -166,13 +166,17 @@ (define build-struct-expand-info (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters #:omit-constructor? [no-ctr? #f] - #:constructor-name [ctr-name #f]) + #:constructor-name [ctr-name #f] + #:omit-struct-type? [no-type? #f]) (let* ([names (build-struct-names name-stx fields omit-sel? omit-set? #:constructor-name ctr-name)] [names (if no-ctr? (list* (car names) #f (cddr names)) + names)] + [names (if no-type? + (cons #f (cdr names)) names)]) (build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters))))