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

Remove unnecessary loop in tc-app-objects.

Browse Source 
original commit: 7c87a975a6fc28c0d395d0d6144467ad0bd00f00
This commit is contained in:
Eric Dobson 2013-05-25 14:32:11 -07:00
parent 032fffb911
commit ffa2c55dc9
1 changed files with 34 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -6,7 +6,7 @@
syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax
syntax/parse/experimental/reflect racket/dict
(typecheck signatures tc-funapp)
(types abbrev union utils)
(types abbrev resolve union utils)
(rep type-rep)
(utils tc-utils)
@ -33,38 +33,36 @@
(define (check-do-make-object b cl pos-args names named-args)
(let* ([names (stx-map syntax-e names)]
[name-assoc (stx-map cons names named-args)])
(let loop ([t (tc-expr cl)])
(match t
[(tc-result1: (? Mu? t*)) (loop (ret (unfold t*)))]
[(tc-result1: (Union: '())) (ret (Un))]
[(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
(unless (= (length pos-tys)
(syntax-length pos-args))
(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
"unknown named argument ~a for class\nlegal named arguments are ~a"
n (stringify tnames)))
(for-each (match-lambda
[(list tname tfty opt?)
(define s
(dict-ref name-assoc tname
(lambda ()
(unless opt?
(tc-error/delayed "value not provided for named init arg ~a"
tname))
#f)))
;; Only check the argument if it is provided
(when s
(tc-expr/check s (ret tfty)))])
tnflds)
(ret (make-Instance c))]
[(tc-result1: t)
(tc-error/expr #:return (ret (Un))
"expected a class value for object creation, got: ~a" t)]))))
(match (resolve (tc-expr/t cl))
[(Union: '()) (ret (Un))]
[(and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))
(unless (= (length pos-tys)
(syntax-length pos-args))
(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
"unknown named argument ~a for class\nlegal named arguments are ~a"
n (stringify tnames)))
(for-each (match-lambda
[(list tname tfty opt?)
(define s
(dict-ref name-assoc tname
(lambda ()
(unless opt?
(tc-error/delayed "value not provided for named init arg ~a"
tname))
#f)))
;; Only check the argument if it is provided
(when s
(tc-expr/check s (ret tfty)))])
tnflds)
(ret (make-Instance c))]
[t
(tc-error/expr #:return (ret (Un))
"expected a class value for object creation, got: ~a" t)])))