From c41a752d1f98e697ec109168c4a2f9470cb4eb33 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 16 Aug 2012 00:26:00 -0700 Subject: [PATCH] Moved object special cases out of tc-app.rkt. original commit: 73bd7da049a2831d6fffac9a81c3d89d43c58975 --- .../typed-racket/typecheck/signatures.rkt | 3 + collects/typed-racket/typecheck/tc-app.rkt | 61 ++-------------- .../typecheck/tc-app/tc-app-objects.rkt | 69 +++++++++++++++++++ .../typed-racket/typecheck/typechecker.rkt | 4 +- 4 files changed, 80 insertions(+), 57 deletions(-) create mode 100644 collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index d7a64010..6b2035e4 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -46,6 +46,9 @@ (define-signature tc-app-keywords^ ([cond-contracted tc/app-keywords (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) +(define-signature tc-app-objects^ + ([cond-contracted tc/app-objects (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) + (define-signature tc-apply^ ([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)])) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index a8fabd84..6527d82b 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -9,7 +9,6 @@ ;; fixme - don't need to be bound in this phase - only to make tests work racket/bool racket/unsafe/ops - (only-in racket/private/class-internal do-make-object) (only-in syntax/location module-name-fixup) ;; end fixme (for-syntax syntax/parse racket/base (utils tc-utils)) @@ -24,11 +23,12 @@ (for-template racket/unsafe/ops racket/fixnum racket/flonum "internal-forms.rkt" racket/base racket/bool '#%paramz - (only-in racket/private/class-internal do-make-object) + (only-in syntax/location module-name-fixup))) (import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-keywords^ - tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^) + tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^ + tc-app-objects^) (export tc-app^) @@ -78,51 +78,6 @@ [(_ _) (ret -Boolean)])) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Objects - -;; do-make-object now takes blame as its first argument, which isn't checked -;; (it's just an s-expression) -(define (check-do-make-object b cl pos-args names named-args) - (let* ([names (map syntax-e (syntax->list names))] - [name-assoc (map list names (syntax->list 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) - (length (syntax->list pos-args))) - (tc-error/delayed "expected ~a positional arguments, but got ~a" - (length pos-tys) (length (syntax->list 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 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?) - (let ([s (cond [(assq tname name-assoc) => cadr] - [(not opt?) - (tc-error/delayed "value not provided for named init arg ~a" - tname) - #f] - [else #f])]) - (if s - ;; this argument was present - (tc-expr/check s (ret tfty)) - ;; this argument wasn't provided, and was optional - #f))]) - tnflds) - (ret (make-Instance c))] - [(tc-result1: t) - (tc-error/expr #:return (ret (Un)) - "expected a class value for object creation, got: ~a" t)])))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; let loop @@ -189,10 +144,11 @@ (tc/app-apply form expected) (tc/app-values form expected) (tc/app-keywords form expected) + (tc/app-objects form expected) (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote not false? list - do-make-object module-name-fixup cons + module-name-fixup cons extend-parameterization) ;; bail out immediately if we have one of these [(#%plain-app rator:special-op . rands) (tc/app/regular form expected)] @@ -250,13 +206,6 @@ ;; (quote-module-name) originally. [(#%plain-app module-name-fixup src path) (ret Univ)] - ;; special cases for classes - [(#%plain-app do-make-object b cl - (#%plain-app list . pos-args) - (#%plain-app list (#%plain-app cons 'names named-args) ...)) - (check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))] - [(#%plain-app do-make-object args ...) - (int-err "unexpected arguments to do-make-object")] ;; special case for `delay' [(#%plain-app mp1 diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt new file mode 100644 index 00000000..17493425 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -0,0 +1,69 @@ +#lang racket/unit + +(require "../../utils/utils.rkt" + syntax/parse racket/match unstable/sequence + (typecheck signatures tc-app-helper tc-funapp check-below) + (types abbrev union utils) + (rep type-rep) + (utils tc-utils) + + (for-template racket/base)) + + +(import tc-expr^) +(export tc-app-objects^) + +(define (tc/app-objects form expected) + (syntax-parse form + #:literals (#%plain-app list cons quote) + [(#%plain-app dmo b cl + (#%plain-app list . pos-args) + (#%plain-app list (#%plain-app cons (quote names) named-args) ...)) + #:declare dmo (id-from 'do-make-object 'racket/private/class-internal) + (check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))] + [(#%plain-app dmo . args) + #:declare dmo (id-from 'do-make-object 'racket/private/class-internal) + (int-err "unexpected arguments to do-make-object")] + [_ #f])) + +;; do-make-object now takes blame as its first argument, which isn't checked +;; (it's just an s-expression) +(define (check-do-make-object b cl pos-args names named-args) + (let* ([names (map syntax-e (syntax->list names))] + [name-assoc (map list names (syntax->list 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) + (length (syntax->list pos-args))) + (tc-error/delayed "expected ~a positional arguments, but got ~a" + (length pos-tys) (length (syntax->list 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 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?) + (let ([s (cond [(assq tname name-assoc) => cadr] + [(not opt?) + (tc-error/delayed "value not provided for named init arg ~a" + tname) + #f] + [else #f])]) + (if s + ;; this argument was present + (tc-expr/check s (ret tfty)) + ;; this argument wasn't provided, and was optional + #f))]) + tnflds) + (ret (make-Instance c))] + [(tc-result1: t) + (tc-error/expr #:return (ret (Un)) + "expected a class value for object creation, got: ~a" t)])))) diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index ac00248d..77f4ce55 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -10,6 +10,7 @@ "tc-app/tc-app-hetero.rkt" "tc-app/tc-app-keywords.rkt" "tc-app/tc-app-list.rkt" + "tc-app/tc-app-objects.rkt" "tc-app/tc-app-values.rkt" "signatures.rkt" "tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt" @@ -20,4 +21,5 @@ (define-values/invoke-unit/infer (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@ - tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@)) + tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@ + tc-app-objects@))