suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Clean up object init and add support for get-field

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-10 17:10:38 -04:00
parent 72c991c1de
commit 684fabde1b
1 changed files with 64 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -19,53 +19,78 @@
(define-literal-set object-literals #:for-label (list cons)) (define-literal-set object-literals #:for-label (list cons))
;; type-check object initialization and field operations
(define-tc/app-syntax-class (tc/app-objects expected) (define-tc/app-syntax-class (tc/app-objects expected)
#:literal-sets (kernel-literals object-literals) #:literal-sets (kernel-literals object-literals)
(pattern (dmo b cl (pattern (dmo b cl
(#%plain-app list . pos-args) (#%plain-app list . pos-args)
(#%plain-app list (#%plain-app cons (quote names) named-args) ...)) (#%plain-app list (#%plain-app cons (quote names) named-args) ...))
#:declare dmo (id-from 'do-make-object 'racket/private/class-internal) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal)
(check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))) (check-do-make-object #'b #'cl #'(names ...) #'(named-args ...)))
(pattern (dmo . args) (pattern (dmo . args)
#:declare dmo (id-from 'do-make-object 'racket/private/class-internal) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal)
(int-err "unexpected arguments to do-make-object"))) (int-err "unexpected arguments to do-make-object"))
(pattern (gf meth obj)
#:declare gf (id-from 'get-field/proc 'racket/private/class-internal)
(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")))
;; check-do-make-object : Syntax Syntax Listof<Syntax> Listof<Syntax> -> TCResult
;; do-make-object now takes blame as its first argument, which isn't checked ;; do-make-object now takes blame as its first argument, which isn't checked
;; (it's just an s-expression) ;; (it's just an s-expression)
(define (check-do-make-object b cl pos-args names named-args) (define (check-do-make-object b cl names named-args)
(let* ([names (stx-map syntax-e names)] (define given-names (stx-map syntax-e names))
[name-assoc (stx-map cons names named-args)]) (define name-assoc (for/list ([name (in-syntax names)]
(match (resolve (tc-expr/t cl)) [arg (in-syntax named-args)])
[(Union: '()) (ret (Un))] (list (syntax-e name) arg)))
[(and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) (match (resolve (tc-expr/t cl))
fields _)) [(Union: '()) (ret (Un))]
(unless (= (length pos-tys) [(and c (Class: _ inits fields _))
(syntax-length pos-args)) (define init-names (map car inits))
(tc-error/delayed "expected ~a positional arguments, but got ~a" (for ([given-name given-names]
(length pos-tys) (syntax-length pos-args))) #:unless (memq given-name init-names))
;; use for, since they might be different lengths in error case (tc-error/delayed
(for ([pa (in-syntax pos-args)] "unknown named argument ~a for class\nlegal named arguments are ~a"
[pt (in-list pos-tys)]) given-name (stringify init-names)))
(tc-expr/check pa (ret pt))) (for ([init inits])
(for ([n (in-list names)] (match-define (list init-name init-type opt?) init)
#:unless (memq n tnames)) ;; stx if argument was provided, #f if it was
(tc-error/delayed ;; not provided (and if mandatory, it errors)
"unknown named argument ~a for class\nlegal named arguments are ~a" (define maybe-stx
n (stringify tnames))) (cond [(assq init-name name-assoc) => cadr]
(for-each (match-lambda [(not opt?)
[(list tname tfty opt?) (tc-error/delayed "value not provided for named init arg ~a"
(define s init-name)
(dict-ref name-assoc tname #f]
(lambda () [else #f]))
(unless opt? (when maybe-stx
(tc-error/delayed "value not provided for named init arg ~a" (tc-expr/check maybe-stx (ret init-type))))
tname)) (ret (make-Instance c))]
#f))) [t
;; Only check the argument if it is provided (tc-error/expr #:return (ret (Un))
(when s "expected a class value for object creation, got: ~a" t)]))
(tc-expr/check s (ret tfty)))])
tnflds) ;; check-get-field : Syntax Syntax -> TCResult
(ret (make-Instance c))] ;; type-check the `get-field` operation on objects
[t (define (check-get-field meth obj)
(tc-error/expr #:return (ret (Un)) (define maybe-meth-sym
"expected a class value for object creation, got: ~a" t)]))) (syntax-parse meth [(quote m:id) (syntax-e #'m)] [_ #f]))
(define obj-type (tc-expr obj))
(unless maybe-meth-sym
(tc-error/expr #:return (ret (Un))
"expected a symbolic method name, but got ~a" meth))
(match obj-type
;; FIXME: handle unions and mu?
[(tc-result1: (and ty (Instance: (Class: _ _ (list fields ...) _))))
(cond [(assq maybe-meth-sym fields) =>
(λ (field-entry) (ret (cadr field-entry)))]
[else
(tc-error/expr #:return (ret (Un))
"expected an object with field ~a, but got ~a"
maybe-meth-sym ty)])]
[(tc-result1: t)
(tc-error/expr #:return (ret (Un))
"expected an object value for get-field, got ~a" t)]))