diff --git a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl index 718f19bf89..8441728d87 100644 --- a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl +++ b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl @@ -24,6 +24,8 @@ (code:line #:property prop-expr val-expr) (code:line #:transparent) (code:line #:prefab) + (code:line #:name name-id) + (code:line #:extra-name name-id) (code:line #:constructor-name constructor-id) (code:line #:extra-constructor-name constructor-id) (code:line #:reflection-name symbol-expr) @@ -54,23 +56,24 @@ to @math{4+2n} names: @math{m} is the number of @racket[field]s that do not include an @racket[#:auto] option.} - @item{@racket[id], a @tech{transformer} binding that encapsulates + @item{@racket[name-id] (which defaults to @racket[id]), + a @tech{transformer} binding that encapsulates information about the structure type declaration. This binding is used to define subtypes, and it also works with the @racket[shared] and @racket[match] forms. For detailed - information about the binding of @racket[id], see + information about the binding of @racket[name-id], see @secref["structinfo"]. - The @racket[constructor-id] and @racket[id] can be the same, in - which case @racket[id] performs both roles. In that case, the - expansion of @racket[id] as an expression produces an otherwise + The @racket[constructor-id] and @racket[name-id] can be the same, in + which case @racket[name-id] performs both roles. In that case, the + expansion of @racket[name-id] as an expression produces an otherwise inaccessible identifier that is bound to the constructor procedure; the expanded identifier has a @racket['constructor-for] property whose value is an identifier - that is @racket[free-identifier=?] to @racket[id] as well as + that is @racket[free-identifier=?] to @racket[name-id] as well as a syntax property accessible via @racket[syntax-procedure-alias-property] with an identifier - that is @racket[free-identifier=?] to @racket[id].} + that is @racket[free-identifier=?] to @racket[name-id].} @item{@racket[id]@racketidfont{?}, a @deftech{predicate} procedure that returns @racket[#t] for instances of the @tech{structure @@ -95,7 +98,7 @@ to @math{4+2n} names: ] If @racket[super-id] is provided, it must have a transformer binding -of the same sort bound to @racket[id] (see @secref["structinfo"]), +of the same sort bound to @racket[name-id] (see @secref["structinfo"]), and it specifies a supertype for the structure type. Alternately, the @racket[#:super] option can be used to specify an expression that must produce a @tech{structure type descriptor}. See @@ -163,8 +166,20 @@ must also be a @tech{prefab} structure type. (prefab-point? #s(prefab-point 1 2)) ] +If @racket[name-id] is supplied via @racket[#:extra-name] and it is +not @racket[id], then both @racket[name-id] and @racket[id] are bound +to information about the structure type. Only one of +@racket[#:extra-name] and @racket[#:name] can be provided within a +@racket[struct] form. + +@examples[#:eval posn-eval + (struct ghost (color name) #:prefab #:extra-name GHOST) + (match (ghost 'red 'blinky) + [(GHOST c n) c]) +] + If @racket[constructor-id] is supplied, then the @tech{transformer} -binding of @racket[id] records @racket[constructor-id] as the +binding of @racket[name-id] records @racket[constructor-id] as the constructor binding; as a result, for example, @racket[struct-out] includes @racket[constructor-id] as an export. If @racket[constructor-id] is supplied via @@ -172,7 +187,7 @@ includes @racket[constructor-id] as an export. If @racket[object-name] on the constructor produces the symbolic form of @racket[id] rather than @racket[constructor-id]. If @racket[constructor-id] is supplied via @racket[#:constructor-name] -and it is not the same as @racket[id], then @racket[id] does not serve +and it is not the same as @racket[name-id], then @racket[name-id] does not serve as a constructor, and @racket[object-name] on the constructor produces the symbolic form of @racket[constructor-id]. Only one of @racket[#:extra-constructor-name] and @racket[#:constructor-name] @@ -217,7 +232,8 @@ and expressions may also appear in @racket[method-defs]. ] If the @racket[#:omit-define-syntaxes] option is supplied, then -@racket[id] is not bound as a transformer. If the +@racket[name-id] (and @racket[id], if @racket[#:extra-name] is specified]) +is not bound as a transformer. If the @racket[#:omit-define-values] option is supplied, then none of the usual variables are bound, but @racket[id] is bound. If both are supplied, then the @racket[struct] form is equivalent to diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index 72a66fac29..b5502da8ff 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -1142,6 +1142,28 @@ (test #t struct? (make-prefab-struct '(foo 5 (1 #f) #(1) bar 2 #()) 1 2 3 4 5 6 7 8)) (test #t struct? (make-prefab-struct '(foo 5 (1 #f) #(1) bar 0 #()) 1 2 3 4 5 6)) +;; ---------------------------------------- +;; Check `#:name` and `#:extra-name`: + +(let () + (struct ghost (color name) #:extra-name GHOST) + (test 'blinky ghost-name (ghost 'red 'blinky)) + (struct running-ghost GHOST (edible?)) + (test 'blinky ghost-name (running-ghost 'red 'blinky #f))) + +(let () + (struct ghost (color name) #:name GHOST) + (struct running-ghost GHOST (edible?)) + (test 'blinky ghost-name (running-ghost 'red 'blinky #f))) + +(syntax-test #'(struct ghost (color name) #:name gHoSt #:extra-name GHOST)) + +(struct ghost (color name) #:name GHOST) +(test #t procedure? ghost) +(test #t ghost? (ghost 'red 'blinky)) +(test 'blinky ghost-name (struct-copy GHOST (ghost 'red 'blinky))) +(syntax-test #'GHOST) + ;; ---------------------------------------- (report-errs) diff --git a/racket/collects/racket/private/define-struct.rkt b/racket/collects/racket/private/define-struct.rkt index 9a8a80be04..c348298dd2 100644 --- a/racket/collects/racket/private/define-struct.rkt +++ b/racket/collects/racket/private/define-struct.rkt @@ -236,8 +236,10 @@ (#:mutable . #f) (#:guard . #f) (#:constructor-name . #f) - (#:reflection-name . #f) (#:only-constructor? . #f) + (#:reflection-name . #f) + (#:name . #f) + (#:only-name? . #f) (#:omit-define-values . #f) (#:omit-define-syntaxes . #f))] [nongen? #f]) @@ -329,6 +331,18 @@ '#:only-constructor? (eq? '#:constructor-name (syntax-e (car p)))) nongen?)] + [(or (eq? '#:name (syntax-e (car p))) + (eq? '#:extra-name (syntax-e (car p)))) + (check-exprs 1 p "identifier") + (when (lookup config '#:name) + (bad "multiple" "#:name or #:extra-name" "s" (car p))) + (unless (identifier? (cadr p)) + (bad "need an identifier after" (car p) "" (cadr p))) + (loop (cddr p) + (extend-config (extend-config config '#:name (cadr p)) + '#:only-name? + (eq? '#:name (syntax-e (car p)))) + nongen?)] [(eq? '#:reflection-name (syntax-e (car p))) (check-exprs 1 p "expression") (when (lookup config '#:reflection-name) @@ -433,7 +447,8 @@ (loop (cdr fields) (cdr field-stxes) #f)]))]) (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? reflect-name-expr mutable? - omit-define-values? omit-define-syntaxes?) + omit-define-values? omit-define-syntaxes? + info-name name-only?) (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)]) (values (lookup config '#:inspector) (lookup config '#:super) @@ -445,9 +460,14 @@ (lookup config '#:reflection-name) (lookup config '#:mutable) (lookup config '#:omit-define-values) - (lookup config '#:omit-define-syntaxes)))] + (lookup config '#:omit-define-syntaxes) + (lookup config '#:name) + (lookup config '#:only-name?)))] [(self-ctor?) - (and ctor-name (bound-identifier=? id ctor-name))] + (and ctor-name (or (and (not name-only?) + (bound-identifier=? id ctor-name)) + (and info-name + (bound-identifier=? info-name ctor-name))))] [(name-as-ctor?) (or self-ctor? (not ctor-only?))]) (when mutable? (for-each (lambda (f f-stx) @@ -569,7 +589,7 @@ #f)) sets))) - (let ([run-time-defns + (let* ([run-time-defns (lambda () (quasisyntax/loc stx (define-values (#,struct: #,make- #,? #,@sels #,@sets) @@ -620,7 +640,7 @@ (cons #`(make-struct-field-mutator -set! #,i '#,(field-id (car fields))) (loop (add1 i) (cdr fields)))))))))))] [compile-time-defns - (lambda () + (lambda (body-only?) (let* ([protect (lambda (sel) (and sel (if (syntax-e sel) @@ -640,59 +660,70 @@ #'make-self-ctor-struct-info (if include-autos? #'make-struct-auto-info - #'make-struct-info)))]) - (quasisyntax/loc stx - (define-syntaxes (#,id) - (#,mk-info - (lambda () - (list - (quote-syntax #,(prune struct:)) - (quote-syntax #,(prune (if (and ctor-name self-ctor?) - id - make-))) - (quote-syntax #,(prune ?)) - (list - #,@(map protect (reverse sels)) - #,@(if super-info - (map protect (list-ref super-info 3)) - (if super-expr - '(#f) - null))) - (list - #,@(reverse - (let loop ([fields fields][sets sets]) - (cond - [(null? fields) null] - [(not (or mutable? (field-mutable? (car fields)))) - (cons #f (loop (cdr fields) sets))] - [else - (cons (protect (car sets)) - (loop (cdr fields) (cdr sets)))]))) - #,@(if super-info - (map protect (list-ref super-info 4)) - (if super-expr - '(#f) - null))) - #,(if super-id - (protect super-id) - (if super-expr - #f - #t)))) - #,@(if include-autos? - (list #`(list (list #,@(map protect - (list-tail sels (- (length sels) auto-count))) - #,@(if super-autos - (map protect (car super-autos)) - null)) - (list #,@(map protect - (list-tail sets (max 0 (- (length sets) auto-count)))) - #,@(if super-autos - (map protect (cadr super-autos)) - null)))) - null) - #,@(if name-as-ctor? - (list #`(lambda () (quote-syntax #,make-))) - null))))))]) + #'make-struct-info)))] + [define-syntax-body + #`(#,mk-info + (lambda () + (list + (quote-syntax #,(prune struct:)) + (quote-syntax #,(prune (if (and ctor-name self-ctor?) + id + make-))) + (quote-syntax #,(prune ?)) + (list + #,@(map protect (reverse sels)) + #,@(if super-info + (map protect (list-ref super-info 3)) + (if super-expr + '(#f) + null))) + (list + #,@(reverse + (let loop ([fields fields][sets sets]) + (cond + [(null? fields) null] + [(not (or mutable? (field-mutable? (car fields)))) + (cons #f (loop (cdr fields) sets))] + [else + (cons (protect (car sets)) + (loop (cdr fields) (cdr sets)))]))) + #,@(if super-info + (map protect (list-ref super-info 4)) + (if super-expr + '(#f) + null))) + #,(if super-id + (protect super-id) + (if super-expr + #f + #t)))) + #,@(if include-autos? + (list #`(list (list #,@(map protect + (list-tail sels (- (length sels) auto-count))) + #,@(if super-autos + (map protect (car super-autos)) + null)) + (list #,@(map protect + (list-tail sets (max 0 (- (length sets) auto-count)))) + #,@(if super-autos + (map protect (cadr super-autos)) + null)))) + null) + #,@(if name-as-ctor? + (list #`(lambda () (quote-syntax #,make-))) + null))]) + (if body-only? + define-syntax-body + (quasisyntax/loc stx + (define-syntaxes (#,(if name-only? info-name id)) + #,define-syntax-body)))))] + [extra-compile-time-defs + (lambda () + (cond + [(and info-name (not name-only?)) + ; reuse existing value + (list #`(define-syntaxes (#,info-name) (syntax-local-value #'#,id)))] + [else null]))]) (let ([result (cond [(and (not omit-define-values?) (not omit-define-syntaxes?)) @@ -704,16 +735,22 @@ ;; in the body of a property value that is a procedure) #`(begin (define-syntaxes (#,struct: #,make- #,? #,@sels #,@sets) (values)) - #,(compile-time-defns) + #,(compile-time-defns #f) + #,@(extra-compile-time-defs) #,(run-time-defns)) ;; Other contexts: order should't matter: #`(begin #,(run-time-defns) - #,(compile-time-defns)))] + #,(compile-time-defns #f) + #,@(extra-compile-time-defs)))] [omit-define-syntaxes? - (run-time-defns)] + #`(begin + #,(run-time-defns) + #,@(extra-compile-time-defs))] [omit-define-values? - (compile-time-defns)] + #`(begin + #,(compile-time-defns #f) + #,@(extra-compile-time-defs))] [else #'(begin)])]) (syntax-protect (syntax-property