diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt index a027cf5e..389942fd 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -4,9 +4,11 @@ "signatures.rkt" "utils.rkt" syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax - racket/dict racket/list + racket/dict + racket/format + racket/list (typecheck signatures) - (types resolve union utils) + (types base-abbrev resolve subtype union utils) (rep type-rep) (utils tc-utils) @@ -36,7 +38,13 @@ (check-get-field #'meth #'obj)) (pattern (gf . args) #:declare gf (id-from 'get-field/proc 'racket/private/class-internal) - (int-err "unexpected arguments to get-field/proc"))) + (int-err "unexpected arguments to get-field/proc")) + (pattern (sf field obj val) + #:declare sf (id-from 'set-field!/proc 'racket/private/class-internal) + (check-set-field #'field #'obj #'val)) + (pattern (sf . args) + #:declare sf (id-from 'set-field!/proc 'racket/private/class-internal) + (int-err "unexpected arguments to set-field!/proc"))) ;; check-do-make-object : Syntax Syntax Listof Listof -> TCResult ;; do-make-object now takes blame as its first argument, which isn't checked @@ -119,3 +127,41 @@ (tc-error/expr #:return (ret (Un)) "expected an object value for get-field, got ~a" t)])) +;; check-set-field : Syntax Syntax Syntax -> TCResult +;; type-check the `set-field!` operation on objects +(define (check-set-field field obj val) + (define maybe-field-sym + (syntax-parse field [(quote f:id) (syntax-e #'f)] [_ #f])) + (unless maybe-field-sym + (tc-error/expr #:return (ret (Un)) + "expected a symbolic field name, but got ~a" field)) + (define obj-type (tc-expr/t obj)) + (define val-type (tc-expr/t val)) + (define (check obj-type) + (match (resolve obj-type) + ;; FIXME: handle unions + [(and ty (Instance: (Class: _ _ (list fields ...) _ _ _))) + (cond [(assq maybe-field-sym fields) => + (λ (field-entry) + (define field-type (cadr field-entry)) + (unless (subtype val-type field-type) + (tc-error/expr/fields "type mismatch" + #:more "set-field! only allowed with compatible types" + "expected" field-type + "given" val-type)) + (ret -Void))] + [else + (tc-error/expr/fields "type mismatch" + #:more (~a "expected an object with field " + maybe-field-sym) + #:return (ret (Un)) + "given" ty)])] + [(Instance: type) + (check (make-Instance (resolve type)))] + [type + (tc-error/expr/fields "type mismatch" + #:more "expected an object value for set-field!" + #:return (ret (Un)) + "given" type)])) + (check obj-type)) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 65db2c46..2e52c2c2 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -2379,6 +2379,20 @@ (define/public (m) (get-field n this)))) (void)) -Void] + ;; Test set-field! + [tc-e (set-field! x + (new (class object% + (super-new) + (field [x : String "foo"]))) + "bar") + -Void] + ;; fails, check set-field! type error + [tc-err (set-field! x + (new (class object% + (super-new) + (field [x : String "foo"]))) + 'not-string) + #:msg #rx"set-field! only allowed with"] ;; fails, field's default value has wrong type [tc-err (class object% (super-new) (: x Symbol)