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

87
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)]
[arg (in-syntax named-args)])
(list (syntax-e name) arg)))
(match (resolve (tc-expr/t cl)) (match (resolve (tc-expr/t cl))
[(Union: '()) (ret (Un))] [(Union: '()) (ret (Un))]
[(and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) [(and c (Class: _ inits fields _))
fields _)) (define init-names (map car inits))
(unless (= (length pos-tys) (for ([given-name given-names]
(syntax-length pos-args)) #:unless (memq given-name init-names))
(tc-error/delayed "expected ~a positional arguments, but got ~a"
(length pos-tys) (syntax-length pos-args)))
;; use for, since they might be different lengths in error case
(for ([pa (in-syntax pos-args)]
[pt (in-list pos-tys)])
(tc-expr/check pa (ret pt)))
(for ([n (in-list names)]
#:unless (memq n tnames))
(tc-error/delayed (tc-error/delayed
"unknown named argument ~a for class\nlegal named arguments are ~a" "unknown named argument ~a for class\nlegal named arguments are ~a"
n (stringify tnames))) given-name (stringify init-names)))
(for-each (match-lambda (for ([init inits])
[(list tname tfty opt?) (match-define (list init-name init-type opt?) init)
(define s ;; stx if argument was provided, #f if it was
(dict-ref name-assoc tname ;; not provided (and if mandatory, it errors)
(lambda () (define maybe-stx
(unless opt? (cond [(assq init-name name-assoc) => cadr]
[(not opt?)
(tc-error/delayed "value not provided for named init arg ~a" (tc-error/delayed "value not provided for named init arg ~a"
tname)) init-name)
#f))) #f]
;; Only check the argument if it is provided [else #f]))
(when s (when maybe-stx
(tc-expr/check s (ret tfty)))]) (tc-expr/check maybe-stx (ret init-type))))
tnflds)
(ret (make-Instance c))] (ret (make-Instance c))]
[t [t
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"expected a class value for object creation, got: ~a" t)]))) "expected a class value for object creation, got: ~a" t)]))
;; check-get-field : Syntax Syntax -> TCResult
;; type-check the `get-field` operation on objects
(define (check-get-field meth obj)
(define maybe-meth-sym
(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)]))