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.
This commit is contained in:
Asumu Takikawa
Stevie Strickland
parent
f09867f6a7
commit
f4fb628934
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user