fix a bug in typechecking structs' extra constructor names

When the extra constructor name was the same as the structure name,
it would mistakenly introduce two conflict definitions.

The new changes make sure the extra constructor name is not set under the same condition.

Author: capfredf

typed-racket-lib/typed-racket/base-env/prims-contract.rkt

@@ -408,30 +408,7 @@
 
 
 (module self-ctor racket/base
-  (require racket/struct-info)
-
-  ;Copied from racket/private/define-struct
-  ;FIXME when multiple bindings are supported
-  (define (self-ctor-transformer orig stx)
-    (define (transfer-srcloc orig stx)
-      (datum->syntax orig (syntax-e orig) stx orig))
-    (syntax-case stx ()
-      [(self arg ...) (datum->syntax stx
-                                     (cons (syntax-property (transfer-srcloc orig #'self)
-                                                            'constructor-for
-                                                            (syntax-local-introduce #'self))
-                                           (syntax-e (syntax (arg ...))))
-                                     stx
-                                     stx)]
-      [_ (transfer-srcloc orig stx)]))
-  (define make-struct-info-self-ctor
-    (let ()
-      (struct struct-info-self-ctor (id info)
-        #:property prop:procedure
-        (lambda (ins stx)
-          (self-ctor-transformer (struct-info-self-ctor-id ins) stx))
-        #:property prop:struct-info (λ (x) (extract-struct-info (struct-info-self-ctor-info x))))
-      struct-info-self-ctor))
+  (require "../utils/utils.rkt")
   (provide make-struct-info-self-ctor))
 
 (require (submod "." self-ctor))

typed-racket-lib/typed-racket/typecheck/def-binding.rkt

@@ -7,7 +7,7 @@
 (define-struct binding (name) #:transparent)
 (define-struct (def-binding binding) (ty) #:transparent)
 (define-struct (def-stx-binding binding) () #:transparent)
-(define-struct (def-struct-stx-binding def-stx-binding) (static-info constructor-type extra-ctor-name) #:transparent)
+(define-struct (def-struct-stx-binding def-stx-binding) (static-info constructor-type extra-constr-name) #:transparent)
 
 (provide/cond-contract
  (struct binding ([name identifier?]))
@@ -16,4 +16,4 @@
  (struct (def-struct-stx-binding binding) ([name identifier?]
                                            [static-info (or/c #f struct-info?)]
                                            [constructor-type any/c]
-                                           [extra-ctor-name (or/c #f identifier?)])))
+                                           [extra-constr-name (or/c #f identifier?)])))

typed-racket-lib/typed-racket/typecheck/internal-forms.rkt

@@ -101,8 +101,16 @@
            #:attr mutable (attribute options.mutable)
            #:attr prefab (attribute options.prefab)
            #:attr type-only (attribute options.type-only)
-           #:attr maker (or (attribute options.maker) #'nm.nm)
-           #:attr extra-maker (attribute options.extra-maker)
+           #:with maker^ (or (attribute options.maker) #'nm.nm)
+           #:attr maker #'maker^
+           #:attr extra-maker (let ([em (attribute options.extra-maker)]
+                                    [m #'maker^])
+                                ;; extra-maker is only assigned to an id if
+                                ;; options.extra-maker is set and is *not* the
+                                ;; same as maker. Otherwise, it is false.  This
+                                ;; assumption simplifies handling the extra
+                                ;; constructor in tc-structs
+                                (and em (not (free-identifier=? em m)) em))
            #:attr properties (attribute options.prop)))
 
 (define-syntax-class dviu-import/export

typed-racket-lib/typed-racket/typecheck/provide-handling.rkt

@@ -10,7 +10,6 @@
          (types struct-table)
          (utils tc-utils)
          (env env-utils)
-         (base-env type-name-error)
          (for-syntax racket/base)
          (for-template racket/base))
 
@@ -86,16 +85,16 @@
        (match-lambda
          [(def-binding _ ty)
           (mk-value-quad internal-id new-id ty)]
-         [(def-struct-stx-binding _ (? struct-info? si) constr-type extra-ctor-name)
-          (mk-struct-syntax-quad internal-id new-id si constr-type extra-ctor-name)]
+         [(def-struct-stx-binding _ (? struct-info? si) constr-type extra-constr-name)
+          (mk-struct-syntax-quad internal-id new-id si constr-type extra-constr-name)]
          [(def-stx-binding _)
           (mk-syntax-quad internal-id new-id)])]
       ;; otherwise, not defined in this module, not our problem
       [else (mk-ignored-quad internal-id)]))
 
-  ;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type? -> quad/c
+  ;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type? (or/c identifier? #f) -> quad/c
   ;; This handles `(provide s)` where `s` was defined with `(struct s ...)`. 
-  (define (mk-struct-syntax-quad internal-id new-id si constr-type extra-ctor-name)
+  (define (mk-struct-syntax-quad internal-id new-id si constr-type extra-constr-name)
     (match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si))
     (define-values (defns export-defns new-ids aliases)
       (for/lists (defns export-defns new-ids aliases)
@@ -104,7 +103,7 @@
             (mk e)
             (mk-ignored-quad e))))
 
-    (define type-is-constructor? (or (free-identifier=? new-id constr) extra-ctor-name))
+    (define type-is-constructor? (and (or (free-identifier=? new-id constr) extra-constr-name) #t))
     ;; Here, we recursively handle all of the identifiers referenced
     ;; in this static struct info.
     (define-values (constr-defn constr-export-defn constr-new-id constr-aliases)
@@ -122,7 +121,8 @@
 
     (with-syntax* ([id internal-id]
                    [export-id new-id]
-                   [protected-id (freshen-id #'id)])
+                   [protected-id (freshen-id #'id)]
+                   [type-is-constr? type-is-constructor?])
       (values
         #`(begin
             #,constr-defn
@@ -143,10 +143,7 @@
             (define-syntax protected-id
               (let ((info (list type-desc* (syntax export-id) pred* (list accs* ...)
                                 (list #,@(map (lambda (x) #'#f) accs)) super*)))
-                #,(if type-is-constructor?
-                      #'(make-struct-info-self-ctor constr* info)
-                      #'(lambda (stx)
-                          (type-name-error stx)))))
+                (make-struct-info-self-ctor constr* info type-is-constr?)))
             (define-syntax export-id
               (make-rename-transformer #'protected-id)))
         #'export-id

typed-racket-lib/typed-racket/utils/utils.rkt

@@ -109,6 +109,8 @@ at least theoretically.
 (define-requirer base-env base-env-out)
 (define-requirer static-contracts static-contracts-out)
 
+(require "../base-env/type-name-error.rkt")
+
 ;; turn contracts on and off - off by default for performance.
 (provide (for-syntax enable-contracts?)
          provide/cond-contract
@@ -230,14 +232,17 @@ at least theoretically.
     [_ (transfer-srcloc orig stx)]))
 
 
-(define make-struct-info-self-ctor
- (let ()
-  (struct struct-info-self-ctor (id info)
-          #:property prop:procedure
-                     (lambda (ins stx)
-                      (self-ctor-transformer (struct-info-self-ctor-id ins) stx))
-          #:property prop:struct-info (λ (x) (extract-struct-info (struct-info-self-ctor-info x))))
-  struct-info-self-ctor))
+(define (make-struct-info-self-ctor id info [flag #t])
+  (let ()
+    (struct struct-info-self-ctor (id info type-is-constr?)
+      #:property prop:procedure
+      (lambda (ins stx)
+        (if (struct-info-self-ctor-type-is-constr? ins)
+            (self-ctor-transformer (struct-info-self-ctor-id ins) stx)
+            (type-name-error stx)))
+      #:property prop:struct-info (λ (x) (extract-struct-info (struct-info-self-ctor-info x))))
+    (struct-info-self-ctor id info flag)))
+
 
 ;; Listof[A] Listof[B] B -> Listof[B]
 ;; pads out t to be as long as s

typed-racket-test/succeed/struct-constructors.rkt

@@ -0,0 +1,16 @@
+#lang typed/racket/base
+(module a-mod typed/racket/base
+  (provide (except-out (all-defined-out) make-avocado))
+  (struct apple ())
+  (struct orange () #:constructor-name make-orange)
+  (struct kiwi () #:constructor-name kiwi)
+  (struct pear () #:extra-constructor-name pear)
+  (struct avocado () #:type-name Avocado #:constructor-name make-avocado))
+
+(require 'a-mod)
+(apple)
+(make-orange)
+(kiwi)
+(: avocado-id (-> Avocado Avocado))
+(define (avocado-id arg) arg)
+(struct hass-avocado avocado ())