diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index 4b4a4d84..3e832cc8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -341,12 +341,14 @@ (define-values (annotated-methods other-top-level private-fields) (process-class-contents others name-dict)) (define annotated-super (tr:class:super-property #'super #t)) + (define ordered-inits (get-all-init-names clauses)) (define optional-inits (get-optional-inits clauses)) (ignore (tr:class #`(let-values () #,(internal (make-class-name-table (attribute forall.type-variables) private-fields + ordered-inits optional-inits name-dict)) (untyped-class #,annotated-super @@ -450,6 +452,14 @@ #:when optional?) (stx-car id-pair))))) + ;; get-all-init-names : Listof -> Listof + ;; Get a list of all the (internal) init names in order + (define (get-all-init-names clauses) + (flatten + (for/list ([clause clauses] + #:when (init-clause? clause)) + (stx-map stx-car (clause-ids clause))))) + ;; check-unsupported-features : Dict -> Void ;; Check if features that are not supported were used and ;; raise an error if they are present @@ -462,14 +472,19 @@ "unsupported class clause: ~a" (syntax-e form))))) - ;; make-class-name-table : Listof Listof Listof Dict -> Stx + ;; make-class-name-table : Listof Listof Listof + ;; Listof Dict -> Stx ;; construct syntax used by the class type-checker as a reliable source ;; for the member names that are in a given class, plus any type ;; variables that are bound - (define (make-class-name-table foralls private-fields - optional-inits name-dict) + (define (make-class-name-table foralls + private-fields + ordered-inits + optional-inits + name-dict) #`(class-internal (#:forall #,@foralls) + (#:all-inits #,@ordered-inits) (init #,@(dict-ref name-dict #'init '())) (init-field #,@(dict-ref name-dict #'init-field '())) (init-rest #,@(dict-ref name-dict #'init-rest '())) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index fb8dff0c..086eda81 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -74,6 +74,7 @@ (pattern (begin (quote-syntax (class-internal (#:forall type-parameter:id ...) + (#:all-inits all-init-names:id ...) (c:init init-names:name-pair ...) (c:init-field init-field-names:name-pair ...) (c:init-rest (~optional init-rest-name:id)) @@ -89,6 +90,7 @@ (c:pubment pubment-names:name-pair ...))) (#%plain-app values)) #:with type-parameters #'(type-parameter ...) + #:with all-init-internals #'(all-init-names ...) #:with init-internals #'(init-names.internal ...) #:with init-externals #'(init-names.external ...) #:with init-field-internals #'(init-field-names.internal ...) @@ -160,6 +162,7 @@ #:literals (let-values letrec-syntaxes+values #%plain-app) #:attributes (superclass-expr type-parameters + all-init-internals init-internals init-externals init-field-internals init-field-externals init-rest-name @@ -252,9 +255,9 @@ 'optional-inits (syntax->datum #'cls.optional-inits) 'only-init-internals (syntax->datum #'cls.init-internals) 'only-init-names (syntax->datum #'cls.init-externals) - 'init-internals - (set-union (syntax->datum #'cls.init-internals) - (syntax->datum #'cls.init-field-internals)) + ;; the order of these names reflect the order in the class, + ;; so use this list when retaining the order is important + 'init-internals (syntax->datum #'cls.all-init-internals) 'init-rest-name (and (attribute cls.init-rest-name) (syntax-e (attribute cls.init-rest-name))) 'public-internals (syntax->datum #'cls.public-internals) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt index 058b5df5..fd663a9f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt @@ -1251,6 +1251,25 @@ (init-rest [rst : (List Symbol)]))) (make-object c% "wrong")) #:msg #rx"expected: Symbol.*given: String"] + ;; PR 14408, test init-field order + [tc-e (let () + (define c% + (class object% + (super-new) + (init-field [x : String] [y : Symbol]))) + (make-object c% "str" 'sym) + (void)) + -Void] + ;; a variant of the last, but testing that init and init-field + ;; interleave correctly in the class type + [tc-e (let () + (define c% + (class object% + (super-new) + (init [a : 'a]) (init-field [x : 'x] [y : 'y]) (init [b 'b]))) + (make-object c% 'a 'x 'y 'b) + (void)) + -Void] ;; fail, too many positional arguments to superclass [tc-err (class object% (super-make-object "foo")) #:msg #rx"too many positional init arguments"]