From f4fb628934dc39b5b48f16cdea168ecd75a22eb5 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 26 Apr 2012 15:04:31 -0400 Subject: [PATCH] Changing new to (eventually) concretize interface contract methods. * No-op for now, but will later do more work. * Fix up Typed Racket to handle the new do-make-object. --- collects/racket/private/class-internal.rkt | 47 +++++++++++++++++----- collects/typed-racket/typecheck/tc-app.rkt | 18 +++++---- 2 files changed, 48 insertions(+), 17 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 08d18c3cbf..5510cedd41 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -3,6 +3,7 @@ mzlib/etc racket/contract/base racket/contract/combinator + (only-in racket/contract/region current-contract-region) (only-in racket/contract/private/arrow making-a-method method-contract?) (only-in racket/list remove-duplicates) racket/stxparam @@ -1538,7 +1539,7 @@ (syntax-case stx () [(_ (arg (... ...)) (kw kwarg) (... ...)) (with-syntax ([stx stx]) - (syntax (-instantiate super-go stx (the-obj si_c si_inited? + (syntax (-instantiate super-go stx #f (the-obj si_c si_inited? si_leftovers) (list arg (... ...)) (kw kwarg) (... ...))))]))] @@ -1547,7 +1548,7 @@ (syntax-case stx () [(_ (kw kwarg) (... ...)) (with-syntax ([stx stx]) - (syntax (-instantiate super-go stx (the-obj si_c si_inited? + (syntax (-instantiate super-go stx #f (the-obj si_c si_inited? si_leftovers) null (kw kwarg) (... ...))))]))] @@ -3673,30 +3674,51 @@ An example [else (raise-syntax-error 'new "expected name and value binding" stx pr)])) (syntax->list (syntax (pr ...))))])) +#; (define make-object (lambda (class . args) (do-make-object class args null))) +(define ((make-object/proc blame) class . args) + (do-make-object blame class args null)) + +(define-syntax make-object + (make-set!-transformer + (lambda (stx) + (syntax-case stx () + [id + (identifier? #'id) + (quasisyntax/loc stx + (make-object/proc (current-contract-region)))] + [(_ class arg ...) + (quasisyntax/loc stx + (do-make-object + (current-contract-region) + class (list arg ...) (list)))] + [(_) (raise-syntax-error 'make-object "expected class" stx)])))) + (define-syntax (instantiate stx) (syntax-case stx () [(form class (arg ...) . x) (with-syntax ([orig-stx stx]) (quasisyntax/loc stx - (-instantiate do-make-object orig-stx (class) (list arg ...) . x)))])) + (-instantiate do-make-object orig-stx #t (class) (list arg ...) . x)))])) ;; Helper; used by instantiate and super-instantiate (define-syntax -instantiate (lambda (stx) (syntax-case stx () - [(_ do-make-object orig-stx (maker-arg ...) args (kw arg) ...) + [(_ do-make-object orig-stx first? (maker-arg ...) args (kw arg) ...) (andmap identifier? (syntax->list (syntax (kw ...)))) - (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))]) + (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))] + [(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)]) (syntax/loc stx - (do-make-object maker-arg ... + (do-make-object blame ... + maker-arg ... args (list (cons `kw arg) ...))))] - [(_ super-make-object orig-stx (make-arg ...) args kwarg ...) + [(_ super-make-object orig-stx first? (make-arg ...) args kwarg ...) ;; some kwarg must be bad: (for-each (lambda (kwarg) (syntax-case kwarg () @@ -3720,10 +3742,17 @@ An example (define (alist->sexp alist) (map (lambda (pair) (list (car pair) (cdr pair))) alist)) -(define (do-make-object class by-pos-args named-args) +;; class blame -> class +;; takes a class and concretize interface ctc methods +(define (fetch-concrete-class cls blame) + cls) + +(define (do-make-object blame class by-pos-args named-args) (unless (class? class) (raise-type-error 'instantiate "class" class)) - (let ([o ((class-make-object class))]) + ;; Generate correct class by concretizing methods w/interface ctcs + (let* ([class (fetch-concrete-class class blame)] + [o ((class-make-object class))]) (continue-make-object o class by-pos-args named-args #t) o)) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index 2f5f7c624f..12d2126728 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -9,7 +9,7 @@ ;; fixme - don't need to be bound in this phase - only to make tests work scheme/bool racket/unsafe/ops - (only-in racket/private/class-internal make-object do-make-object) + (only-in racket/private/class-internal do-make-object) (only-in syntax/location module-name-fixup) (only-in '#%kernel [apply k:apply] [reverse k:reverse]) ;; end fixme @@ -26,7 +26,7 @@ racket/unsafe/ops racket/fixnum racket/flonum (only-in '#%kernel [apply k:apply] [reverse k:reverse]) "internal-forms.rkt" scheme/base scheme/bool '#%paramz - (only-in racket/private/class-internal make-object do-make-object) + (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^) @@ -163,7 +163,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Objects -(define (check-do-make-object cl pos-args names named-args) +;; 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)]) @@ -264,7 +266,7 @@ (define (tc/app/internal form expected) (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote - values apply k:apply not false? list list* call-with-values do-make-object make-object module-name-fixup cons + values apply k:apply not false? list list* call-with-values do-make-object module-name-fixup cons map andmap ormap reverse k:reverse extend-parameterization vector-ref unsafe-vector-ref unsafe-vector*-ref vector-set! unsafe-vector-set! unsafe-vector*-set! @@ -598,10 +600,10 @@ [(#%plain-app module-name-fixup src path) (ret Univ)] ;; special cases for classes - [(#%plain-app make-object cl . args) - (check-do-make-object #'cl #'args #'() #'())] - [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...)) - (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))] + [(#%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")] [(#%plain-app (~and map-expr (~literal map)) f arg0 arg ...) (match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...)))) ;; if the argument is a ListDots