First cut of converting object-contract to share a common base that
object/c will also use. svn: r18274
This commit is contained in:
Stevie Strickland
parent
815dd80923
commit
d820493feb
|
|
@ -13,27 +13,6 @@
|
|||
implementation?/c
|
||||
object-contract)
|
||||
|
||||
;; example of how one contract is constructed
|
||||
#;
|
||||
(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
|
||||
[cf (-> integer? integer?)]
|
||||
[m-proj ((contract-projection cm)
|
||||
(make-blame #'here #f "whatever" 'pos 'neg #t))]
|
||||
[f-proj ((contract-projection cf)
|
||||
(make-blame #'here #f "whatever" 'pos 'neg #t))]
|
||||
[cls (make-wrapper-class 'wrapper-class
|
||||
'(m)
|
||||
(list
|
||||
(m-proj (λ (this x) (send (wrapper-object-wrapped this) m x))))
|
||||
'(f)
|
||||
#f)]
|
||||
[o (new (class object%
|
||||
(field [f (λ (x) x)])
|
||||
(define/public (m x) x)
|
||||
(super-new)))]
|
||||
[wo (make-object cls o (f-proj (get-field/proc 'f o)))])
|
||||
((get-field/proc 'f wo) #f))
|
||||
|
||||
(define-for-syntax (parse-object-contract stx args)
|
||||
(let loop ([args (syntax->list args)]
|
||||
[mtds '()]
|
||||
|
|
@ -52,55 +31,17 @@
|
|||
[_
|
||||
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
|
||||
|
||||
(define (o-c-first-order ctc val blame meth-projs)
|
||||
(let/ec return
|
||||
(define (failed str . args)
|
||||
(if blame
|
||||
(apply raise-blame-error blame val str args)
|
||||
(return #f)))
|
||||
(unless (object? val)
|
||||
(failed "expected an object, got ~e" val))
|
||||
(let ([meth-names (object-contract-methods ctc)])
|
||||
(for-each (λ (m proj)
|
||||
(let-values ([(method unwrapper)
|
||||
(find-method/who 'object-contract val m #:error? #f)])
|
||||
(unless method
|
||||
(failed "expected an object with method ~s" m))
|
||||
;; verify the first-order properties by apply the projection and
|
||||
;; throwing the result away. Without this, the contract wrappers
|
||||
;; just check the first-order properties of the wrappers, which is
|
||||
;; the wrong thing.
|
||||
(proj method)))
|
||||
meth-names
|
||||
meth-projs))
|
||||
(let ([ctc-field-names (object-contract-fields ctc)]
|
||||
[fields (field-names val)])
|
||||
(for-each (λ (f)
|
||||
(unless (memq f fields)
|
||||
(failed "expected an object with field ~s" f)))
|
||||
ctc-field-names))
|
||||
#t))
|
||||
|
||||
(define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs)
|
||||
(define-struct object-contract (methods method-ctcs fields field-ctcs)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(let ([meth-names (object-contract-methods ctc)]
|
||||
[meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))]
|
||||
[ctc-field-names (object-contract-fields ctc)]
|
||||
[field-param-projs (map contract-projection (object-contract-field-ctcs ctc))])
|
||||
(λ (blame)
|
||||
(let* ([meth-projs (map (λ (x) (x blame)) meth-param-projs)]
|
||||
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
|
||||
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
|
||||
[field-projs (map (λ (x) (x blame)) field-param-projs)])
|
||||
(λ (val)
|
||||
(o-c-first-order ctc val blame meth-projs)
|
||||
(apply make-object cls val
|
||||
(map (λ (field proj) (proj (get-field/proc field val)))
|
||||
ctc-field-names field-projs)))))))
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(make-wrapper-object val blame
|
||||
(object-contract-methods ctc) (object-contract-method-ctcs ctc)
|
||||
(object-contract-fields ctc) (object-contract-field-ctcs ctc)))))
|
||||
#:name
|
||||
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
|
||||
(object-contract-fields ctc)
|
||||
|
|
@ -112,7 +53,7 @@
|
|||
#:first-order
|
||||
(λ (ctc)
|
||||
(λ (val)
|
||||
(o-c-first-order ctc val #f (map (λ (x) values) (object-contract-method-ctcs ctc)))))))
|
||||
(check-object-contract val #f (object-contract-methods ctc) (object-contract-fields ctc))))))
|
||||
|
||||
(define-syntax (object-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -124,14 +65,12 @@
|
|||
(syntax->list #'(method-id ...)))])
|
||||
#'(build-object-contract '(method-id ...)
|
||||
(syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
|
||||
(list (λ (this . x) (send (wrapper-object-wrapped this) method-id . x)) ...)
|
||||
'(field-id ...)
|
||||
(list field-ctc ...))))]))
|
||||
|
||||
(define (build-object-contract methods method-ctcs wrappers fields field-ctcs)
|
||||
(define (build-object-contract methods method-ctcs fields field-ctcs)
|
||||
(make-object-contract methods
|
||||
(map (λ (x) (coerce-contract 'object-contract x)) method-ctcs)
|
||||
wrappers
|
||||
fields
|
||||
(map (λ (x) (coerce-contract 'object-contract x)) field-ctcs)))
|
||||
|
||||
|
|
|
|||
|
|
@ -2994,7 +2994,7 @@
|
|||
augments augment-ctcs
|
||||
augrides augride-ctcs))))]))
|
||||
|
||||
(define (object/c-check-first-order ctc obj blame)
|
||||
(define (check-object-contract obj blame methods fields)
|
||||
(let/ec return
|
||||
(define (failed str . args)
|
||||
(if blame
|
||||
|
|
@ -3004,19 +3004,24 @@
|
|||
(failed "not a object"))
|
||||
(let ([cls (object-ref obj)])
|
||||
(let ([method-ht (class-method-ht cls)])
|
||||
(for ([m (object/c-methods ctc)])
|
||||
(for ([m methods])
|
||||
(unless (hash-ref method-ht m #f)
|
||||
(failed "no public method ~a" m))))
|
||||
(let ([field-ht (class-field-ht cls)])
|
||||
(for ([m (object/c-fields ctc)])
|
||||
(for ([m fields])
|
||||
(unless (hash-ref field-ht m #f)
|
||||
(failed "no public field ~a" m)))))))
|
||||
|
||||
(define (object/c-check-first-order ctc obj blame)
|
||||
(check-object-contract obj blame (object/c-methods) (object/c-fields)))
|
||||
|
||||
(define (object/c-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (obj)
|
||||
(object/c-check-first-order ctc obj blame)
|
||||
obj)))
|
||||
(make-wrapper-object obj blame
|
||||
(object/c-methods ctc) (object/c-method-contracts ctc)
|
||||
(object/c-fields ctc) (object/c-field-contracts ctc)))))
|
||||
|
||||
(define-struct object/c (methods method-contracts fields field-contracts)
|
||||
#:omit-define-syntaxes
|
||||
|
|
@ -3835,8 +3840,6 @@
|
|||
(cond
|
||||
[index
|
||||
((vector-ref (class-ext-field-sets cls) index) obj val)]
|
||||
[(wrapper-object? obj)
|
||||
(loop (wrapper-object-wrapped obj))]
|
||||
[else
|
||||
(raise-mismatch-error
|
||||
'get-field
|
||||
|
|
@ -3876,8 +3879,6 @@
|
|||
(cond
|
||||
[index
|
||||
((vector-ref (class-ext-field-refs cls) index) obj)]
|
||||
[(wrapper-object? obj)
|
||||
(loop (wrapper-object-wrapped obj))]
|
||||
[else
|
||||
(raise-mismatch-error
|
||||
'get-field
|
||||
|
|
@ -3913,10 +3914,8 @@
|
|||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)])
|
||||
(or (and (hash-ref field-ht id #f)
|
||||
#t) ;; ensure that only #t and #f leak out, not bindings in ht
|
||||
(and (wrapper-object? obj)
|
||||
(loop (wrapper-object-wrapped obj))))))))
|
||||
(and (hash-ref field-ht id #f)
|
||||
#t))))) ;; ensure that only #t and #f leak out, not bindings in ht
|
||||
|
||||
(define-traced (field-names obj)
|
||||
(unless (object? obj)
|
||||
|
|
@ -3930,9 +3929,7 @@
|
|||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[flds (filter interned? (hash-map field-ht (lambda (x y) x)))])
|
||||
(if (wrapper-object? obj)
|
||||
(append flds (loop (wrapper-object-wrapped obj)))
|
||||
flds)))))
|
||||
flds))))
|
||||
|
||||
(define-syntaxes (with-method with-method-traced)
|
||||
(let ()
|
||||
|
|
@ -4059,7 +4056,6 @@
|
|||
(cond
|
||||
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
|
||||
(add1 cnt))]
|
||||
[(wrapper-object? o) (loop (wrapper-object-wrapped o))]
|
||||
[else #f])))))
|
||||
|
||||
(define (implementation? v i)
|
||||
|
|
@ -4262,15 +4258,12 @@
|
|||
;; wrapper for contracts
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(define-struct wrapper-field (name ctc-stx))
|
||||
(define-struct wrapper-method (name mth-stx))
|
||||
|
||||
(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
|
||||
(let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
|
||||
(make-struct-type 'raw-wrapper-object
|
||||
#f
|
||||
0
|
||||
1)])
|
||||
1
|
||||
0)])
|
||||
(values wrapper-object?
|
||||
(lambda (v) (ref v 0))
|
||||
(lambda (o v) (set! o 0 v))
|
||||
|
|
@ -4283,161 +4276,137 @@
|
|||
(loop (wrapper-object-wrapped o))
|
||||
o)))
|
||||
|
||||
;; make-wrapper-class : symbol
|
||||
;; (listof symbol)
|
||||
;; method-spec [depends on the boolean what it is]
|
||||
;; (listof symbol)
|
||||
;; boolean
|
||||
;; -> class
|
||||
;; the resulting class is the "proxy" class for the contracted version of an
|
||||
;; object with contracts on the method-ids.
|
||||
|
||||
;; Overall, objects of this class have one field for the original object,
|
||||
;; one field per method in the contract and one field per field in the contract.
|
||||
;; Each of the methods (passed in) just accesses the initial (method) fields
|
||||
;; (which contain procedures) and calls them and returns their results.
|
||||
;; Those fields do not show up from outside of this file, via the usual
|
||||
;; field accessors. In addition, the class has one field per field that
|
||||
;; will contain the contracted versions of the input fields.
|
||||
;; The class accepts one initialization argument per method and
|
||||
;; one init arg per field (in that order) using the make-object style
|
||||
;; initialization.
|
||||
(define (make-wrapper-class class-name method-ids methods field-ids old-style?)
|
||||
(let* ([supers (vector object% #f)]
|
||||
[method-ht (make-hasheq)]
|
||||
[method-count (length method-ids)]
|
||||
[methods-vec (make-vector method-count #f)]
|
||||
[int-methods-vec (make-vector method-count)]
|
||||
[dynamic-idxs (make-vector method-count 0)]
|
||||
[dynamic-projs (make-vector method-count (vector values))]
|
||||
|
||||
[field-ht (make-hasheq)]
|
||||
[field-count (length field-ids)]
|
||||
[int-field-refs (make-vector field-count)]
|
||||
[int-field-sets (make-vector field-count)]
|
||||
[ext-field-refs (make-vector field-count)]
|
||||
[ext-field-sets (make-vector field-count)]
|
||||
|
||||
[cls
|
||||
(make-class class-name
|
||||
1
|
||||
supers
|
||||
'bogus-self-interface
|
||||
void ; nothing can be inspected
|
||||
|
||||
method-count
|
||||
method-ht
|
||||
(reverse method-ids)
|
||||
|
||||
methods-vec
|
||||
methods-vec
|
||||
int-methods-vec
|
||||
(list->vector (map (lambda (x) 'final) method-ids))
|
||||
'dont-use-me!
|
||||
(make-vector method-count values)
|
||||
dynamic-idxs
|
||||
dynamic-projs
|
||||
|
||||
(if old-style?
|
||||
(+ field-count method-count 1)
|
||||
field-count)
|
||||
field-count
|
||||
field-ht
|
||||
field-ids
|
||||
|
||||
int-field-refs
|
||||
int-field-sets
|
||||
ext-field-refs
|
||||
ext-field-sets
|
||||
|
||||
#f; struct:object
|
||||
#f; object?
|
||||
#f; make-object ;; -> void
|
||||
#f; field-ref
|
||||
#f; field-set!
|
||||
|
||||
#f ;; only by position arguments
|
||||
'normal ; init-mode - ??
|
||||
|
||||
#f ; init
|
||||
#f ; orig-cls
|
||||
#f #f ; not serializable
|
||||
#f)])
|
||||
(let-values ([(struct:object make-object object? field-ref field-set!)
|
||||
(make-struct-type 'wrapper-object
|
||||
(define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts)
|
||||
(let* ([name (class-name cls)]
|
||||
[method-width (class-method-width cls)]
|
||||
[method-ht (class-method-ht cls)]
|
||||
[methods (if (null? methods)
|
||||
(class-methods cls)
|
||||
(make-vector method-width))]
|
||||
[field-pub-width (class-field-pub-width cls)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[int-field-refs (make-vector field-pub-width)]
|
||||
[int-field-sets (make-vector field-pub-width)]
|
||||
[ext-field-refs (make-vector field-pub-width)]
|
||||
[ext-field-sets (make-vector field-pub-width)]
|
||||
[class-make (if name
|
||||
(make-naming-constructor
|
||||
struct:class
|
||||
(string->symbol (format "class:~a" name)))
|
||||
make-class)]
|
||||
[c (class-make name
|
||||
(class-pos cls)
|
||||
(list->vector (vector->list (class-supers cls)))
|
||||
(class-self-interface cls)
|
||||
void ;; No inspecting
|
||||
|
||||
method-width
|
||||
method-ht
|
||||
(class-method-ids cls)
|
||||
|
||||
methods
|
||||
(class-super-methods cls)
|
||||
(class-int-methods cls)
|
||||
(class-beta-methods cls)
|
||||
(class-meth-flags cls)
|
||||
|
||||
(class-inner-projs cls)
|
||||
(class-dynamic-idxs cls)
|
||||
(class-dynamic-projs cls)
|
||||
|
||||
(class-field-width cls)
|
||||
field-pub-width
|
||||
field-ht
|
||||
(class-field-ids cls)
|
||||
|
||||
int-field-refs
|
||||
int-field-sets
|
||||
ext-field-refs
|
||||
ext-field-sets
|
||||
|
||||
'struct:object 'object? 'make-object
|
||||
'field-ref 'field-set!
|
||||
|
||||
(class-init-args cls)
|
||||
(class-init-mode cls)
|
||||
(class-init cls)
|
||||
|
||||
(class-orig-cls cls)
|
||||
#f #f ; serializer is never set
|
||||
#f)]
|
||||
[obj-name (if name
|
||||
(string->symbol (format "wrapper-object:~a" name))
|
||||
'object)])
|
||||
|
||||
(vector-set! (class-supers c) (class-pos c) c)
|
||||
|
||||
;; --- Make the new object struct ---
|
||||
(let-values ([(struct:object object-make object? object-field-ref object-field-set!)
|
||||
(make-struct-type obj-name
|
||||
struct:wrapper-object
|
||||
0
|
||||
(if old-style?
|
||||
(+ (length field-ids) (length method-ids))
|
||||
(length field-ids))
|
||||
0 ;; No init fields
|
||||
0 ;; No new fields in this wrapped object
|
||||
undefined
|
||||
(list (cons prop:object cls))
|
||||
insp)])
|
||||
(set-class-struct:object! cls struct:object)
|
||||
(set-class-object?! cls object?)
|
||||
(set-class-make-object! cls make-object)
|
||||
(set-class-field-ref! cls field-ref)
|
||||
(set-class-field-set!! cls field-set!)
|
||||
|
||||
(set-class-orig-cls! cls cls)
|
||||
|
||||
(let ([init
|
||||
(lambda (o continue-make-super c inited? named-args leftover-args)
|
||||
;; leftover args will contain the original object and new field values
|
||||
;; fill the original object in and then fill in the fields.
|
||||
(set-wrapper-object-wrapped! o (car leftover-args))
|
||||
(let loop ([leftover-args (cdr leftover-args)]
|
||||
[i 0])
|
||||
(unless (null? leftover-args)
|
||||
(field-set! o i (car leftover-args))
|
||||
(loop (cdr leftover-args)
|
||||
(+ i 1))))
|
||||
(continue-make-super o c inited? '() '() '()))])
|
||||
(set-class-init! cls init))
|
||||
|
||||
;; fill in the methods vector & methods-ht
|
||||
(let loop ([i 0]
|
||||
[methods methods]
|
||||
[method-ids method-ids])
|
||||
(when (< i method-count)
|
||||
(vector-set! methods-vec i (if old-style?
|
||||
((car methods) field-ref)
|
||||
(car methods)))
|
||||
(vector-set! int-methods-vec i
|
||||
(vector (if old-style?
|
||||
((car methods) field-ref)
|
||||
(car methods))))
|
||||
(hash-set! method-ht (car method-ids) i)
|
||||
(loop (+ i 1)
|
||||
(cdr methods)
|
||||
(cdr method-ids))))
|
||||
|
||||
;; fill in the fields-ht
|
||||
(let loop ([i 0]
|
||||
[field-ids field-ids])
|
||||
(when (< i field-count)
|
||||
(hash-set! field-ht (car field-ids) i)
|
||||
(vector-set! int-field-refs i
|
||||
(make-struct-field-accessor field-ref i #f))
|
||||
(vector-set! int-field-sets i
|
||||
(make-struct-field-mutator field-set! i #f))
|
||||
(vector-set! ext-field-refs i
|
||||
(make-struct-field-accessor field-ref i (car field-ids)))
|
||||
(vector-set! ext-field-sets i
|
||||
(make-struct-field-mutator field-set! i (car field-ids)))
|
||||
(loop (+ i 1)
|
||||
(cdr field-ids))))
|
||||
|
||||
;; fill in the supers vector
|
||||
(vector-set! supers 1 cls)
|
||||
|
||||
cls)))
|
||||
;; Map object property to class:
|
||||
(list (cons prop:object c)))])
|
||||
(set-class-struct:object! c struct:object)
|
||||
(set-class-object?! c object?)
|
||||
(set-class-make-object! c object-make)
|
||||
(set-class-field-ref! c object-field-ref)
|
||||
(set-class-field-set!! c object-field-set!))
|
||||
|
||||
;; Handle public method contracts
|
||||
(unless (null? methods)
|
||||
;; First, fill in from old methods
|
||||
(vector-copy! methods 0 (class-methods cls))
|
||||
;; Now apply projections
|
||||
(for ([m (in-list methods)]
|
||||
[c (in-list method-contracts)])
|
||||
(when c
|
||||
(let ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) blame)])
|
||||
(vector-set! methods i (p (vector-ref methods i)))))))
|
||||
|
||||
;; Redirect internal/external field accessors/mutators
|
||||
(let ([old-int-refs (class-int-field-refs cls)]
|
||||
[old-int-sets (class-int-field-sets cls)]
|
||||
[old-ext-refs (class-ext-field-refs cls)]
|
||||
[old-ext-sets (class-ext-field-sets cls)])
|
||||
(for ([i (in-range field-pub-width)])
|
||||
(let ([old-int-ref (vector-ref old-int-refs i)]
|
||||
[old-int-set (vector-ref old-int-sets i)]
|
||||
[old-ext-ref (vector-ref old-ext-refs i)]
|
||||
[old-ext-set (vector-ref old-ext-sets i)])
|
||||
;; Take in the object, then completely ignore it.
|
||||
(vector-set! int-field-refs i (λ (o) (old-int-ref obj)))
|
||||
(vector-set! int-field-sets i (λ (o) (old-int-set obj)))
|
||||
(vector-set! ext-field-refs i (λ (o) (old-ext-ref obj)))
|
||||
(vector-set! ext-field-sets i (λ (o) (old-ext-set obj))))))
|
||||
|
||||
;; Handle external field contracts
|
||||
(unless (null? fields)
|
||||
(let ([bset (blame-swap blame)])
|
||||
(for ([f (in-list fields)]
|
||||
[c (in-list field-contracts)])
|
||||
(when c
|
||||
(let* ([i (hash-ref field-ht f)]
|
||||
[pre-p (contract-projection c)]
|
||||
[old-ref (vector-ref ext-field-refs i)]
|
||||
[old-set (vector-ref ext-field-sets i)])
|
||||
(vector-set! ext-field-refs i
|
||||
(λ (o)
|
||||
((pre-p blame) (old-ref o))))
|
||||
(vector-set! ext-field-sets i
|
||||
(λ (o v)
|
||||
(old-set o ((pre-p bset) v)))))))))
|
||||
|
||||
c))
|
||||
|
||||
; extract-vtable : object -> (vectorof method-proc[this args ... -> res])
|
||||
(define (extract-vtable o) (class-methods (object-ref o)))
|
||||
|
||||
; extract-method-ht : object -> hash-table[sym -> number]
|
||||
(define (extract-method-ht o) (class-method-ht (object-ref o)))
|
||||
;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?)
|
||||
(define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
|
||||
(check-object-contract obj blame methods fields)
|
||||
(let ([new-cls (make-wrapper-class obj (object-ref obj) blame methods method-contracts fields field-contracts)])
|
||||
((class-make-object new-cls) obj)))
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; misc utils
|
||||
|
|
@ -4626,10 +4595,8 @@
|
|||
)
|
||||
|
||||
;; Providing normal functionality:
|
||||
(provide (protect-out make-wrapper-class
|
||||
wrapper-object-wrapped
|
||||
extract-vtable
|
||||
extract-method-ht
|
||||
(provide (protect-out make-wrapper-object
|
||||
check-object-contract
|
||||
get-field/proc)
|
||||
|
||||
(rename-out [_class class]) class* class/derived
|
||||
|
|
|
|||
|
|
@ -3043,10 +3043,12 @@
|
|||
|
||||
(test/pos-blame
|
||||
'object-contract/field2
|
||||
'(contract (object-contract (field x integer?))
|
||||
(new (class object% (field [x #t]) (super-new)))
|
||||
'pos
|
||||
'neg))
|
||||
'(get-field
|
||||
x
|
||||
(contract (object-contract (field x integer?))
|
||||
(new (class object% (field [x #t]) (super-new)))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'object-contract/field3
|
||||
|
|
@ -3060,17 +3062,21 @@
|
|||
|
||||
(test/pos-blame
|
||||
'object-contract/field4
|
||||
'(contract (object-contract (field x boolean?) (field y boolean?))
|
||||
(new (class object% (field [x #t] [y 'x]) (super-new)))
|
||||
'pos
|
||||
'neg))
|
||||
'(get-field
|
||||
y
|
||||
(contract (object-contract (field x boolean?) (field y boolean?))
|
||||
(new (class object% (field [x #t] [y 'x]) (super-new)))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'object-contract/field5
|
||||
'(contract (object-contract (field x symbol?) (field y symbol?))
|
||||
(new (class object% (field [x #t] [y 'x]) (super-new)))
|
||||
'pos
|
||||
'neg))
|
||||
'(get-field
|
||||
x
|
||||
(contract (object-contract (field x symbol?) (field y symbol?))
|
||||
(new (class object% (field [x #t] [y 'x]) (super-new)))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'object-contract/field6
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user