Support pubment and augment methods
This required changes to the type and row representation. I also got rid of the redundancy between Row and Class types. Some other bugs had to be quashed for these changes, such as private methods not actually being type-checked. original commit: eb95264e3f3d04e0427f01f26e19447ad9fe4b12
This commit is contained in:
Asumu Takikawa
parent
e0da126e85
commit
fd9c06e10f
|
|
@ -961,7 +961,7 @@
|
|||
[struct-type? (make-pred-ty (make-StructTypeTop))]
|
||||
|
||||
;; Section 6.2 (Classes)
|
||||
[object% (make-Class #f null null null)]
|
||||
[object% (make-Class #f null null null null)]
|
||||
|
||||
;; Section 9.1
|
||||
[exn:misc:match? (-> Univ B)]
|
||||
|
|
|
|||
|
|
@ -263,7 +263,9 @@
|
|||
(override #,@(dict-ref name-dict #'override '()))
|
||||
(private #,@(dict-ref name-dict #'private '()))
|
||||
(private-field #,@private-fields)
|
||||
(inherit #,@(dict-ref name-dict #'inherit '()))))
|
||||
(inherit #,@(dict-ref name-dict #'inherit '()))
|
||||
(augment #,@(dict-ref name-dict #'augment '()))
|
||||
(pubment #,@(dict-ref name-dict #'pubment '()))))
|
||||
(class #,annotated-super
|
||||
#,@(map clause-stx clauses)
|
||||
#,@(map non-clause-stx annotated-methods)
|
||||
|
|
@ -289,11 +291,12 @@
|
|||
#:literals (define-values super-new)
|
||||
;; if it's a method definition for a declared method, then
|
||||
;; mark it as something to type-check
|
||||
;; FIXME: this needs to track augments, etc.
|
||||
[(define-values (id) . rst)
|
||||
#:when (memf (λ (n) (free-identifier=? #'id n))
|
||||
(append (stx-map stx-car (dict-ref name-dict #'public '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'pubment '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'override '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'augment '()))
|
||||
(dict-ref name-dict #'private '())))
|
||||
(values (cons (non-clause (syntax-property stx
|
||||
'tr:class:method
|
||||
|
|
@ -342,7 +345,8 @@
|
|||
;; set!-transformers to the appropriate accessors, which lets
|
||||
;; us figure out the accessor identifiers.
|
||||
(define (make-locals-table name-dict private-field-names)
|
||||
(define public-names (stx-map stx-car (dict-ref name-dict #'public '())))
|
||||
(define public-names
|
||||
(stx-map stx-car (dict-ref name-dict #'public '())))
|
||||
(define override-names
|
||||
(stx-map stx-car (dict-ref name-dict #'override '())))
|
||||
(define private-names (dict-ref name-dict #'private '()))
|
||||
|
|
@ -353,6 +357,9 @@
|
|||
(stx-map stx-car (dict-ref name-dict #'init '())))
|
||||
(define inherit-names
|
||||
(stx-map stx-car (dict-ref name-dict #'inherit '())))
|
||||
(define augment-names
|
||||
(append (stx-map stx-car (dict-ref name-dict #'pubment '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'augment '()))))
|
||||
(syntax-property
|
||||
#`(let-values ([(#,@public-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx)))
|
||||
|
|
@ -374,7 +381,10 @@
|
|||
inherit-names))]
|
||||
[(#,@override-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx) (super #,stx)))
|
||||
override-names))])
|
||||
override-names))]
|
||||
[(#,@augment-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx)))
|
||||
augment-names))])
|
||||
(void))
|
||||
'tr:class:local-table #t)))
|
||||
|
||||
|
|
|
|||
|
|
@ -91,6 +91,18 @@
|
|||
[(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))]
|
||||
[(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns))
|
||||
(quote ,c) ,(sub b))]
|
||||
[(Class: row inits fields methods augments)
|
||||
;; FIXME: there's probably a better way to do this
|
||||
(define (convert members [inits? #f])
|
||||
(for/list ([m members])
|
||||
`(list (quote ,(car m))
|
||||
,(sub (cadr m))
|
||||
,@(if inits? (cddr m) '()))))
|
||||
`(make-Class ,(sub row)
|
||||
(list ,@(convert inits #t))
|
||||
(list ,@(convert fields))
|
||||
(list ,@(convert methods))
|
||||
(list ,@(convert augments)))]
|
||||
[(arr: dom rng rest drest kws)
|
||||
`(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
|
||||
[(TypeFilter: t p i)
|
||||
|
|
|
|||
|
|
@ -559,10 +559,10 @@
|
|||
|
||||
;;; Utilities for (Class ...) type parsing
|
||||
|
||||
;; process-class-clauses : Option<F> Syntax FieldDict MethodDict
|
||||
;; -> Option<Id> FieldDict MethodDict
|
||||
;; process-class-clauses : Option<F> Syntax FieldDict MethodDict AugmentDict
|
||||
;; -> Option<Id> FieldDict MethodDict AugmentDict
|
||||
;; Merges #:implements class type and the current class clauses appropriately
|
||||
(define (merge-with-parent-type row-var stx fields methods)
|
||||
(define (merge-with-parent-type row-var stx fields methods augments)
|
||||
;; (Listof Symbol) Dict Dict String -> (Values Dict Dict)
|
||||
;; check for duplicates in a class clause
|
||||
(define (check-duplicate-clause names super-names types super-types err-msg)
|
||||
|
|
@ -584,19 +584,22 @@
|
|||
(define parent-type (parse-type stx))
|
||||
(define (match-parent-type parent-type)
|
||||
(match parent-type
|
||||
[(Class: row-var _ fields methods)
|
||||
(values row-var fields methods)]
|
||||
[(Class: row-var _ fields methods augments)
|
||||
(values row-var fields methods augments)]
|
||||
[(? Mu?)
|
||||
(match-parent-type (unfold parent-type))]
|
||||
[_ (tc-error "expected a class type for #:implements clause, got ~a"
|
||||
parent-type)]))
|
||||
(define-values (super-row-var super-fields super-methods)
|
||||
(define-values (super-row-var super-fields
|
||||
super-methods super-augments)
|
||||
(match-parent-type parent-type))
|
||||
|
||||
(match-define (list (list field-names _) ...) fields)
|
||||
(match-define (list (list method-names _) ...) methods)
|
||||
(match-define (list (list augment-names _) ...) augments)
|
||||
(match-define (list (list super-field-names _) ...) super-fields)
|
||||
(match-define (list (list super-method-names _) ...) super-methods)
|
||||
(match-define (list (list super-augment-names _) ...) super-augments)
|
||||
|
||||
;; if any duplicates are found between this class and the superclass
|
||||
;; type, then raise an error
|
||||
|
|
@ -606,10 +609,15 @@
|
|||
fields super-fields
|
||||
"field or init-field name ~a conflicts with #:implements clause"))
|
||||
(define-values (checked-methods checked-super-methods)
|
||||
(check-duplicate-clause
|
||||
method-names super-method-names
|
||||
methods super-methods
|
||||
"method name ~a conflicts with #:implements clause"))
|
||||
(check-duplicate-clause
|
||||
method-names super-method-names
|
||||
methods super-methods
|
||||
"method name ~a conflicts with #:implements clause"))
|
||||
(define-values (checked-augments checked-super-augments)
|
||||
(check-duplicate-clause
|
||||
augment-names super-augment-names
|
||||
augments super-augments
|
||||
"augmentable method name ~a conflicts with #:implements clause"))
|
||||
|
||||
;; it is an error for both the extending type and extended type
|
||||
;; to have row variables
|
||||
|
|
@ -620,7 +628,17 @@
|
|||
;; then append the super types if there were no errors
|
||||
(define merged-fields (append checked-super-fields checked-fields))
|
||||
(define merged-methods (append checked-super-methods checked-methods))
|
||||
(values (or row-var super-row-var) merged-fields merged-methods))
|
||||
(define merged-augments (append checked-super-augments checked-augments))
|
||||
|
||||
;; make sure augments and methods are disjoint
|
||||
(define maybe-dup (check-duplicate (append (dict-keys merged-methods)
|
||||
(dict-keys merged-augments))))
|
||||
(when maybe-dup
|
||||
(tc-error (~a "method name " maybe-dup " conflicts with"
|
||||
" another method name or augmentable method name")))
|
||||
|
||||
(values (or row-var super-row-var) merged-fields
|
||||
merged-methods merged-augments))
|
||||
|
||||
;; Syntax -> Type
|
||||
;; Parse a (Object ...) type
|
||||
|
|
@ -635,7 +653,7 @@
|
|||
(define methods (map list
|
||||
(stx-map syntax-e #'clause.method-names)
|
||||
(stx-map parse-type #'clause.method-types)))
|
||||
(make-Instance (make-Class #f null fields methods))]))
|
||||
(make-Instance (make-Class #f null fields methods null))]))
|
||||
|
||||
;; Syntax -> Type
|
||||
;; Parse a (Class ...) type
|
||||
|
|
@ -648,27 +666,31 @@
|
|||
(define given-inits (attribute clause.inits))
|
||||
(define given-fields (attribute clause.fields))
|
||||
(define given-methods (attribute clause.methods))
|
||||
(define given-augments (attribute clause.augments))
|
||||
(define given-row-var
|
||||
(and (attribute clause.row-var)
|
||||
(parse-type (attribute clause.row-var))))
|
||||
|
||||
;; merge with all given parent types, erroring if needed
|
||||
(define-values (row-var fields methods)
|
||||
(define-values (row-var fields methods augments)
|
||||
(for/fold ([row-var given-row-var]
|
||||
[fields given-fields]
|
||||
[methods given-methods])
|
||||
[methods given-methods]
|
||||
[augments given-augments])
|
||||
([parent-type parent-types])
|
||||
(merge-with-parent-type row-var parent-type fields methods)))
|
||||
(merge-with-parent-type row-var parent-type fields
|
||||
methods augments)))
|
||||
|
||||
;; check constraints on row var for consistency with class
|
||||
(when (and row-var (has-row-constraints? (F-n row-var)))
|
||||
(define constraints (lookup-row-constraints (F-n row-var)))
|
||||
(check-constraints given-inits (car constraints))
|
||||
(check-constraints fields (cadr constraints))
|
||||
(check-constraints methods (caddr constraints)))
|
||||
(check-constraints methods (caddr constraints))
|
||||
(check-constraints augments (cadddr constraints)))
|
||||
|
||||
(define class-type
|
||||
(make-Class row-var given-inits fields methods))
|
||||
(make-Class row-var given-inits fields methods augments))
|
||||
|
||||
class-type]))
|
||||
|
||||
|
|
|
|||
|
|
@ -289,11 +289,12 @@
|
|||
(recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])]
|
||||
[(Instance: (? Mu? t))
|
||||
(t->sc (make-Instance (resolve-once t)))]
|
||||
[(Instance: (Class: _ _ _ (list (list names functions) ...)))
|
||||
[(Instance: (Class: _ _ _ (list (list names functions) ...) _))
|
||||
(object/sc (map (λ (n sc) (member-spec 'method n sc)) names (map t->sc/method functions)))]
|
||||
[(Class: _ (list (list by-name-inits by-name-init-tys _) ...)
|
||||
fields
|
||||
(list (list names functions) ...))
|
||||
(list (list names functions) ...)
|
||||
_)
|
||||
(class/sc (append
|
||||
(map (λ (n sc) (member-spec 'method n sc))
|
||||
names (map t->sc/method functions))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
remove-dups
|
||||
sub-f sub-o sub-pe
|
||||
(rename-out [Class:* Class:]
|
||||
[*Class make-Class]
|
||||
[Class* make-Class]
|
||||
[Mu:* Mu:]
|
||||
[Poly:* Poly:]
|
||||
[PolyDots:* PolyDots:]
|
||||
|
|
@ -246,7 +246,7 @@
|
|||
;; constraints are row absence constraints, represented
|
||||
;; as a set for each of init, field, methods
|
||||
(def-type PolyRow (constraints body) #:no-provide
|
||||
[#:contract (->i ([constraints (list/c list? list? list?)]
|
||||
[#:contract (->i ([constraints (list/c list? list? list? list?)]
|
||||
[body (scope-depth 1)])
|
||||
(#:syntax [stx (or/c #f syntax?)])
|
||||
[result PolyRow?])]
|
||||
|
|
@ -458,67 +458,51 @@
|
|||
;; A Row used in type instantiation
|
||||
;; For now, this should not appear in user code. It's used
|
||||
;; internally to perform row instantiations
|
||||
;;
|
||||
;; FIXME: should Classes just use this?
|
||||
;;
|
||||
(def-type Row ([inits (listof (list/c symbol? Type/c boolean?))]
|
||||
[fields (listof (list/c symbol? Type/c))]
|
||||
[methods (listof (list/c symbol? Function?))])
|
||||
[methods (listof (list/c symbol? Function?))]
|
||||
[augments (listof (list/c symbol? Function?))])
|
||||
[#:frees (λ (f) (combine-frees
|
||||
(map f (append (map cadr inits)
|
||||
(map cadr fields)
|
||||
(map cadr methods)))))]
|
||||
[#:fold-rhs (match (list inits fields methods)
|
||||
(map cadr methods)
|
||||
(map cadr augments)))))]
|
||||
[#:fold-rhs (match (list inits fields methods augments)
|
||||
[(list
|
||||
(list (list init-names init-tys reqd) ___)
|
||||
(list (list fname fty) ___)
|
||||
(list (list mname mty) ___))
|
||||
(list (list mname mty) ___)
|
||||
(list (list aname aty) ___))
|
||||
(*Row
|
||||
(map list
|
||||
init-names
|
||||
(map type-rec-id init-tys)
|
||||
reqd)
|
||||
(map list fname (map type-rec-id fty))
|
||||
(map list mname (map type-rec-id mty)))])])
|
||||
(map list mname (map type-rec-id mty))
|
||||
(map list aname (map type-rec-id aty)))])])
|
||||
|
||||
;; row : Option<(U F Row)>
|
||||
;; name-inits : (Listof (Tuple Symbol Type Boolean))
|
||||
;; fields : (Listof (Tuple Symbol Type))
|
||||
;; methods : (Listof (Tuple Symbol Function))
|
||||
;; row-ext : Option<(U F B Row)>
|
||||
;; row : Row
|
||||
;;
|
||||
;; interp. The first field represents a row variable.
|
||||
;; The second field represents the named
|
||||
;; initialization argument types.
|
||||
;; The remainder are the types for public fields and
|
||||
;; public methods, respectively.
|
||||
;; interp. The first field represents a row extension
|
||||
;; The second field represents the concrete row
|
||||
;; that the class starts with
|
||||
;;
|
||||
(def-type Class ([row (or/c #f F? B? Row?)]
|
||||
[inits (listof (list/c symbol? Type/c boolean?))]
|
||||
[fields (listof (list/c symbol? Type/c))]
|
||||
[methods (listof (list/c symbol? Function?))])
|
||||
(def-type Class ([row-ext (or/c #f F? B? Row?)]
|
||||
[row Row?])
|
||||
#:no-provide
|
||||
[#:frees (λ (f) (combine-frees
|
||||
;; FIXME: is this correct?
|
||||
`(,@(or (and (F? row) (list (f row)))
|
||||
`(,@(or (and (F? row-ext) (list (f row-ext)))
|
||||
'())
|
||||
,@(map f (append (map cadr inits)
|
||||
(map cadr fields)
|
||||
(map cadr methods))))))]
|
||||
,(f row))))]
|
||||
[#:key 'class]
|
||||
[#:fold-rhs (match (list row inits fields methods)
|
||||
[(list
|
||||
row
|
||||
(list (list init-names init-tys reqd) ___)
|
||||
(list (list fname fty) ___)
|
||||
(list (list mname mty) ___))
|
||||
[#:fold-rhs (match (list row-ext row)
|
||||
[(list row-ext row)
|
||||
(*Class
|
||||
(and row (type-rec-id row))
|
||||
(map list
|
||||
init-names
|
||||
(map type-rec-id init-tys)
|
||||
reqd)
|
||||
(map list fname (map type-rec-id fty))
|
||||
(map list mname (map type-rec-id mty)))])])
|
||||
(and row-ext (type-rec-id row-ext))
|
||||
(type-rec-id row))])])
|
||||
|
||||
;; cls : Class
|
||||
(def-type Instance ([cls Type/c]) [#:key 'instance])
|
||||
|
|
@ -920,6 +904,18 @@
|
|||
(PolyRow-body* fresh-syms t)))
|
||||
(list nps freshp constrp bp)))])))
|
||||
|
||||
;; Class*
|
||||
;; This is a custom constructor for Class types that
|
||||
;; doesn't require writing make-Row everywhere
|
||||
(define/cond-contract (Class* row-var inits fields methods augments)
|
||||
(-> (or/c F? B? Row? #f)
|
||||
(listof (list/c symbol? Type/c boolean?))
|
||||
(listof (list/c symbol? Type/c))
|
||||
(listof (list/c symbol? Function?))
|
||||
(listof (list/c symbol? Function?))
|
||||
Class?)
|
||||
(*Class row-var (*Row inits fields methods augments)))
|
||||
|
||||
;; Class:*
|
||||
;; This match expander replaces the built-in matching with
|
||||
;; a version that will merge the members inside the substituted row
|
||||
|
|
@ -928,25 +924,30 @@
|
|||
;; helper function for the expansion of Class:*
|
||||
;; just does the merging
|
||||
(define (merge-class/row class-type)
|
||||
(define row (Class-row class-type))
|
||||
(define inits (Class-inits class-type))
|
||||
(define fields (Class-fields class-type))
|
||||
(define methods (Class-methods class-type))
|
||||
(define row (Class-row-ext class-type))
|
||||
(define class-row (Class-row class-type))
|
||||
(define inits (Row-inits class-row))
|
||||
(define fields (Row-fields class-row))
|
||||
(define methods (Row-methods class-row))
|
||||
(define augments (Row-augments class-row))
|
||||
(cond [(and row (Row? row))
|
||||
(define row-inits (Row-inits row))
|
||||
(define row-fields (Row-fields row))
|
||||
(define row-methods (Row-methods row))
|
||||
(define row-augments (Row-augments row))
|
||||
(list row
|
||||
(append inits row-inits)
|
||||
(append fields row-fields)
|
||||
(append methods row-methods))]
|
||||
[else (list row inits fields methods)]))
|
||||
(append methods row-methods)
|
||||
(append augments row-augments))]
|
||||
[else (list row inits fields methods augments)]))
|
||||
|
||||
(define-match-expander Class:*
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ row-pat inits-pat fields-pat methods-pat)
|
||||
[(_ row-pat inits-pat fields-pat methods-pat augments-pat)
|
||||
#'(? Class?
|
||||
(app merge-class/row
|
||||
(list row-pat inits-pat fields-pat methods-pat)))])))
|
||||
(list row-pat inits-pat fields-pat
|
||||
methods-pat augments-pat)))])))
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
(require "../utils/utils.rkt"
|
||||
racket/dict
|
||||
racket/format
|
||||
racket/match
|
||||
racket/pretty ;; DEBUG ONLY
|
||||
racket/set
|
||||
|
|
@ -35,7 +36,8 @@
|
|||
(define-syntax-class internal-class-data
|
||||
#:literals (#%plain-app quote-syntax class:-internal begin
|
||||
values c:init c:init-field optional-init c:field
|
||||
c:public c:override c:private c:inherit private-field)
|
||||
c:public c:override c:private c:inherit private-field
|
||||
c:augment c:pubment)
|
||||
(pattern (begin (quote-syntax
|
||||
(class:-internal
|
||||
(c:init init-names:name-pair ...)
|
||||
|
|
@ -46,7 +48,9 @@
|
|||
(c:override override-names:name-pair ...)
|
||||
(c:private privates:id ...)
|
||||
(private-field private-fields:id ...)
|
||||
(c:inherit inherit-names:name-pair ...)))
|
||||
(c:inherit inherit-names:name-pair ...)
|
||||
(c:augment augment-names:name-pair ...)
|
||||
(c:pubment pubment-names:name-pair ...)))
|
||||
(#%plain-app values))
|
||||
#:with init-internals #'(init-names.internal ...)
|
||||
#:with init-externals #'(init-names.external ...)
|
||||
|
|
@ -61,6 +65,10 @@
|
|||
#:with override-externals #'(override-names.external ...)
|
||||
#:with inherit-externals #'(inherit-names.external ...)
|
||||
#:with inherit-internals #'(inherit-names.internal ...)
|
||||
#:with augment-externals #'(augment-names.external ...)
|
||||
#:with augment-internals #'(augment-names.internal ...)
|
||||
#:with pubment-externals #'(pubment-names.external ...)
|
||||
#:with pubment-internals #'(pubment-names.internal ...)
|
||||
#:with private-names #'(privates ...)
|
||||
#:with private-field-names #'(private-fields ...)))
|
||||
|
||||
|
|
@ -119,6 +127,8 @@
|
|||
public-internals public-externals
|
||||
override-internals override-externals
|
||||
inherit-internals inherit-externals
|
||||
augment-internals augment-externals
|
||||
pubment-internals pubment-externals
|
||||
private-names private-field-names
|
||||
make-methods
|
||||
initializer-body
|
||||
|
|
@ -151,7 +161,7 @@
|
|||
(match expected
|
||||
[(tc-result1: (? Mu? type))
|
||||
(check-class form (ret (unfold type)))]
|
||||
[(tc-result1: (and self-class-type (Class: _ _ _ _)))
|
||||
[(tc-result1: (and self-class-type (Class: _ _ _ _ _)))
|
||||
(do-check form #t self-class-type)]
|
||||
[#f (do-check form #f #f)]))
|
||||
|
||||
|
|
@ -167,21 +177,24 @@
|
|||
;; FIXME: maybe should check the property on this expression
|
||||
;; as a sanity check too
|
||||
(define super-type (tc-expr #'cls.superclass-expr))
|
||||
(define-values (super-inits super-fields super-methods)
|
||||
(define-values (super-inits super-fields
|
||||
super-methods super-augments)
|
||||
(match super-type
|
||||
;; FIXME: should handle the case where the super class is
|
||||
;; polymorphic
|
||||
[(tc-result1: (Class: _ super-inits super-fields super-methods))
|
||||
(values super-inits super-fields super-methods)]
|
||||
[(tc-result1: (Class: _ super-inits super-fields
|
||||
super-methods super-augments))
|
||||
(values super-inits super-fields super-methods super-augments)]
|
||||
[(tc-result1: t)
|
||||
(tc-error/expr "expected a superclass but got ~a" t
|
||||
#:stx #'cls.superclass-expr)
|
||||
;; FIXME: is this the right thing to do?
|
||||
(values null null null)]))
|
||||
(values null null null null)]))
|
||||
;; Define sets of names for use later
|
||||
(define super-init-names (list->set (dict-keys super-inits)))
|
||||
(define super-field-names (list->set (dict-keys super-fields)))
|
||||
(define super-method-names (list->set (dict-keys super-methods)))
|
||||
(define super-augment-names (list->set (dict-keys super-augments)))
|
||||
(define this%-init-internals
|
||||
(list->set (append (syntax->datum #'cls.init-internals)
|
||||
(syntax->datum #'cls.init-field-internals))))
|
||||
|
|
@ -189,6 +202,10 @@
|
|||
(list->set (syntax->datum #'cls.public-internals)))
|
||||
(define this%-override-internals
|
||||
(list->set (syntax->datum #'cls.override-internals)))
|
||||
(define this%-pubment-internals
|
||||
(list->set (syntax->datum #'cls.pubment-internals)))
|
||||
(define this%-augment-internals
|
||||
(list->set (syntax->datum #'cls.augment-internals)))
|
||||
(define this%-method-internals
|
||||
(set-union this%-public-internals this%-override-internals))
|
||||
(define this%-field-internals
|
||||
|
|
@ -208,14 +225,22 @@
|
|||
(list->set (syntax->datum #'cls.public-externals)))
|
||||
(define this%-override-names
|
||||
(list->set (syntax->datum #'cls.override-externals)))
|
||||
(define this%-pubment-names
|
||||
(list->set (append (syntax->datum #'cls.pubment-externals))))
|
||||
(define this%-augment-names
|
||||
(list->set (append (syntax->datum #'cls.augment-externals))))
|
||||
(define this%-inherit-names
|
||||
(list->set (syntax->datum #'cls.inherit-externals)))
|
||||
(define this%-private-names
|
||||
(list->set (syntax->datum #'cls.private-names)))
|
||||
(define this%-private-fields
|
||||
(list->set (syntax->datum #'cls.private-field-names)))
|
||||
(define this%-method-names
|
||||
(define this%-overridable-names
|
||||
(set-union this%-public-names this%-override-names))
|
||||
(define this%-augmentable-names
|
||||
(set-union this%-augment-names this%-pubment-names))
|
||||
(define this%-method-names
|
||||
(set-union this%-overridable-names this%-augmentable-names))
|
||||
(define all-internal
|
||||
(apply append
|
||||
(map (λ (stx) (syntax->datum stx))
|
||||
|
|
@ -224,7 +249,9 @@
|
|||
#'cls.field-internals
|
||||
#'cls.public-internals
|
||||
#'cls.override-internals
|
||||
#'cls.inherit-internals))))
|
||||
#'cls.inherit-internals
|
||||
#'cls.pubment-internals
|
||||
#'cls.augment-internals))))
|
||||
(define all-external
|
||||
(apply append
|
||||
(map (λ (stx) (syntax->datum stx))
|
||||
|
|
@ -233,7 +260,9 @@
|
|||
#'cls.field-externals
|
||||
#'cls.public-externals
|
||||
#'cls.override-externals
|
||||
#'cls.inherit-externals))))
|
||||
#'cls.inherit-externals
|
||||
#'cls.pubment-externals
|
||||
#'cls.augment-externals))))
|
||||
;; establish a mapping between internal and external names
|
||||
(define internal-external-mapping
|
||||
(for/hash ([internal all-internal]
|
||||
|
|
@ -272,16 +301,19 @@
|
|||
remaining-super-inits
|
||||
super-fields
|
||||
super-methods
|
||||
super-augments
|
||||
this%-init-internals
|
||||
this%-field-internals
|
||||
this%-public-internals)))
|
||||
(match-define (Instance: (Class: _ inits fields methods))
|
||||
this%-public-internals
|
||||
this%-pubment-internals)))
|
||||
(match-define (Instance: (Class: _ inits fields methods augments))
|
||||
self-type)
|
||||
;; trawl the body for the local name table
|
||||
(define locals (trawl-for-property #'cls.make-methods 'tr:class:local-table))
|
||||
(define-values (local-method-table local-private-table local-field-table
|
||||
local-private-field-table local-init-table
|
||||
local-inherit-table local-super-table)
|
||||
local-inherit-table local-super-table
|
||||
local-augment-table local-inner-table)
|
||||
(construct-local-mapping-tables (car locals)))
|
||||
;; types for private elements
|
||||
(define private-method-types
|
||||
|
|
@ -310,6 +342,10 @@
|
|||
super-methods
|
||||
this%-inherit-internals
|
||||
this%-override-internals
|
||||
local-augment-table local-inner-table
|
||||
augments super-augments
|
||||
this%-pubment-internals
|
||||
this%-augment-internals
|
||||
local-private-table private-method-types
|
||||
this%-private-names
|
||||
#'cls.initializer-self-id
|
||||
|
|
@ -327,35 +363,51 @@
|
|||
(define meth-stxs (trawl-for-property #'cls.make-methods 'tr:class:method))
|
||||
(define checked-method-types
|
||||
(with-lexical-env/extend lexical-names lexical-types
|
||||
(check-methods internal-external-mapping meth-stxs methods self-type)))
|
||||
(check-methods internal-external-mapping meth-stxs methods self-type
|
||||
#:filter this%-overridable-names)))
|
||||
(define checked-pubment-types
|
||||
(with-lexical-env/extend lexical-names lexical-types
|
||||
(check-methods internal-external-mapping meth-stxs augments self-type
|
||||
#:filter this%-augmentable-names)))
|
||||
(with-lexical-env/extend lexical-names lexical-types
|
||||
(check-private-methods meth-stxs this%-private-names
|
||||
private-method-types self-type))
|
||||
(define final-class-type
|
||||
(if expected?
|
||||
self-class-type
|
||||
(merge-types self-type checked-method-types)))
|
||||
(merge-types
|
||||
self-type
|
||||
checked-method-types
|
||||
checked-pubment-types)))
|
||||
(check-method-presence-and-absence
|
||||
final-class-type
|
||||
this%-init-names this%-field-names
|
||||
this%-public-names this%-override-names
|
||||
this%-inherit-names
|
||||
this%-pubment-names this%-augment-names
|
||||
(set-union optional-external optional-super)
|
||||
remaining-super-inits super-field-names
|
||||
super-method-names)
|
||||
super-method-names
|
||||
super-augment-names)
|
||||
final-class-type]))
|
||||
|
||||
;; check-method-presence-and-absence : Type Set<Symbol> * 9 -> Void
|
||||
;; check-method-presence-and-absence : Type Set<Symbol> * 12 -> Void
|
||||
;; use the internal class: information to check whether clauses
|
||||
;; exist or are absent appropriately
|
||||
(define (check-method-presence-and-absence
|
||||
class-type this%-init-names this%-field-names
|
||||
this%-public-names this%-override-names
|
||||
this%-inherit-names
|
||||
this%-pubment-names this%-augment-names
|
||||
optional-external
|
||||
remaining-super-inits super-field-names
|
||||
super-method-names)
|
||||
(match-define (Class: _ inits fields methods) class-type)
|
||||
super-method-names
|
||||
super-augment-names)
|
||||
(match-define (Class: _ inits fields methods augments) class-type)
|
||||
(define exp-init-names (list->set (dict-keys inits)))
|
||||
(define exp-field-names (list->set (dict-keys fields)))
|
||||
(define exp-method-names (list->set (dict-keys methods)))
|
||||
(define exp-augment-names (list->set (dict-keys augments)))
|
||||
(define exp-optional-inits
|
||||
(for/set ([(name val) (in-dict inits)]
|
||||
#:when (cadr val))
|
||||
|
|
@ -370,23 +422,34 @@
|
|||
(check-same (set-union this%-field-names super-field-names)
|
||||
exp-field-names
|
||||
"public field")
|
||||
(check-same (set-union this%-pubment-names super-augment-names)
|
||||
exp-augment-names
|
||||
"public augmentable method")
|
||||
(check-same optional-external exp-optional-inits
|
||||
"optional init argument")
|
||||
(check-exists super-method-names this%-override-names
|
||||
"override method")
|
||||
(check-exists super-method-names this%-inherit-names
|
||||
(check-exists super-augment-names this%-augment-names
|
||||
"augment method")
|
||||
(check-exists (set-union super-method-names super-augment-names)
|
||||
this%-inherit-names
|
||||
"inherited method")
|
||||
(check-absent super-field-names this%-field-names "public field")
|
||||
(check-absent super-method-names this%-public-names "public method"))
|
||||
(check-absent super-method-names this%-public-names "public method")
|
||||
(check-absent super-augment-names this%-pubment-names
|
||||
"public augmentable method"))
|
||||
|
||||
;; merge-types : Type Dict<Symbol, Type> -> Type
|
||||
;; merge-types : Type Dict<Symbol, Type> Dict<Symbol, Type> -> Type
|
||||
;; Given a self object type, construct the real class type based on
|
||||
;; new information found from type-checking. Only used when an expected
|
||||
;; type was not provided.
|
||||
(define (merge-types self-type method-types)
|
||||
(match-define (Instance: (and class-type (Class: #f inits fields methods)))
|
||||
self-type)
|
||||
(define new-methods
|
||||
(define (merge-types self-type method-types pubment-types)
|
||||
(match-define
|
||||
(Instance:
|
||||
(and class-type
|
||||
(Class: #f inits fields methods augments)))
|
||||
self-type)
|
||||
(define (make-new-methods methods method-types)
|
||||
(for/fold ([methods methods])
|
||||
([(name type) (in-dict method-types)])
|
||||
(define old-type (dict-ref methods name #f))
|
||||
|
|
@ -394,7 +457,9 @@
|
|||
(when (and old-type (not (equal? old-type type)))
|
||||
(tc-error "merge-types: internal error"))
|
||||
(dict-set methods name type)))
|
||||
(make-Class #f inits fields new-methods))
|
||||
(make-Class #f inits fields
|
||||
(make-new-methods methods method-types)
|
||||
(make-new-methods augments pubment-types)))
|
||||
|
||||
;; local-tables->lexical-env : Dict<Symbol, Symbol>
|
||||
;; LocalMapping NameTypeDict Names
|
||||
|
|
@ -412,6 +477,9 @@
|
|||
local-inherit-table local-super-table
|
||||
super-types
|
||||
inherit-names override-names
|
||||
local-augment-table local-inner-table
|
||||
augments super-augments
|
||||
pubment-names augment-names
|
||||
local-private-table
|
||||
private-types private-methods
|
||||
self-id init-args-id
|
||||
|
|
@ -434,21 +502,38 @@
|
|||
(localize local-private-table private-methods))
|
||||
(define localized-override-names
|
||||
(localize local-super-table override-names))
|
||||
(define localized-pubment-names
|
||||
(localize local-augment-table pubment-names))
|
||||
(define localized-augment-names
|
||||
(localize local-augment-table augment-names))
|
||||
(define localized-inner-names
|
||||
(localize local-inner-table (set-union pubment-names augment-names)))
|
||||
(define localized-init-names (localize local-init-table init-names))
|
||||
(define default-type (list (make-Univ)))
|
||||
|
||||
;; construct the types for method accessors
|
||||
(define (make-method-types method-names type-map)
|
||||
(define (make-method-types method-names type-map
|
||||
#:inner? [inner? #f])
|
||||
(for/list ([m (in-set method-names)])
|
||||
(define external (dict-ref internal-external-mapping m))
|
||||
(define maybe-type (dict-ref type-map external #f))
|
||||
(->* (list (make-Univ))
|
||||
(if maybe-type
|
||||
(fixup-method-type (car maybe-type) self-type)
|
||||
(make-Univ)))))
|
||||
(cond [(and maybe-type (not inner?))
|
||||
(fixup-method-type (car maybe-type) self-type)]
|
||||
[maybe-type
|
||||
(Un (-val #f)
|
||||
(fixup-method-type (car maybe-type) self-type))]
|
||||
[else (make-Univ)]))))
|
||||
|
||||
(define method-types (make-method-types method-names methods))
|
||||
(define inherit-types (make-method-types inherit-names super-types))
|
||||
(define inherit-types
|
||||
(make-method-types
|
||||
inherit-names
|
||||
(append super-types super-augments)))
|
||||
(define augment-types (make-method-types augment-names augments))
|
||||
(define inner-types
|
||||
(make-method-types
|
||||
(set-union pubment-names augment-names)
|
||||
augments #:inner? #t))
|
||||
|
||||
;; construct field accessor types
|
||||
(define (make-field-types field-names type-map #:private? [private? #f])
|
||||
|
|
@ -483,6 +568,8 @@
|
|||
(make-private-like-types private-methods private-types))
|
||||
(define super-call-types
|
||||
(make-private-like-types override-names super-types))
|
||||
(define pubment-types
|
||||
(make-private-like-types pubment-names augments))
|
||||
|
||||
(define init-types
|
||||
(for/list ([i (in-set init-names)])
|
||||
|
|
@ -496,11 +583,15 @@
|
|||
localized-private-field-get-names
|
||||
localized-private-field-set-names
|
||||
localized-inherit-names
|
||||
localized-override-names))
|
||||
localized-override-names
|
||||
localized-pubment-names
|
||||
localized-augment-names
|
||||
localized-inner-names))
|
||||
(define all-types (append method-types private-method-types
|
||||
field-get-types field-set-types
|
||||
private-field-get-types private-field-set-types
|
||||
inherit-types super-call-types))
|
||||
inherit-types super-call-types
|
||||
pubment-types augment-types inner-types))
|
||||
(values all-names all-types
|
||||
;; FIXME: consider removing method names and types
|
||||
;; from top-level environment to avoid <undefined>
|
||||
|
|
@ -519,11 +610,13 @@
|
|||
;; -> Dict<Symbol, Type>
|
||||
;; Type-check the methods inside of a class
|
||||
(define (check-methods internal-external-mapping
|
||||
meths methods self-type)
|
||||
(for/list ([meth meths])
|
||||
meths methods self-type
|
||||
#:filter [filter #f])
|
||||
(for/fold ([checked '()])
|
||||
([meth meths])
|
||||
(define method-name (syntax-property meth 'tr:class:method))
|
||||
(define external-name (dict-ref internal-external-mapping method-name))
|
||||
(define maybe-expected (dict-ref methods external-name #f))
|
||||
(define external-name (dict-ref internal-external-mapping method-name #f))
|
||||
(define maybe-expected (and external-name (dict-ref methods external-name #f)))
|
||||
(cond [maybe-expected
|
||||
(define pre-method-type (car maybe-expected))
|
||||
(define method-type
|
||||
|
|
@ -531,9 +624,34 @@
|
|||
(define expected (ret method-type))
|
||||
(define annotated (annotate-method meth self-type method-type))
|
||||
(tc-expr/check annotated expected)
|
||||
(list external-name pre-method-type)]
|
||||
[else (list external-name
|
||||
(unfixup-method-type (tc-expr/t meth)))])))
|
||||
(cons (list external-name pre-method-type) checked)]
|
||||
;; Only try to type-check if these names are in the
|
||||
;; filter when it's provided. This allows us to, say, only
|
||||
;; type-check pubments/augments.
|
||||
[(and filter (set-member? filter external-name))
|
||||
(cons (list external-name
|
||||
(unfixup-method-type (tc-expr/t meth)))
|
||||
checked)]
|
||||
[else checked])))
|
||||
|
||||
;; check-private-methods : Listof<Syntax> Listof<Sym> Dict<Sym, Type> Type
|
||||
;; -> Void
|
||||
;; Type-check private methods
|
||||
(define (check-private-methods stxs names types self-type)
|
||||
(for ([stx stxs])
|
||||
(define method-name (syntax-property stx 'tr:class:method))
|
||||
(define private? (set-member? names method-name))
|
||||
(define annotation (dict-ref types method-name #f))
|
||||
(cond [(and private? annotation)
|
||||
(define pre-method-type annotation)
|
||||
(define method-type
|
||||
(fixup-method-type pre-method-type self-type))
|
||||
(define expected (ret method-type))
|
||||
(define annotated (annotate-method stx self-type method-type))
|
||||
(tc-expr/check annotated expected)]
|
||||
;; not private, then ignore since it's irrelevant
|
||||
[(not private?) (void)]
|
||||
[else (tc-expr/t stx)])))
|
||||
|
||||
;; check-field-set!s : Syntax Dict<Symbol, Symbol> Dict<Symbol, Type> -> Void
|
||||
;; Check that fields are initialized to the correct type
|
||||
|
|
@ -635,7 +753,7 @@
|
|||
;; generated inside the untyped class macro.
|
||||
(define (construct-local-mapping-tables stx)
|
||||
(syntax-parse stx
|
||||
#:literals (let-values #%plain-app #%plain-lambda values)
|
||||
#:literals (let-values if quote #%plain-app #%plain-lambda values)
|
||||
;; See base-env/class-prims.rkt to see how this in-syntax
|
||||
;; table is constructed at the surface syntax
|
||||
;;
|
||||
|
|
@ -681,6 +799,15 @@
|
|||
(#%plain-lambda ()
|
||||
(#%plain-app (#%plain-app local-override:id _) _)
|
||||
(#%plain-app local-super:id _))
|
||||
...)]
|
||||
[(augment:id ...)
|
||||
(#%plain-app
|
||||
values
|
||||
(#%plain-lambda ()
|
||||
(~or (#%plain-app local-augment:id _)
|
||||
(#%plain-app (#%plain-app local-augment:id _) _))
|
||||
(let-values ([(_) (#%plain-app local-inner:id _)])
|
||||
(if _ (#%plain-app _ _) _)))
|
||||
...)])
|
||||
(#%plain-app void))
|
||||
(values (map cons
|
||||
|
|
@ -707,7 +834,13 @@
|
|||
(syntax->list #'(local-inherit ...)))
|
||||
(map cons
|
||||
(syntax->datum #'(override ...))
|
||||
(syntax->list #'(local-super ...))))]))
|
||||
(syntax->list #'(local-super ...)))
|
||||
(map cons
|
||||
(syntax->datum #'(augment ...))
|
||||
(syntax->list #'(local-augment ...)))
|
||||
(map cons
|
||||
(syntax->datum #'(augment ...))
|
||||
(syntax->list #'(local-inner ...))))]))
|
||||
|
||||
;; check-super-new-exists : Listof<Syntax> -> (U Syntax #f)
|
||||
;; Check if a `super-new` call exists and if there is only
|
||||
|
|
@ -754,27 +887,26 @@
|
|||
;; Look through the expansion of the class macro in search for
|
||||
;; syntax with some property (e.g., methods)
|
||||
(define (trawl-for-property form prop)
|
||||
(define (recur-on-all stx-list)
|
||||
(apply append (map (λ (stx) (trawl-for-property stx prop))
|
||||
(syntax->list stx-list))))
|
||||
(syntax-parse form
|
||||
#:literals (let-values letrec-values #%plain-app
|
||||
letrec-syntaxes+values)
|
||||
#%plain-lambda letrec-syntaxes+values)
|
||||
[stx
|
||||
#:when (syntax-property form prop)
|
||||
(list form)]
|
||||
[(let-values (b ...)
|
||||
body)
|
||||
(trawl-for-property #'body prop)]
|
||||
[(letrec-values (b ...)
|
||||
body)
|
||||
(trawl-for-property #'body prop)]
|
||||
[(letrec-syntaxes+values (sb ...) (vb ...)
|
||||
body)
|
||||
(trawl-for-property #'body prop)]
|
||||
[(let-values (b ...) body ...)
|
||||
(recur-on-all #'(b ... body ...))]
|
||||
;; for letrecs, traverse the RHSs too
|
||||
[(letrec-values ([(x ...) rhs ...] ...) body ...)
|
||||
(recur-on-all #'(rhs ... ... body ...))]
|
||||
[(letrec-syntaxes+values (sb ...) ([(x ...) rhs ...] ...) body ...)
|
||||
(recur-on-all #'(rhs ... ... body ...))]
|
||||
[(#%plain-app e ...)
|
||||
(apply append (map (λ (stx) (trawl-for-property stx prop))
|
||||
(syntax->list #'(e ...))))]
|
||||
(recur-on-all #'(e ...))]
|
||||
[(#%plain-lambda (x ...) e ...)
|
||||
(apply append (map (λ (stx) (trawl-for-property stx prop))
|
||||
(syntax->list #'(e ...))))]
|
||||
(recur-on-all #'(e ...))]
|
||||
[_ '()]))
|
||||
|
||||
;; register-internals : Listof<Syntax> -> Dict<Symbol, Type>
|
||||
|
|
@ -797,13 +929,14 @@
|
|||
|
||||
;; infer-self-type : Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol>
|
||||
;; Inits Fields Methods
|
||||
;; Set<Symbol> * 3 -> Type
|
||||
;; Set<Symbol> * 4 -> Type
|
||||
;; Construct a self object type based on the registered types
|
||||
;; from : inside the class body.
|
||||
(define (infer-self-type internals-table optional-inits
|
||||
internal-external-mapping
|
||||
super-inits super-fields super-methods
|
||||
inits fields publics)
|
||||
super-augments
|
||||
inits fields publics augments)
|
||||
(define (make-type-dict names supers [inits? #f])
|
||||
(for/fold ([type-dict supers])
|
||||
([name names])
|
||||
|
|
@ -819,7 +952,9 @@
|
|||
(define init-types (make-type-dict inits super-inits #t))
|
||||
(define field-types (make-type-dict fields super-fields))
|
||||
(define public-types (make-type-dict publics super-methods))
|
||||
(make-Instance (make-Class #f init-types field-types public-types)))
|
||||
(define augment-types (make-type-dict augments super-augments))
|
||||
(make-Instance (make-Class #f init-types field-types
|
||||
public-types augment-types)))
|
||||
|
||||
;; fixup-method-type : Function Type -> Function
|
||||
;; Fix up a method's arity from a regular function type
|
||||
|
|
@ -831,7 +966,7 @@
|
|||
(match-define (arr: doms rng rest drest kws) arr)
|
||||
(make-arr (cons self-type doms) rng rest drest kws)))
|
||||
(make-Function fixed-arrs)]
|
||||
[_ (displayln type) (tc-error "fixup-method-type: internal error")]))
|
||||
[_ (tc-error "fixup-method-type: internal error")]))
|
||||
|
||||
;; unfixup-method-type : Function -> Function
|
||||
;; Turn a "real" method type back into a function type
|
||||
|
|
@ -919,7 +1054,6 @@
|
|||
;; check that the actual names don't include names not in the
|
||||
;; expected type (i.e., the names must exactly match up)
|
||||
(define (check-no-extra actual expected)
|
||||
(printf "actual : ~a expected : ~a~n" actual expected)
|
||||
(unless (subset? actual expected)
|
||||
;; FIXME: better error reporting here
|
||||
(tc-error/expr "class defines names not in expected type")))
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@
|
|||
(list (syntax-e name) arg)))
|
||||
(match (resolve (tc-expr/t cl))
|
||||
[(Union: '()) (ret (Un))]
|
||||
[(and c (Class: _ inits fields _))
|
||||
[(and c (Class: _ inits fields _ _))
|
||||
(define init-names (map car inits))
|
||||
(for ([given-name given-names]
|
||||
#:unless (memq given-name init-names))
|
||||
|
|
@ -83,7 +83,7 @@
|
|||
"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 ...) _))))
|
||||
[(tc-result1: (and ty (Instance: (Class: _ _ (list fields ...) _ _))))
|
||||
(cond [(assq maybe-meth-sym fields) =>
|
||||
(λ (field-entry) (ret (cadr field-entry)))]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@
|
|||
(match rcvr-type
|
||||
[(tc-result1: (Instance: (? Mu? type)))
|
||||
(do-check (ret (make-Instance (unfold type))))]
|
||||
[(tc-result1: (Instance: (and c (Class: _ _ _ methods))))
|
||||
[(tc-result1: (Instance: (and c (Class: _ _ _ methods augments))))
|
||||
(match (tc-expr method)
|
||||
[(tc-result1: (Value: (? symbol? s)))
|
||||
(let* ([ftype (cond [(assq s methods) => cadr]
|
||||
(let* ([ftype (cond [(assq s (append methods augments)) => cadr]
|
||||
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
|
||||
[retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)])
|
||||
(add-typeof-expr form retval)
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@
|
|||
;; Data definitions
|
||||
;;
|
||||
;; A RowConstraint is a
|
||||
;; List(List<Sym>, List<Sym>, List<Sym>)
|
||||
;; List(List<Sym>, List<Sym>, List<Sym>, List<Sym>)
|
||||
|
||||
;; Syntax -> Syntax
|
||||
;; Turn into datums and then flatten
|
||||
|
|
@ -37,16 +37,18 @@
|
|||
|
||||
;; Syntax classes for rows
|
||||
(define-splicing-syntax-class row-constraints
|
||||
#:literals (init init-field field)
|
||||
#:literals (init init-field field augment)
|
||||
(pattern (~seq (~or (init iname:id ...)
|
||||
(init-field ifname:id ...)
|
||||
(field fname:id ...)
|
||||
(augment aname:id ...)
|
||||
mname:id)
|
||||
...)
|
||||
#:attr init-names (flatten/datum #'((iname ...) ...))
|
||||
#:attr init-field-names (flatten/datum #'((ifname ...) ...))
|
||||
#:attr field-names (flatten/datum #'((fname ...) ...))
|
||||
#:attr method-names (syntax->datum #'(mname ...))
|
||||
#:attr augment-names (flatten/datum #'((aname ...) ...))
|
||||
#:attr all-field-names (append (attribute init-field-names)
|
||||
(attribute field-names))
|
||||
#:attr all-init-names (append (attribute init-field-names)
|
||||
|
|
@ -57,19 +59,25 @@
|
|||
#:fail-when
|
||||
(check-duplicate (attribute all-field-names))
|
||||
"duplicate field or init-field clause"
|
||||
#:fail-when
|
||||
(check-duplicate (append (attribute method-names)
|
||||
(attribute augment-names)))
|
||||
"duplicate method or augmentable method clause"
|
||||
#:attr constraints
|
||||
(list (attribute all-init-names)
|
||||
(attribute all-field-names)
|
||||
(attribute method-names))))
|
||||
(attribute method-names)
|
||||
(attribute augment-names))))
|
||||
|
||||
;; Row RowConstraints (Symbol -> Void) -> Void
|
||||
;; Check if the given row satisfies the absence constraints
|
||||
;; on the row variable or not. Call the fail thunk if it
|
||||
;; doesn't.
|
||||
(define (check-row-constraints row constraints fail)
|
||||
(match-define (list init-absents field-absents method-absents)
|
||||
(match-define (list init-absents field-absents
|
||||
method-absents augment-absents)
|
||||
constraints)
|
||||
(match-define (Row: inits fields methods) row)
|
||||
(match-define (Row: inits fields methods augments) row)
|
||||
;; check a given clause type (e.g., init, field)
|
||||
(define (check-clauses row-dict absence-set)
|
||||
(for ([(name _) (in-dict row-dict)])
|
||||
|
|
@ -77,7 +85,8 @@
|
|||
(fail name))))
|
||||
(check-clauses inits init-absents)
|
||||
(check-clauses fields field-absents)
|
||||
(check-clauses methods method-absents))
|
||||
(check-clauses methods method-absents)
|
||||
(check-clauses augments augment-absents))
|
||||
|
||||
;; Row types are similar to class types
|
||||
(define-splicing-syntax-class (row-clauses parse-type)
|
||||
|
|
@ -87,9 +96,11 @@
|
|||
#:attr inits (apply append (attribute clause.init-entries))
|
||||
#:attr fields (apply append (attribute clause.field-entries))
|
||||
#:attr methods (apply append (attribute clause.method-entries))
|
||||
#:attr augments (apply append (attribute clause.augment-entries))
|
||||
#:attr row (make-Row (attribute inits)
|
||||
(attribute fields)
|
||||
(attribute methods))
|
||||
(attribute methods)
|
||||
(attribute augments))
|
||||
#:fail-when
|
||||
(check-duplicate (map first (attribute inits)))
|
||||
"duplicate init or init-field clause"
|
||||
|
|
@ -97,45 +108,51 @@
|
|||
(check-duplicate (map first (attribute fields)))
|
||||
"duplicate field or init-field clause"
|
||||
#:fail-when
|
||||
(check-duplicate (map first (attribute methods)))
|
||||
"duplicate method clause"))
|
||||
(check-duplicate (map first (append (attribute methods)
|
||||
(attribute augments))))
|
||||
"duplicate method or augmentable method clause"))
|
||||
|
||||
;; Type -> RowConstraint
|
||||
;; Infer constraints on a row for a row polymorphic function
|
||||
(define (infer-row-constraints type)
|
||||
(define constraints (list null null null))
|
||||
(define constraints (list null null null null))
|
||||
;; Crawl the type tree and mutate constraints when a
|
||||
;; class type with row variable is found.
|
||||
(define (inf type)
|
||||
(type-case
|
||||
(#:Type inf #:Filter (sub-f inf) #:Object (sub-o inf))
|
||||
type
|
||||
[#:Class row inits fields methods
|
||||
[#:Class row inits fields methods augments
|
||||
(cond
|
||||
[(and row (F? row))
|
||||
(match-define (list init-cs field-cs method-cs) constraints)
|
||||
(match-define (list init-cs field-cs method-cs augment-cs)
|
||||
constraints)
|
||||
(set! constraints
|
||||
(list (append (dict-keys inits) init-cs)
|
||||
(append (dict-keys fields) field-cs)
|
||||
(append (dict-keys methods) method-cs)))
|
||||
(make-Class row inits fields methods)]
|
||||
(append (dict-keys methods) method-cs)
|
||||
(append (dict-keys augments) augment-cs)))
|
||||
(make-Class row inits fields methods augments)]
|
||||
[else
|
||||
(match-define (list (list init-names init-tys init-reqds) ...) inits)
|
||||
(match-define (list (list field-names field-tys) ...) fields)
|
||||
(match-define (list (list method-names method-tys) ...) methods)
|
||||
(match-define (list (list augment-names augment-tys) ...) augments)
|
||||
(make-Class
|
||||
(and row (inf row))
|
||||
(map list init-names (map inf init-tys) init-reqds)
|
||||
(map list field-names (map inf field-tys))
|
||||
(map list method-names (map inf method-tys)))])]))
|
||||
(map list method-names (map inf method-tys))
|
||||
(map list augment-names (map inf augment-tys)))])]))
|
||||
(inf type)
|
||||
(map remove-duplicates constraints))
|
||||
|
||||
;; infer-row : RowConstraints Type -> Row
|
||||
;; Infer a row based on a class type and row constraints
|
||||
(define (infer-row constraints class-type)
|
||||
(match-define (list init-cs field-cs method-cs) constraints)
|
||||
(match-define (Class: _ inits fields methods)
|
||||
(match-define (list init-cs field-cs method-cs augment-cs)
|
||||
constraints)
|
||||
(match-define (Class: _ inits fields methods augments)
|
||||
(resolve class-type))
|
||||
(define (dict-remove* dict keys)
|
||||
(for/fold ([dict dict])
|
||||
|
|
@ -143,7 +160,8 @@
|
|||
(dict-remove dict key)))
|
||||
(make-Row (dict-remove* inits init-cs)
|
||||
(dict-remove* fields field-cs)
|
||||
(dict-remove* methods method-cs)))
|
||||
(dict-remove* methods method-cs)
|
||||
(dict-remove* augments augment-cs)))
|
||||
|
||||
;; Syntax -> Syntax
|
||||
;; removes two levels of nesting
|
||||
|
|
@ -177,7 +195,7 @@
|
|||
(define-splicing-syntax-class (class-type-clauses parse-type)
|
||||
#:description "Class type clause"
|
||||
#:attributes (row-var extends-types
|
||||
inits fields methods)
|
||||
inits fields methods augments)
|
||||
(pattern (~seq (~or (~optional (~seq #:row-var row-var:id))
|
||||
(~seq #:implements extends-type:expr)
|
||||
(~var clause (type-clause parse-type)))
|
||||
|
|
@ -185,6 +203,7 @@
|
|||
#:attr inits (apply append (attribute clause.init-entries))
|
||||
#:attr fields (apply append (attribute clause.field-entries))
|
||||
#:attr methods (apply append (attribute clause.method-entries))
|
||||
#:attr augments (apply append (attribute clause.augment-entries))
|
||||
#:with extends-types #'(extends-type ...)
|
||||
#:fail-when
|
||||
(check-duplicate (map first (attribute inits)))
|
||||
|
|
@ -193,8 +212,9 @@
|
|||
(check-duplicate (map first (attribute fields)))
|
||||
"duplicate field or init-field clause"
|
||||
#:fail-when
|
||||
(check-duplicate (map first (attribute methods)))
|
||||
"duplicate method clause"))
|
||||
(check-duplicate (map first (append (attribute methods)
|
||||
(attribute augments))))
|
||||
"duplicate method or augmentable method clause"))
|
||||
|
||||
;; Stx Stx Listof<Boolean> (Stx -> Type) -> Listof<(List Symbol Type Boolean)>
|
||||
;; Construct init entries for a dictionary for the class type
|
||||
|
|
@ -207,18 +227,20 @@
|
|||
optional?)))
|
||||
|
||||
;; Stx Stx (Stx -> Type) -> Listof<(List Symbol Type)>
|
||||
;; Construct field entries for a class type dictionary
|
||||
(define (make-field-entries labels types parse-type)
|
||||
;; Construct field/augment entries for a class type dictionary
|
||||
(define (make-field/augment-entries labels types parse-type)
|
||||
(for/list ([label (in-syntax labels)]
|
||||
[type (in-syntax types)])
|
||||
(list (syntax-e label) (parse-type type))))
|
||||
|
||||
(define-syntax-class (type-clause parse-type)
|
||||
#:attributes (init-entries field-entries method-entries)
|
||||
#:literals (init init-field field)
|
||||
#:attributes (init-entries field-entries
|
||||
method-entries augment-entries)
|
||||
#:literals (init init-field field augment)
|
||||
(pattern (~or (init init-clause:init-type ...)
|
||||
(init-field init-field-clause:init-type ...)
|
||||
(field field-clause:field-or-method-type ...)
|
||||
(augment augment-clause:field-or-method-type ...)
|
||||
method-clause:field-or-method-type)
|
||||
#:attr init-entries
|
||||
(append (if (attribute init-clause)
|
||||
|
|
@ -237,13 +259,13 @@
|
|||
null))
|
||||
#:attr field-entries
|
||||
(append (if (attribute field-clause)
|
||||
(make-field-entries
|
||||
(make-field/augment-entries
|
||||
#'(field-clause.label ...)
|
||||
#'(field-clause.type ...)
|
||||
parse-type)
|
||||
null)
|
||||
(if (attribute init-field-clause)
|
||||
(make-field-entries
|
||||
(make-field/augment-entries
|
||||
#'(init-field-clause.label ...)
|
||||
#'(init-field-clause.type ...)
|
||||
parse-type)
|
||||
|
|
@ -252,6 +274,13 @@
|
|||
(if (attribute method-clause)
|
||||
(list (list (syntax-e #'method-clause.label)
|
||||
(parse-type #'method-clause.type)))
|
||||
null)
|
||||
#:attr augment-entries
|
||||
(if (attribute augment-clause)
|
||||
(make-field/augment-entries
|
||||
#'(augment-clause.label ...)
|
||||
#'(augment-clause.type ...)
|
||||
parse-type)
|
||||
null)))
|
||||
|
||||
(define-syntax-class init-type
|
||||
|
|
|
|||
|
|
@ -330,7 +330,7 @@
|
|||
;; class->sexp : Class [#:object? Boolean] -> S-expression
|
||||
;; Convert a class or object type to an s-expression
|
||||
(define (class->sexp cls #:object? [object? #f])
|
||||
(match-define (Class: row-var inits fields methods) cls)
|
||||
(match-define (Class: row-var inits fields methods augments) cls)
|
||||
(define row-var*
|
||||
(if (and row-var (F? row-var)) `(#:row-var ,(F-n row-var)) '()))
|
||||
(define inits*
|
||||
|
|
@ -355,7 +355,12 @@
|
|||
(for/list ([name+type (in-list methods)])
|
||||
(match-define (list name type) name+type)
|
||||
`(,name ,(type->sexp type))))
|
||||
`(,(if object? 'Object 'Class) ,@row-var* ,@inits* ,@fields* ,@methods*))
|
||||
(define augments*
|
||||
(cond [(null? augments) '()]
|
||||
[object? augments]
|
||||
[else (list (cons 'augment augments))]))
|
||||
`(,(if object? 'Object 'Class)
|
||||
,@row-var* ,@inits* ,@fields* ,@methods* ,@augments*))
|
||||
|
||||
;; type->sexp : Type -> S-expression
|
||||
;; convert a type to an s-expression that can be printed
|
||||
|
|
|
|||
|
|
@ -577,16 +577,8 @@
|
|||
(subtype* s-out t-out))]
|
||||
[((Param: in out) t)
|
||||
(subtype* A0 (cl->* (-> out) (-> in -Void)) t)]
|
||||
[((Instance: t) (Instance: t*))
|
||||
(subtype* A0 t t*)]
|
||||
[((Class: _ '() fields (list (and s (list names meths )) ...))
|
||||
(Class: _ '() fields (list (and s* (list names* meths*)) ...)))
|
||||
(for/fold ([A A0])
|
||||
([n (in-list names*)] [m (in-list meths*)] #:break (not A))
|
||||
(and A (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
|
||||
[else #f])))]
|
||||
[((Instance: (Class: _ _ field-map method-map))
|
||||
(Instance: (Class: _ _ field-map* method-map*)))
|
||||
[((Instance: (Class: _ _ field-map method-map augment-map))
|
||||
(Instance: (Class: _ _ field-map* method-map* augment-map*)))
|
||||
(define (subtype-clause? map map*)
|
||||
(match-define (list (and s (list names types)) ...) map)
|
||||
(match-define (list (and s* (list names* types*)) ...) map*)
|
||||
|
|
@ -595,10 +587,13 @@
|
|||
(and A (cond [(assq n s) =>
|
||||
(lambda (spec) (subtype* A (cadr spec) m))]
|
||||
[else #f]))))
|
||||
(and (subtype-clause? method-map method-map*)
|
||||
(and ;; Note that augment/public doesn't matter for object
|
||||
;; subtyping, so these mappings can be merged
|
||||
(subtype-clause? (append method-map augment-map)
|
||||
(append method-map* augment-map*))
|
||||
(subtype-clause? field-map field-map*))]
|
||||
[((Class: row inits fields methods)
|
||||
(Class: row* inits* fields* methods*))
|
||||
[((Class: row inits fields methods augments)
|
||||
(Class: row* inits* fields* methods* augments*))
|
||||
;; check that each of inits, fields, methods, etc. are
|
||||
;; equal by sorting and checking type equality
|
||||
(define (equal-clause? clause clause* [inits? #f])
|
||||
|
|
@ -630,7 +625,9 @@
|
|||
(equal? row row*))
|
||||
(equal-clause? inits inits* #t)
|
||||
(equal-clause? fields fields*)
|
||||
(equal-clause? methods methods*))]
|
||||
;; augment/public distinction is important here
|
||||
(equal-clause? methods methods*)
|
||||
(equal-clause? augments augments*))]
|
||||
;; otherwise, not a subtype
|
||||
[(_ _) #f])))
|
||||
(when (null? A)
|
||||
|
|
|
|||
|
|
@ -826,5 +826,116 @@
|
|||
(define (f cls)
|
||||
(class: cls (super-new)
|
||||
(field [x 5])))
|
||||
(inst f #:row (field [x Integer])))))
|
||||
(inst f #:row (field [x Integer])))
|
||||
|
||||
;; Check simple use of pubment
|
||||
(check-ok
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x) 0)))
|
||||
(send (new c%) m 3))
|
||||
|
||||
;; Local calls to pubment method
|
||||
(check-ok
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x) 0)
|
||||
(: n (-> Number))
|
||||
(define/public (n) (m 5))))
|
||||
(send (new c%) n))
|
||||
|
||||
;; Inheritance with augment
|
||||
(check-ok
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x) 0)))
|
||||
(define d%
|
||||
(class: c%
|
||||
(super-new)
|
||||
(define/augment (m x)
|
||||
(+ 1 x))))
|
||||
(send (new c%) m 5))
|
||||
|
||||
;; Pubment with inner
|
||||
(check-ok
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x)
|
||||
(inner 0 m x))))
|
||||
(define d%
|
||||
(class: c%
|
||||
(super-new)
|
||||
(define/augment (m x)
|
||||
(+ 1 x))))
|
||||
(send (new c%) m 0))
|
||||
|
||||
;; Fail, bad inner default
|
||||
(check-err
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x)
|
||||
(inner "foo" m x)))))
|
||||
|
||||
;; Fail, wrong number of arguments to inner
|
||||
(check-err
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x)
|
||||
(inner 3 m)))))
|
||||
|
||||
;; Fail, bad augment type
|
||||
(check-err
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/pubment (m x)
|
||||
(inner 0 m x))))
|
||||
(define d%
|
||||
(class: c%
|
||||
(super-new)
|
||||
(define/augment (m x) "bad type"))))
|
||||
|
||||
;; Fail, cannot augment non-augmentable method
|
||||
(check-err
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(define/public (m x) 0)))
|
||||
(define d%
|
||||
(class: c%
|
||||
(super-new)
|
||||
(define/augment (m x) 1))))
|
||||
|
||||
;; Pubment with separate internal/external names
|
||||
(check-ok
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer))
|
||||
(pubment [n m])
|
||||
(define n (λ (x) 0))))
|
||||
(send (new c%) m 0))
|
||||
|
||||
;; Pubment with expected class type
|
||||
(check-ok
|
||||
(: c% (Class (augment [m (Natural -> Natural)])))
|
||||
(define c%
|
||||
(class: object%
|
||||
(super-new)
|
||||
(define/pubment (m x) 0)))
|
||||
(send (new c%) m 3))))
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
(base-env base-types base-types-extra colon)
|
||||
;; needed for parsing case-lambda/case-> types
|
||||
(only-in (base-env case-lambda) case-lambda)
|
||||
(only-in racket/class init init-field field)
|
||||
(only-in racket/class init init-field field augment)
|
||||
|
||||
rackunit)
|
||||
|
||||
|
|
@ -200,20 +200,24 @@
|
|||
(->optkey -String [] #:rest -String #:a -String #f -String)]
|
||||
|
||||
;;; Classes
|
||||
[(Class) (make-Class #f null null null)]
|
||||
[(Class) (make-Class #f null null null null)]
|
||||
[(Class (init [x Number] [y Number]))
|
||||
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) null null)]
|
||||
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) null null null)]
|
||||
[(Class (init [x Number] [y Number #:optional]))
|
||||
(make-Class #f `((x ,-Number #f) (y ,-Number #t)) null null)]
|
||||
(make-Class #f `((x ,-Number #f) (y ,-Number #t)) null null null)]
|
||||
[(Class (init [x Number]) (init-field [y Number]))
|
||||
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) `((y ,-Number))
|
||||
null)]
|
||||
null null)]
|
||||
[(Class [m (Number -> Number)])
|
||||
(make-Class #f null null `((m ,(t:-> N N))))]
|
||||
(make-Class #f null null `((m ,(t:-> N N))) null)]
|
||||
[(Class [m (Number -> Number)] (init [x Number]))
|
||||
(make-Class #f `((x ,-Number #f)) null `((m ,(t:-> N N))))]
|
||||
(make-Class #f `((x ,-Number #f)) null `((m ,(t:-> N N))) null)]
|
||||
[(Class [m (Number -> Number)] (field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
|
||||
[(Class (augment [m (Number -> Number)]))
|
||||
(make-Class #f null null null `((m ,(t:-> N N))))]
|
||||
[(Class (augment [m (Number -> Number)]) (field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) null `((m ,(t:-> N N))))]
|
||||
[FAIL (Class foobar)]
|
||||
[FAIL (Class [x UNBOUND])]
|
||||
[FAIL (Class [x Number #:random-keyword])]
|
||||
|
|
@ -223,19 +227,21 @@
|
|||
[FAIL (Class (init [x Number]) (init [x Number]))]
|
||||
[FAIL (Class (init [x Number]) (init-field [x Number]))]
|
||||
[FAIL (Class (field [x Number]) (init-field [x Number]))]
|
||||
[FAIL (Class (augment [x (-> Number)]) [x (-> Number)])]
|
||||
[FAIL (Class (augment [x (-> Number)] [x (-> String)]))]
|
||||
;; test #:row-var
|
||||
[(All (r #:row) (Class #:row-var r))
|
||||
(make-PolyRow (list 'r)
|
||||
(list null null null)
|
||||
(make-Class (make-F 'r) null null null))]
|
||||
(list null null null null)
|
||||
(make-Class (make-F 'r) null null null null))]
|
||||
[(All (r #:row) (Class #:implements (Class #:row-var r)))
|
||||
(make-PolyRow (list 'r)
|
||||
(list null null null)
|
||||
(make-Class (make-F 'r) null null null))]
|
||||
(list null null null null)
|
||||
(make-Class (make-F 'r) null null null null))]
|
||||
[(All (r #:row) (Class #:implements (Class) #:row-var r))
|
||||
(make-PolyRow (list 'r)
|
||||
(list null null null)
|
||||
(make-Class (make-F 'r) null null null))]
|
||||
(list null null null null)
|
||||
(make-Class (make-F 'r) null null null null))]
|
||||
[FAIL (Class #:row-var 5)]
|
||||
[FAIL (Class #:row-var (list 3))]
|
||||
[FAIL (Class #:implements (Class #:row-var r) #:row-var x)]
|
||||
|
|
@ -246,30 +252,37 @@
|
|||
[FAIL (All (r #:row) (Class #:implements (Class #:row-var r) #:row-var r))]
|
||||
;; test #:implements
|
||||
[(Class #:implements (Class [m (Number -> Number)]) (field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
|
||||
[(Class #:implements (Class [m (Number -> Number)])
|
||||
#:implements (Class [n (Number -> Number)])
|
||||
(field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) `((n ,(t:-> N N)) (m ,(t:-> N N))))]
|
||||
(make-Class #f null `((x ,-Number))
|
||||
`((n ,(t:-> N N)) (m ,(t:-> N N))) null)]
|
||||
[(Class #:implements (Class [m (Number -> Number)])
|
||||
#:implements (Class [m (Number -> Number)])
|
||||
(field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
|
||||
[(Class #:implements (Class (init [x Integer]) [m (Number -> Number)])
|
||||
(field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
|
||||
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
|
||||
[FAIL (Class #:implements Number)]
|
||||
[FAIL (Class #:implements Number [m (Number -> Number)])]
|
||||
[FAIL (Class #:implements (Class [m (Number -> Number)]) [m String])]
|
||||
[FAIL (Class #:implements (Class [m (Number -> Number)])
|
||||
#:implements (Class [m (String -> String)])
|
||||
(field [x Number]))]
|
||||
[FAIL (Class #:implements (Class (augment [m (Number -> Number)]))
|
||||
#:implements (Class (augment [m (String -> String)]))
|
||||
(field [x Number]))]
|
||||
[FAIL (Class #:implements (Class (augment [m (Number -> Number)]))
|
||||
(augment [m (-> Number)]))]
|
||||
;; Test Object types
|
||||
[(Object) (make-Instance (make-Class #f null null null))]
|
||||
[(Object) (make-Instance (make-Class #f null null null null))]
|
||||
[(Object [m (Number -> Number)])
|
||||
(make-Instance (make-Class #f null null `((m ,(t:-> N N)))))]
|
||||
(make-Instance (make-Class #f null null `((m ,(t:-> N N))) null))]
|
||||
[(Object [m (Number -> Number)] (field [f Number]))
|
||||
(make-Instance (make-Class #f null `((f ,N)) `((m ,(t:-> N N)))))]
|
||||
(make-Instance (make-Class #f null `((f ,N))
|
||||
`((m ,(t:-> N N))) null))]
|
||||
[FAIL (Object foobar)]
|
||||
[FAIL (Object [x UNBOUND])]
|
||||
[FAIL (Object [x Number #:random-keyword])]
|
||||
|
|
@ -279,14 +292,14 @@
|
|||
[FAIL (Object [x Number] [x Number])]
|
||||
;; Test row polymorphic types
|
||||
[(All (r #:row) ((Class #:row-var r) -> (Class #:row-var r)))
|
||||
(-polyrow (r) (list null null null)
|
||||
(t:-> (make-Class r null null null)
|
||||
(make-Class r null null null)))]
|
||||
(-polyrow (r) (list null null null null)
|
||||
(t:-> (make-Class r null null null null)
|
||||
(make-Class r null null null null)))]
|
||||
[(All (r #:row (init x y z) (field f) m n)
|
||||
((Class #:row-var r) -> (Class #:row-var r)))
|
||||
(-polyrow (r) (list '(x y z) '(f) '(m n))
|
||||
(t:-> (make-Class r null null null)
|
||||
(make-Class r null null null)))]
|
||||
(-polyrow (r) (list '(x y z) '(f) '(m n) '())
|
||||
(t:-> (make-Class r null null null null)
|
||||
(make-Class r null null null null)))]
|
||||
;; Class types cannot use a row variable that doesn't constrain
|
||||
;; all of its members to be absent in the row
|
||||
[FAIL (All (r #:row (init x))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user