suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adds object/c and fixes object-contract to have the same semantics.

Browse Source 
Contracts written in object-contract forms still have the same restrictions,
but object/c is the unrestricted version.

svn: r18320
This commit is contained in:
Stevie Strickland 2010-02-24 16:43:06 +00:00
commit c5a3b9ee16
31 changed files with 481 additions and 609 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/kernel.ss
View File

@ -78,9 +78,9 @@
(syntax (syntax
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) (define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(make-primitive-class (make-primitive-class
(lambda (class prop:object preparer dispatcher more-props) (lambda (class prop:object preparer dispatcher prop:unwrap more-props)
(kernel:primitive-class-prepare-struct-type! (kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher more-props)) c prop:object class preparer dispatcher prop:unwrap more-props))
kernel:initialize-primitive-object kernel:initialize-primitive-object
'print-name super (list intf ...) 'args 'print-name super (list intf ...) 'args
'(old ...) '(old ...)

107
collects/mzlib/private/contract-object.ss
View File

@ -246,51 +246,6 @@
(raise-syntax-error 'object-contract "malformed ->pp-rest declaration")] (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
[else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)])) [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx mtds)
(define (last-pair l)
(cond
[(not (pair? (cdr l))) l]
[else (last-pair (cdr l))]))
(let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
[names (map mtd-name mtds)]
[i 0])
(cond
[(null? arg-spec-stxss) null]
[else (let ([arg-spec-stxs (car arg-spec-stxss)])
(with-syntax ([(cases ...)
(map (lambda (arg-spec-stx)
(with-syntax ([i i])
(syntax-case arg-spec-stx ()
[(this rest-ids ...)
(syntax
((this rest-ids ...)
((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))]
[else
(let-values ([(this rest-ids last-var)
(let ([lst (syntax->improper-list arg-spec-stx)])
(values (car lst)
(all-but-last (cdr lst))
(cdr (last-pair lst))))])
(with-syntax ([this this]
[(rest-ids ...) rest-ids]
[last-var last-var])
(syntax
((this rest-ids ... . last-var)
(apply (field-ref this i)
(wrapper-object-wrapped this)
rest-ids ...
last-var)))))])))
(syntax->list arg-spec-stxs))]
[name (string->symbol (format "~a method" (syntax->datum (car names))))])
(with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss)
(cdr names)
(+ i 1))))))])))
(define (syntax->improper-list stx) (define (syntax->improper-list stx)
(define (se->il se) (define (se->il se)
(cond (cond
@ -317,61 +272,29 @@
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
[(method-name ...) (map mtd-name mtds)] [(method-name ...) (map mtd-name mtds)]
[(method-ctc-var ...) (generate-temporaries mtds)] [(method-ctc-var ...) (generate-temporaries mtds)]
[(method-var ...) (generate-temporaries mtds)]
[(method/app-var ...) (generate-temporaries mtds)]
[(methods ...) (build-methods-stx mtds)]
[(field-ctc-stx ...) (map fld-ctc-stx flds)] [(field-ctc-stx ...) (map fld-ctc-stx flds)]
[(field-name ...) (map fld-name flds)] [(field-name ...) (map fld-name flds)]
[(field-ctc-var ...) (generate-temporaries flds)] [(field-ctc-var ...) (generate-temporaries flds)])
[(field-var ...) (generate-temporaries flds)]
[(field/app-var ...) (generate-temporaries flds)])
(syntax (syntax
(let ([method-ctc-var method-ctc-stx] (let ([method-ctc-var method-ctc-stx]
... ...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...) ...)
(let ([method-var (contract-projection method-ctc-var)] (make-contract
... #:name
[field-var (contract-projection field-ctc-var)] `(object-contract
...) ,(build-compound-type-name 'method-name method-ctc-var) ...
(let ([cls (make-wrapper-class 'wrapper-class ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
'(method-name ...) #:projection
(list methods ...) (lambda (blame)
'(field-name ...) (lambda (val)
#t)]) (make-wrapper-object val blame
(make-contract (list 'method-name ...) (list method-ctc-var ...)
#:name (list 'field-name ...) (list field-ctc-var ...))))
`(object-contract #:first-order
,(build-compound-type-name 'method-name method-ctc-var) ... (lambda (val)
,(build-compound-type-name 'field 'field-name field-ctc-var) ...) (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))]))))
#:projection
(lambda (blame)
(let ([method/app-var (method-var blame)]
...
[field/app-var (field-var blame)]
...)
(let ([field-names-list '(field-name ...)])
(lambda (val)
(check-object val blame)
(let ([val-mtd-names
(interface->method-names
(object-interface
val))])
(void)
(check-method val 'method-name val-mtd-names blame)
...)
(unless (field-bound? field-name val)
(field-error val 'field-name blame)) ...
(let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(make-object cls
val
(method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ...
)))))))))))))]))))
(define (check-object val blame) (define (check-object val blame)

77
collects/scheme/contract/private/object.ss
View File

@ -13,27 +13,6 @@
implementation?/c implementation?/c
object-contract) 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) (define-for-syntax (parse-object-contract stx args)
(let loop ([args (syntax->list args)] (let loop ([args (syntax->list args)]
[mtds '()] [mtds '()]
@ -52,55 +31,17 @@
[_ [_
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])]))) (raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
(define (o-c-first-order ctc val blame meth-projs) (define-struct object-contract (methods method-ctcs fields field-ctcs)
(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)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection #:projection
(λ (ctc) (λ (ctc)
(let ([meth-names (object-contract-methods ctc)] (λ (blame)
[meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))] (λ (val)
[ctc-field-names (object-contract-fields ctc)] (make-wrapper-object val blame
[field-param-projs (map contract-projection (object-contract-field-ctcs ctc))]) (object-contract-methods ctc) (object-contract-method-ctcs ctc)
(λ (blame) (object-contract-fields ctc) (object-contract-field-ctcs ctc)))))
(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)))))))
#:name #:name
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc) (object-contract-fields ctc)
@ -112,7 +53,7 @@
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(λ (val) (λ (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) (define-syntax (object-contract stx)
(syntax-case stx () (syntax-case stx ()
@ -124,14 +65,12 @@
(syntax->list #'(method-id ...)))]) (syntax->list #'(method-id ...)))])
#'(build-object-contract '(method-id ...) #'(build-object-contract '(method-id ...)
(syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...)) (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 ...) '(field-id ...)
(list field-ctc ...))))])) (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 (make-object-contract methods
(map (λ (x) (coerce-contract 'object-contract x)) method-ctcs) (map (λ (x) (coerce-contract 'object-contract x)) method-ctcs)
wrappers
fields fields
(map (λ (x) (coerce-contract 'object-contract x)) field-ctcs))) (map (λ (x) (coerce-contract 'object-contract x)) field-ctcs)))

535
collects/scheme/private/class-internal.ss
View File

@ -56,7 +56,7 @@
method-in-interface? interface->method-names class->interface class-info method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object) (struct-out exn:fail:object)
make-primitive-class make-primitive-class
class/c ->m ->*m #| object/c |# class/c ->m ->*m object/c
;; "keywords": ;; "keywords":
private public override augment private public override augment
@ -194,6 +194,28 @@
"used before its definition: ~a" "used before its definition: ~a"
orig))) orig)))
;;--------------------------------------------------------------------
;; object wrapper for contracts
;;--------------------------------------------------------------------
(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
1
0)])
(values wrapper-object?
(lambda (v) (ref v 0))
(lambda (o v) (set! o 0 v))
struct:wrapper-object)))
(define-values (prop:unwrap object-unwrapper)
(let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)])
;; Instead of using the accessor if it has prop:unwrap, just use the unwrapper
;; from wrapper-object directly, since we know it must be a wrapped object.
;; (The accessor will just give us that anyway.)
(values prop:unwrap (λ (o) (if (pred o) (wrapper-object-wrapped o) o)))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; class macros ;; class macros
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -1165,6 +1187,7 @@
(make-field-map trace-flag (make-field-map trace-flag
(quote-syntax the-finder) (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax object-unwrapper)
(quote-syntax inherit-field-name) (quote-syntax inherit-field-name)
(quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-name-localized)
(quote-syntax inherit-field-accessor) (quote-syntax inherit-field-accessor)
@ -1174,6 +1197,7 @@
(make-field-map trace-flag (make-field-map trace-flag
(quote-syntax the-finder) (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax object-unwrapper)
(quote-syntax local-field) (quote-syntax local-field)
(quote-syntax local-field-localized) (quote-syntax local-field-localized)
(quote-syntax local-field-accessor) (quote-syntax local-field-accessor)
@ -1329,17 +1353,13 @@
;; Methods (when given needed super-methods, etc.): ;; Methods (when given needed super-methods, etc.):
#, ;; Attach srcloc (useful for profiling) #, ;; Attach srcloc (useful for profiling)
(quasisyntax/loc stx (quasisyntax/loc stx
(lambda (local-accessor (lambda (local-field-accessor ...
local-mutator local-field-mutator ...
inherit-field-accessor ... ; inherit inherit-field-accessor ... ; inherit
inherit-field-mutator ... inherit-field-mutator ...
rename-super-temp ... rename-super-extra-temp ... rename-super-temp ... rename-super-extra-temp ...
rename-inner-temp ... rename-inner-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ...
method-accessor ...) ; for a local call that needs a dynamic lookup method-accessor ...) ; for a local call that needs a dynamic lookup
(let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)]
...
[local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)]
...)
(syntax-parameterize (syntax-parameterize
([this-param (make-this-map (quote-syntax this-id) ([this-param (make-this-map (quote-syntax this-id)
(quote-syntax the-finder) (quote-syntax the-finder)
@ -1461,7 +1481,7 @@
(quote-syntax plain-init-name-localized))] ...) (quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...) ([(local-plain-init-name) undefined] ...)
(void) ; in case the body is empty (void) ; in case the body is empty
. exprs))))))))))))) . exprs))))))))))))
;; Not primitive: ;; Not primitive:
#f)))))))))))))))) #f))))))))))))))))
@ -2106,7 +2126,10 @@
;; --- Make the new object struct --- ;; --- Make the new object struct ---
(let*-values ([(prim-object-make prim-object? struct:prim-object) (let*-values ([(prim-object-make prim-object? struct:prim-object)
(if make-struct:prim (if make-struct:prim
(make-struct:prim c prop:object preparer dispatcher (get-properties interfaces)) (make-struct:prim c prop:object
preparer dispatcher
prop:unwrap
(get-properties interfaces))
(values #f #f #f))] (values #f #f #f))]
[(struct:object object-make object? object-field-ref object-field-set!) [(struct:object object-make object? object-field-ref object-field-set!)
(if make-struct:prim (if make-struct:prim
@ -2150,6 +2173,7 @@
(vector-copy! int-field-sets 0 (class-int-field-sets super)) (vector-copy! int-field-sets 0 (class-int-field-sets super))
(vector-copy! ext-field-refs 0 (class-ext-field-refs super)) (vector-copy! ext-field-refs 0 (class-ext-field-refs super))
(vector-copy! ext-field-sets 0 (class-ext-field-sets super)) (vector-copy! ext-field-sets 0 (class-ext-field-sets super))
;; For public fields, set both the internal and external accessors/mutators.
(for ([n (in-range (class-field-pub-width super) field-pub-width)] (for ([n (in-range (class-field-pub-width super) field-pub-width)]
[i (in-naturals)] [i (in-naturals)]
[id (in-list public-field-names)]) [id (in-list public-field-names)])
@ -2160,10 +2184,17 @@
;; --- Build field accessors and mutators --- ;; --- Build field accessors and mutators ---
;; Use public field names to name the accessors and mutators ;; Use public field names to name the accessors and mutators
(let-values ([(inh-accessors inh-mutators) (let-values ([(local-accessors local-mutators)
(values (map (lambda (id) (vector-ref int-field-refs (hash-ref field-ht id))) (values (for/list ([n (in-range num-fields)])
(make-struct-field-accessor object-field-ref n #f))
(for/list ([n (in-range num-fields)])
(make-struct-field-mutator object-field-set! n #f)))]
[(inh-accessors inh-mutators)
(values (map (lambda (id)
(vector-ref int-field-refs (hash-ref field-ht id)))
inherit-field-names) inherit-field-names)
(map (lambda (id) (vector-ref int-field-sets (hash-ref field-ht id))) (map (lambda (id)
(vector-ref int-field-sets (hash-ref field-ht id)))
inherit-field-names))]) inherit-field-names))])
;; -- Extract superclass methods and make rename-inners --- ;; -- Extract superclass methods and make rename-inners ---
@ -2260,9 +2291,9 @@
;; -- Get new methods and initializers -- ;; -- Get new methods and initializers --
(let-values ([(new-methods override-methods augride-methods init) (let-values ([(new-methods override-methods augride-methods init)
(apply make-methods (apply make-methods
object-field-ref (append local-accessors
object-field-set! local-mutators
(append inh-accessors inh-accessors
inh-mutators inh-mutators
rename-supers rename-supers
rename-inners rename-inners
@ -2544,6 +2575,13 @@
(λ (cls) (λ (cls)
(class/c-check-first-order ctc cls blame) (class/c-check-first-order ctc cls blame)
(let* ([name (class-name cls)] (let* ([name (class-name cls)]
;; Only add a new slot if we're not projecting an already contracted class.
[supers (if (eq? (class-orig-cls cls) cls)
(list->vector (append (vector->list (class-supers cls)) (list #f)))
(list->vector (vector->list (class-supers cls))))]
[pos (if (eq? (class-orig-cls cls) cls)
(add1 (class-pos cls))
(class-pos cls))]
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
[method-ht (class-method-ht cls)] [method-ht (class-method-ht cls)]
[dynamic-features [dynamic-features
@ -2594,8 +2632,8 @@
(string->symbol (format "class:~a" name))) (string->symbol (format "class:~a" name)))
make-class)] make-class)]
[c (class-make name [c (class-make name
(class-pos cls) pos
(list->vector (vector->list (class-supers cls))) supers
(class-self-interface cls) (class-self-interface cls)
void ;; No inspecting void ;; No inspecting
@ -2632,12 +2670,12 @@
(class-orig-cls cls) (class-orig-cls cls)
#f #f ; serializer is never set #f #f ; serializer is never set
#f)] (class-no-super-init? cls))]
[obj-name (if name [obj-name (if name
(string->symbol (format "object:~a" name)) (string->symbol (format "object:~a" name))
'object)]) 'object)])
(vector-set! (class-supers c) (class-pos c) c) (vector-set! supers pos c)
;; --- Make the new object struct --- ;; --- Make the new object struct ---
(let-values ([(struct:object object-make object? object-field-ref object-field-set!) (let-values ([(struct:object object-make object? object-field-ref object-field-set!)
@ -2703,11 +2741,9 @@
[old-ref (vector-ref ext-field-refs i)] [old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)]) [old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i (vector-set! ext-field-refs i
(λ (o) (λ (o) ((pre-p blame) (old-ref o))))
((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i (vector-set! ext-field-sets i
(λ (o v) (λ (o v) (old-set o ((pre-p bset) v)))))))))
(old-set o ((pre-p bset) v)))))))))
;; Handle internal field contracts ;; Handle internal field contracts
(unless (null? (class/c-inherit-fields ctc)) (unless (null? (class/c-inherit-fields ctc))
@ -2722,11 +2758,9 @@
[old-ref (vector-ref int-field-refs i)] [old-ref (vector-ref int-field-refs i)]
[old-set (vector-ref int-field-sets i)]) [old-set (vector-ref int-field-sets i)])
(vector-set! int-field-refs i (vector-set! int-field-refs i
(λ (o) (λ (o) ((pre-p blame) (old-ref o))))
((pre-p blame) (old-ref o))))
(vector-set! int-field-sets i (vector-set! int-field-sets i
(λ (o v) (λ (o v) (old-set o ((pre-p bset) v)))))))))
(old-set o ((pre-p bset) v)))))))))
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
;; First we update any dynamic indexes, as applicable. ;; First we update any dynamic indexes, as applicable.
@ -2993,7 +3027,7 @@
augments augment-ctcs augments augment-ctcs
augrides augride-ctcs))))])) augrides augride-ctcs))))]))
(define (object/c-check-first-order ctc obj blame) (define (check-object-contract obj blame methods fields)
(let/ec return (let/ec return
(define (failed str . args) (define (failed str . args)
(if blame (if blame
@ -3003,19 +3037,21 @@
(failed "not a object")) (failed "not a object"))
(let ([cls (object-ref obj)]) (let ([cls (object-ref obj)])
(let ([method-ht (class-method-ht cls)]) (let ([method-ht (class-method-ht cls)])
(for ([m (object/c-methods ctc)]) (for ([m methods])
(unless (hash-ref method-ht m #f) (unless (hash-ref method-ht m #f)
(failed "no public method ~a" m)))) (failed "no public method ~a" m))))
(let ([field-ht (class-field-ht cls)]) (let ([field-ht (class-field-ht cls)])
(for ([m (object/c-fields ctc)]) (for ([m fields])
(unless (hash-ref field-ht m #f) (unless (hash-ref field-ht m #f)
(failed "no public field ~a" m))))))) (failed "no public field ~a" m)))))))
(define (object/c-proj ctc) (define (object/c-proj ctc)
(λ (blame) (λ (blame)
(λ (obj) (λ (obj)
(object/c-check-first-order ctc obj blame) (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc))
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) (define-struct object/c (methods method-contracts fields field-contracts)
#:omit-define-syntaxes #:omit-define-syntaxes
@ -3042,8 +3078,7 @@
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(λ (obj) (λ (obj)
(with-handlers ([exn:fail:contract? (λ (e) #f)]) (check-object-contract obj #f (object/c-methods ctc) (object/c-fields ctc))))))
(object/c-check-first-order ctc obj #f))))))
(define-syntax (object/c stx) (define-syntax (object/c stx)
(syntax-case stx () (syntax-case stx ()
@ -3568,7 +3603,6 @@
traced? traced?
stx stx
(syntax/loc stx receiver) (syntax/loc stx receiver)
(syntax/loc stx unwrap-object)
(syntax/loc stx method) (syntax/loc stx method)
(syntax/loc stx sym) (syntax/loc stx sym)
args args
@ -3630,38 +3664,20 @@
;; any[object] ;; any[object]
;; symbol[method-name] ;; symbol[method-name]
;; -> (values method-proc object) ;; -> (values method-proc object)
;; returns the method's procedure and a function to unwrap `this' in the case ;; returns the method's procedure and the object. If the object is a contract
;; that this is a wrapper object that is just "falling thru". ;; wrapped one and the original class was a primitive one, then the method
(define (find-method/who who in-object name #:error? [error? #t]) ;; will automatically unwrap both the object and any wrapped arguments on entry.
(define (find-method/who who in-object name)
(unless (object? in-object) (unless (object? in-object)
(if error? (obj-error who "target is not an object: ~e for method: ~a"
(obj-error who "target is not an object: ~e for method: ~a" in-object name))
in-object name) (let* ([cls (object-ref in-object)]
(values #f values))) [pos (hash-ref (class-method-ht cls) name #f)])
(if pos
(let-syntax ([loop-body (values (vector-ref (class-methods cls) pos) in-object)
(lambda (stx) (obj-error who "no such method: ~a~a"
(syntax-case stx () name
[(_ abs-object wrapper-case) (for-class (class-name cls))))))
(identifier? (syntax abs-object))
(syntax
(let* ([c (object-ref abs-object)]
[pos (hash-ref (class-method-ht c) name #f)])
(cond
[pos (values (vector-ref (class-methods c) pos) abs-object)]
[(wrapper-object? abs-object) wrapper-case]
[else
(if error?
(obj-error who "no such method: ~a~a"
name
(for-class (class-name c)))
(values #f values))])))]))])
(loop-body
in-object
(let loop ([loop-object in-object])
(loop-body
loop-object
(loop (wrapper-object-wrapped loop-object)))))))
(define-values (make-class-field-accessor make-class-field-mutator) (define-values (make-class-field-accessor make-class-field-mutator)
(let ([mk (λ (who which) (let ([mk (λ (who which)
@ -3749,7 +3765,6 @@
traced? traced?
stx stx
(syntax obj) (syntax obj)
(syntax/loc stx unwrap-object)
(syntax/loc stx ((generic-applicable gen) obj)) (syntax/loc stx ((generic-applicable gen) obj))
(syntax/loc stx (generic-name gen)) (syntax/loc stx (generic-name gen))
flat-stx flat-stx
@ -3827,20 +3842,15 @@
obj)) obj))
(trace-begin (trace-begin
(trace (set-event obj id val)) (trace (set-event obj id val))
(let loop ([obj obj]) (let* ([cls (object-ref obj)]
(let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)]
[field-ht (class-field-ht cls)] [index (hash-ref field-ht id #f)])
[index (hash-ref field-ht id #f)]) (if index
(cond ((vector-ref (class-ext-field-sets cls) index) (object-unwrapper obj) val)
[index (raise-mismatch-error
((vector-ref (class-ext-field-sets cls) index) obj val)] 'get-field
[(wrapper-object? obj) (format "expected an object that has a field named ~s, got " id)
(loop (wrapper-object-wrapped obj))] obj)))))
[else
(raise-mismatch-error
'get-field
(format "expected an object that has a field named ~s, got " id)
obj)])))))
(define-syntaxes (get-field get-field-traced) (define-syntaxes (get-field get-field-traced)
(let () (let ()
@ -3868,20 +3878,15 @@
obj)) obj))
(trace-begin (trace-begin
(trace (get-event obj id)) (trace (get-event obj id))
(let loop ([obj obj]) (let* ([cls (object-ref obj)]
(let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)]
[field-ht (class-field-ht cls)] [index (hash-ref field-ht id #f)])
[index (hash-ref field-ht id #f)]) (if index
(cond ((vector-ref (class-ext-field-refs cls) index) (object-unwrapper obj))
[index (raise-mismatch-error
((vector-ref (class-ext-field-refs cls) index) obj)] 'get-field
[(wrapper-object? obj) (format "expected an object that has a field named ~s, got " id)
(loop (wrapper-object-wrapped obj))] obj)))))
[else
(raise-mismatch-error
'get-field
(format "expected an object that has a field named ~s, got " id)
obj)])))))
(define-syntaxes (field-bound? field-bound?-traced) (define-syntaxes (field-bound? field-bound?-traced)
(let () (let ()
@ -3912,10 +3917,8 @@
(let loop ([obj obj]) (let loop ([obj obj])
(let* ([cls (object-ref obj)] (let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)]) [field-ht (class-field-ht cls)])
(or (and (hash-ref field-ht id #f) (and (hash-ref field-ht id #f)
#t) ;; ensure that only #t and #f leak out, not bindings in ht #t))))) ;; ensure that only #t and #f leak out, not bindings in ht
(and (wrapper-object? obj)
(loop (wrapper-object-wrapped obj))))))))
(define-traced (field-names obj) (define-traced (field-names obj)
(unless (object? obj) (unless (object? obj)
@ -3929,9 +3932,7 @@
(let* ([cls (object-ref obj)] (let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)] [field-ht (class-field-ht cls)]
[flds (filter interned? (hash-map field-ht (lambda (x y) x)))]) [flds (filter interned? (hash-map field-ht (lambda (x y) x)))])
(if (wrapper-object? obj) flds))))
(append flds (loop (wrapper-object-wrapped obj)))
flds)))))
(define-syntaxes (with-method with-method-traced) (define-syntaxes (with-method with-method-traced)
(let () (let ()
@ -3966,8 +3967,7 @@
(quote-syntax set!) (quote-syntax set!)
(quote-syntax id) (quote-syntax id)
(quote-syntax method) (quote-syntax method)
(quote-syntax method-obj) (quote-syntax method-obj))]
(syntax unwrap-object))]
...) ...)
() ()
body0 body1 ...)))))] body0 body1 ...)))))]
@ -4017,20 +4017,22 @@
(define-traced (is-a? v c) (define-traced (is-a? v c)
(trace-begin (trace-begin
(trace (when (object? v) (trace (when (object? v) (inspect-event v)))
(inspect-event v)))
(cond (cond
[(class? c) ((class-object? c) (unwrap-object v))] [(not (object? v)) #f]
[(class? c) ((class-object? (class-orig-cls c)) (object-unwrapper v))]
[(interface? c) [(interface? c)
(and (object? v) (and (object? v)
(implementation? (object-ref (unwrap-object v)) c))] (implementation? (object-ref (object-unwrapper v)) c))]
[else (raise-type-error 'is-a? "class or interface" 1 v c)]))) [else (raise-type-error 'is-a? "class or interface" 1 v c)])))
(define (subclass? v c) (define (subclass? v c)
(unless (class? c) (unless (class? c)
(raise-type-error 'subclass? "class" 1 v c)) (raise-type-error 'subclass? "class" 1 v c))
(and (class? v) (and (class? v)
(let ([p (class-pos c)]) (let* ([c (class-orig-cls c)]
[v (class-orig-cls v)]
[p (class-pos c)])
(and (<= p (class-pos v)) (and (<= p (class-pos v))
(eq? c (vector-ref (class-supers v) p)))))) (eq? c (vector-ref (class-supers v) p))))))
@ -4039,7 +4041,7 @@
(raise-type-error 'object-interface "object" o)) (raise-type-error 'object-interface "object" o))
(trace-begin (trace-begin
(trace (inspect-event o)) (trace (inspect-event o))
(class-self-interface (object-ref (unwrap-object o))))) (class-self-interface (object-ref (object-unwrapper o)))))
(define-traced (object-method-arity-includes? o name cnt) (define-traced (object-method-arity-includes? o name cnt)
(unless (object? o) (unless (object? o)
@ -4058,7 +4060,6 @@
(cond (cond
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos) [pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
(add1 cnt))] (add1 cnt))]
[(wrapper-object? o) (loop (wrapper-object-wrapped o))]
[else #f]))))) [else #f])))))
(define (implementation? v i) (define (implementation? v i)
@ -4099,7 +4100,7 @@
(raise-type-error 'object-info "object" o)) (raise-type-error 'object-info "object" o))
(trace-begin (trace-begin
(trace (inspect-event o)) (trace (inspect-event o))
(let loop ([c (object-ref (unwrap-object o))] (let loop ([c (object-ref (object-unwrapper o))]
[skipped? #f]) [skipped? #f])
(if (struct? ((class-insp-mk c))) (if (struct? ((class-insp-mk c)))
;; current inspector can inspect this object ;; current inspector can inspect this object
@ -4139,7 +4140,7 @@
(raise-type-error 'object->vector "object" in-o)) (raise-type-error 'object->vector "object" in-o))
(trace-begin (trace-begin
(trace (inspect-event in-o)) (trace (inspect-event in-o))
(let ([o (unwrap-object in-o)]) (let ([o (object-unwrapper in-o)])
(list->vector (list->vector
(cons (cons
(string->symbol (format "object:~a" (class-name (object-ref o)))) (string->symbol (format "object:~a" (class-name (object-ref o))))
@ -4166,8 +4167,8 @@
(raise-type-error 'object=? "object" o1)) (raise-type-error 'object=? "object" o1))
(unless (object? o2) (unless (object? o2)
(raise-type-error 'object=? "object" o2)) (raise-type-error 'object=? "object" o2))
(eq? (unwrap-object o1) (eq? (object-unwrapper o1)
(unwrap-object o2))) (object-unwrapper o2)))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; primitive classes ;; primitive classes
@ -4186,7 +4187,7 @@
new-methods) ; list of methods new-methods) ; list of methods
; The `make-struct:prim' function takes prop:object, a ; The `make-struct:prim' function takes prop:object, a
; class, a preparer, a dispatcher function, and a property assoc list, and produces: ; class, a preparer, a dispatcher function, an unwrapper, and a property assoc list, and produces:
; * a struct constructor (must have prop:object) ; * a struct constructor (must have prop:object)
; * a struct predicate ; * a struct predicate
; * a struct type for derived classes (mustn't have prop:object) ; * a struct type for derived classes (mustn't have prop:object)
@ -4195,6 +4196,8 @@
; ;
; The supplied dispatcher takes an object and a num and returns a method. ; The supplied dispatcher takes an object and a num and returns a method.
; ;
; The supplied unwrapper takes an object and returns the unwrapped version (or the original object).
;
; When a primitive class has a superclass, the struct:prim maker ; When a primitive class has a superclass, the struct:prim maker
; is responsible for ensuring that the returned struct items match ; is responsible for ensuring that the returned struct items match
; the supertype predicate. ; the supertype predicate.
@ -4261,182 +4264,128 @@
;; wrapper for contracts ;; wrapper for contracts
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define-struct wrapper-field (name ctc-stx)) (define (make-wrapper-class cls blame methods method-contracts fields field-contracts)
(define-struct wrapper-method (name mth-stx)) (let* ([name (class-name cls)]
[method-width (class-method-width cls)]
(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object) [method-ht (class-method-ht cls)]
(let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!) [meths (if (null? methods)
(make-struct-type 'raw-wrapper-object (class-methods cls)
#f (make-vector method-width))]
0 [field-pub-width (class-field-pub-width cls)]
1)]) [field-ht (class-field-ht cls)]
(values wrapper-object? [int-field-refs (make-vector field-pub-width)]
(lambda (v) (ref v 0)) [int-field-sets (make-vector field-pub-width)]
(lambda (o v) (set! o 0 v)) [ext-field-refs (make-vector field-pub-width)]
struct:wrapper-object))) [ext-field-sets (make-vector field-pub-width)]
[class-make (if name
;; unwrap-object : (union wrapper-object object) -> object (make-naming-constructor
(define (unwrap-object o) struct:class
(let loop ([o o]) (string->symbol (format "class:~a" name)))
(if (wrapper-object? o) make-class)]
(loop (wrapper-object-wrapped o)) [c (class-make name
o))) (class-pos cls)
(list->vector (vector->list (class-supers cls)))
;; make-wrapper-class : symbol (class-self-interface cls)
;; (listof symbol) void ;; No inspecting
;; method-spec [depends on the boolean what it is]
;; (listof symbol) method-width
;; boolean method-ht
;; -> class (class-method-ids cls)
;; the resulting class is the "proxy" class for the contracted version of an
;; object with contracts on the method-ids. meths
(class-super-methods cls)
;; Overall, objects of this class have one field for the original object, (class-int-methods cls)
;; one field per method in the contract and one field per field in the contract. (class-beta-methods cls)
;; Each of the methods (passed in) just accesses the initial (method) fields (class-meth-flags cls)
;; (which contain procedures) and calls them and returns their results.
;; Those fields do not show up from outside of this file, via the usual (class-inner-projs cls)
;; field accessors. In addition, the class has one field per field that (class-dynamic-idxs cls)
;; will contain the contracted versions of the input fields. (class-dynamic-projs cls)
;; The class accepts one initialization argument per method and
;; one init arg per field (in that order) using the make-object style (class-field-width cls)
;; initialization. field-pub-width
(define (make-wrapper-class class-name method-ids methods field-ids old-style?) field-ht
(let* ([supers (vector object% #f)] (class-field-ids cls)
[method-ht (make-hasheq)]
[method-count (length method-ids)] int-field-refs
[methods-vec (make-vector method-count #f)] int-field-sets
[int-methods-vec (make-vector method-count)] ext-field-refs
[dynamic-idxs (make-vector method-count 0)] ext-field-sets
[dynamic-projs (make-vector method-count (vector values))]
'struct:object 'object? 'make-object
[field-ht (make-hasheq)] 'field-ref 'field-set!
[field-count (length field-ids)]
[int-field-refs (make-vector field-count)] (class-init-args cls)
[int-field-sets (make-vector field-count)] (class-init-mode cls)
[ext-field-refs (make-vector field-count)] (class-init cls)
[ext-field-sets (make-vector field-count)]
(class-orig-cls cls)
[cls #f #f ; serializer is never set
(make-class class-name #f)]
1 [obj-name (if name
supers (string->symbol (format "wrapper-object:~a" name))
'bogus-self-interface 'object)])
void ; nothing can be inspected
(vector-set! (class-supers c) (class-pos c) c)
method-count
method-ht ;; --- Make the new object struct ---
(reverse method-ids) (let-values ([(struct:object object-make object? object-field-ref object-field-set!)
(make-struct-type obj-name
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
struct:wrapper-object struct:wrapper-object
0 0 ;; No init fields
(if old-style? 0 ;; No new fields in this wrapped object
(+ (length field-ids) (length method-ids))
(length field-ids))
undefined undefined
(list (cons prop:object cls)) ;; Map object property to class:
insp)]) (list (cons prop:object c)
(set-class-struct:object! cls struct:object) (cons prop:unwrap wrapper-object-wrapped)))])
(set-class-object?! cls object?) (set-class-struct:object! c struct:object)
(set-class-make-object! cls make-object) (set-class-object?! c object?)
(set-class-field-ref! cls field-ref) (set-class-make-object! c object-make)
(set-class-field-set!! cls field-set!) (set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!))
(set-class-orig-cls! cls cls)
;; Handle public method contracts
(let ([init (unless (null? methods)
(lambda (o continue-make-super c inited? named-args leftover-args) ;; First, fill in from old methods
;; leftover args will contain the original object and new field values (vector-copy! meths 0 (class-methods cls))
;; fill the original object in and then fill in the fields. ;; Now apply projections
(set-wrapper-object-wrapped! o (car leftover-args)) (for ([m (in-list methods)]
(let loop ([leftover-args (cdr leftover-args)] [c (in-list method-contracts)])
[i 0]) (when c
(unless (null? leftover-args) (let ([i (hash-ref method-ht m)]
(field-set! o i (car leftover-args)) [p ((contract-projection c) blame)])
(loop (cdr leftover-args) (vector-set! meths i (p (vector-ref meths i)))))))
(+ i 1))))
(continue-make-super o c inited? '() '() '()))]) ;; Fix up internal/external field accessors/mutators
(set-class-init! cls init)) ;; Normally we'd redirect these, but since make-field-map now unwraps
;; on all accesses, we just copy over the old vectors.
;; fill in the methods vector & methods-ht (vector-copy! int-field-refs 0 (class-int-field-refs cls))
(let loop ([i 0] (vector-copy! int-field-sets 0 (class-int-field-sets cls))
[methods methods] (vector-copy! ext-field-refs 0 (class-ext-field-refs cls))
[method-ids method-ids]) (vector-copy! ext-field-sets 0 (class-ext-field-sets cls))
(when (< i method-count)
(vector-set! methods-vec i (if old-style? ;; Handle external field contracts
((car methods) field-ref) (unless (null? fields)
(car methods))) (let ([bset (blame-swap blame)])
(vector-set! int-methods-vec i (for ([f (in-list fields)]
(vector (if old-style? [c (in-list field-contracts)])
((car methods) field-ref) (when c
(car methods)))) (let* ([i (hash-ref field-ht f)]
(hash-set! method-ht (car method-ids) i) [pre-p (contract-projection c)]
(loop (+ i 1) [old-ref (vector-ref ext-field-refs i)]
(cdr methods) [old-set (vector-ref ext-field-sets i)])
(cdr method-ids)))) (vector-set! ext-field-refs i
(λ (o) ((pre-p blame) (old-ref o))))
;; fill in the fields-ht (vector-set! ext-field-sets i
(let loop ([i 0] (λ (o v) (old-set o ((pre-p bset) v)))))))))
[field-ids field-ids])
(when (< i field-count) c))
(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)))
; extract-vtable : object -> (vectorof method-proc[this args ... -> res]) ;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?)
(define (extract-vtable o) (class-methods (object-ref o))) (define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
(check-object-contract obj blame methods fields)
; extract-method-ht : object -> hash-table[sym -> number] (let ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)])
(define (extract-method-ht o) (class-method-ht (object-ref o))) ((class-make-object new-cls) (object-unwrapper obj))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; misc utils ;; misc utils
@ -4625,10 +4574,8 @@
) )
;; Providing normal functionality: ;; Providing normal functionality:
(provide (protect-out make-wrapper-class (provide (protect-out make-wrapper-object
wrapper-object-wrapped check-object-contract
extract-vtable
extract-method-ht
get-field/proc) get-field/proc)
(rename-out [_class class]) class* class/derived (rename-out [_class class]) class* class/derived
@ -4657,5 +4604,5 @@
method-in-interface? interface->method-names class->interface class-info method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object) (struct-out exn:fail:object)
make-primitive-class make-primitive-class
class/c ->m ->*m #|object/c|#) class/c ->m ->*m object/c)

19
collects/scheme/private/classidmap.ss
View File

@ -59,7 +59,7 @@
[(f . args) [(f . args)
(quasisyntax/loc stx (#,replace-stx . args))]))))) (quasisyntax/loc stx (#,replace-stx . args))])))))
(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized (define (make-field-map trace-flag the-finder the-obj unwrapper the-binder the-binder-localized
field-accessor field-mutator field-pos/null) field-accessor field-mutator field-pos/null)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
@ -73,7 +73,8 @@
[trace (syntax/loc stx (set-event obj (quote id) id))] [trace (syntax/loc stx (set-event obj (quote id) id))]
[set (quasisyntax/loc stx [set (quasisyntax/loc stx
((unsyntax field-mutator) ((unsyntax field-mutator)
obj (unsyntax-splicing field-pos/null) id))]) ((unsyntax unwrapper) obj)
(unsyntax-splicing field-pos/null) id))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace set)) (syntax/loc stx (let* bindings trace set))
(syntax/loc stx (let* bindings set))))] (syntax/loc stx (let* bindings set))))]
@ -82,7 +83,8 @@
[trace (syntax/loc stx (get-event obj (quote id)))] [trace (syntax/loc stx (get-event obj (quote id)))]
[call (quasisyntax/loc stx [call (quasisyntax/loc stx
(((unsyntax field-accessor) (((unsyntax field-accessor)
obj-expr (unsyntax-splicing field-pos/null)) . args))]) ((unsyntax unwrapper) obj-expr)
(unsyntax-splicing field-pos/null)) . args))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace call)) (syntax/loc stx (let* bindings trace call))
(syntax/loc stx (let* bindings call))))] (syntax/loc stx (let* bindings call))))]
@ -91,7 +93,8 @@
[trace (syntax/loc stx (get-event obj (quote id)))] [trace (syntax/loc stx (get-event obj (quote id)))]
[get (quasisyntax/loc stx [get (quasisyntax/loc stx
((unsyntax field-accessor) ((unsyntax field-accessor)
obj-expr (unsyntax-splicing field-pos/null)))]) ((unsyntax unwrapper) obj-expr)
(unsyntax-splicing field-pos/null)))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings trace get))
(syntax/loc stx (let* bindings get))))])))))) (syntax/loc stx (let* bindings get))))]))))))
@ -267,7 +270,7 @@
stx))) stx)))
(define (make-with-method-map trace-flag set!-stx id-stx (define (make-with-method-map trace-flag set!-stx id-stx
method-stx method-obj-stx unwrap-stx) method-stx method-obj-stx)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -284,7 +287,6 @@
trace-flag trace-flag
stx stx
method-obj-stx method-obj-stx
unwrap-stx
method-stx method-stx
(syntax (quote id)) (syntax (quote id))
flat-args-stx flat-args-stx
@ -343,7 +345,7 @@
(and (pair? ctx) (and (pair? ctx)
(class-context? (car ctx)))) (class-context? (car ctx))))
(define (make-method-call traced? source-stx object-stx unwrap-stx (define (make-method-call traced? source-stx object-stx
method-proc-stx method-name-stx args-stx rest-arg?) method-proc-stx method-name-stx args-stx rest-arg?)
(define-syntax (qstx stx) (define-syntax (qstx stx)
@ -357,7 +359,6 @@
(if traced? (if traced?
(with-syntax ([(mth obj) (generate-temporaries (with-syntax ([(mth obj) (generate-temporaries
(list object-stx method-proc-stx))] (list object-stx method-proc-stx))]
[unwrap unwrap-stx]
[name method-name-stx] [name method-name-stx]
[(arg ...) (qstx args)] [(arg ...) (qstx args)]
[(var ...) (generate-temporaries (qstx args))]) [(var ...) (generate-temporaries (qstx args))])
@ -365,7 +366,7 @@
[obj object] [obj object]
[var arg] ...) [var arg] ...)
(initialize-call-event (initialize-call-event
(unwrap obj) name (app list var ...)) obj name (app list var ...))
(call-with-values (lambda () (app mth obj var ...)) (call-with-values (lambda () (app mth obj var ...))
finalize-call-event)))) finalize-call-event))))
(qstx (app method object . args))))) (qstx (app method object . args)))))

27
collects/scribblings/reference/class.scrbl
View File

@ -1501,7 +1501,7 @@ Method contracts must contain an additional initial argument which corresponds
to the implicit @scheme[this] parameter of the method. This allows for to the implicit @scheme[this] parameter of the method. This allows for
contracts which discuss the state of the object when the method is called contracts which discuss the state of the object when the method is called
(or, for dependent contracts, in other parts of the contract). Two alternative (or, for dependent contracts, in other parts of the contract). Two alternative
contract forms, @scheme[->m] and @scheme[->m*], are provided as a shorthand contract forms, @scheme[->m] and @scheme[->*m], are provided as a shorthand
for writing method contracts. for writing method contracts.
The external contracts are as follows: The external contracts are as follows:
@ -1563,6 +1563,31 @@ Similar to @scheme[->*], except that the mandatory domain of the resulting contr
more element than the stated domain, where the first (implicit) argument is contracted with more element than the stated domain, where the first (implicit) argument is contracted with
@scheme[any/c]. This contract is useful for writing simpler method contracts when no properties @scheme[any/c]. This contract is useful for writing simpler method contracts when no properties
of @scheme[this] need to be checked.} of @scheme[this] need to be checked.}
@defform/subs[
#:literals (field)
(object/c member-spec ...)
([member-spec
method-spec
(field field-spec ...)]
[method-spec
method-id
(method-id method-contract)]
[field-spec
field-id
(field-id contract-expr)])]{
Produces a contract for an object.
Unlike the older form @scheme[object-contract], but like
@scheme[class/c], arbitrary contract expressions are allowed.
Also, method contracts for @scheme[object/c] follow those for
@scheme[class/c]. An object wrapped with @scheme[object/c]
behaves as if its class had been wrapped with the equivalent
@scheme[class/c] contract.
}
@defform/subs[ @defform/subs[
#:literals (field -> ->* ->d) #:literals (field -> ->* ->d)

34
collects/tests/mzscheme/contract-mzlib-test.ss
View File

@ -1652,10 +1652,12 @@ of the contract library does not change over time.
(test/pos-blame (test/pos-blame
'object-contract/field2 'object-contract/field2
'(contract (object-contract (field x integer?)) '(get-field
(new (class object% (field [x #t]) (super-new))) x
'pos (contract (object-contract (field x integer?))
'neg)) (new (class object% (field [x #t]) (super-new)))
'pos
'neg)))
(test/spec-passed/result (test/spec-passed/result
'object-contract/field3 'object-contract/field3
@ -1669,17 +1671,21 @@ of the contract library does not change over time.
(test/pos-blame (test/pos-blame
'object-contract/field4 'object-contract/field4
'(contract (object-contract (field x boolean?) (field y boolean?)) '(get-field
(new (class object% (field [x #t] [y 'x]) (super-new))) y
'pos (contract (object-contract (field x boolean?) (field y boolean?))
'neg)) (new (class object% (field [x #t] [y 'x]) (super-new)))
'pos
'neg)))
(test/pos-blame (test/pos-blame
'object-contract/field5 'object-contract/field5
'(contract (object-contract (field x symbol?) (field y symbol?)) '(get-field
(new (class object% (field [x #t] [y 'x]) (super-new))) x
'pos (contract (object-contract (field x symbol?) (field y symbol?))
'neg)) (new (class object% (field [x #t] [y 'x]) (super-new)))
'pos
'neg)))
(test/spec-passed/result (test/spec-passed/result
'object-contract/field6 'object-contract/field6
@ -4521,10 +4527,10 @@ so that propagation occurs.
(ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1)
(ctest #t contract-first-order-passes? (ctest #f contract-first-order-passes?
(object-contract (m (-> integer? integer?))) (object-contract (m (-> integer? integer?)))
(new object%)) (new object%))
(ctest #t contract-first-order-passes? (ctest #f contract-first-order-passes?
(object-contract (m (-> integer? integer?))) (object-contract (m (-> integer? integer?)))
1) 1)

30
collects/tests/mzscheme/contract-test.ss
View File

@ -3043,10 +3043,12 @@
(test/pos-blame (test/pos-blame
'object-contract/field2 'object-contract/field2
'(contract (object-contract (field x integer?)) '(get-field
(new (class object% (field [x #t]) (super-new))) x
'pos (contract (object-contract (field x integer?))
'neg)) (new (class object% (field [x #t]) (super-new)))
'pos
'neg)))
(test/spec-passed/result (test/spec-passed/result
'object-contract/field3 'object-contract/field3
@ -3060,17 +3062,21 @@
(test/pos-blame (test/pos-blame
'object-contract/field4 'object-contract/field4
'(contract (object-contract (field x boolean?) (field y boolean?)) '(get-field
(new (class object% (field [x #t] [y 'x]) (super-new))) y
'pos (contract (object-contract (field x boolean?) (field y boolean?))
'neg)) (new (class object% (field [x #t] [y 'x]) (super-new)))
'pos
'neg)))
(test/pos-blame (test/pos-blame
'object-contract/field5 'object-contract/field5
'(contract (object-contract (field x symbol?) (field y symbol?)) '(get-field
(new (class object% (field [x #t] [y 'x]) (super-new))) x
'pos (contract (object-contract (field x symbol?) (field y symbol?))
'neg)) (new (class object% (field [x #t] [y 'x]) (super-new)))
'pos
'neg)))
(test/spec-passed/result (test/spec-passed/result
'object-contract/field6 'object-contract/field6

4
src/mred/wxs/wxs_bmap.cxx
View File

@ -659,7 +659,7 @@ int objscheme_istype_wxBitmap(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxBitmap_class);
if (objscheme_is_a(obj, os_wxBitmap_class)) if (objscheme_is_a(obj, os_wxBitmap_class))
return 1; return 1;
else { else {
@ -703,7 +703,7 @@ class wxBitmap *objscheme_unbundle_wxBitmap(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxBitmap_class);
(void)objscheme_istype_wxBitmap(obj, where, nullOK); (void)objscheme_istype_wxBitmap(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_butn.cxx
View File

@ -796,7 +796,7 @@ int objscheme_istype_wxButton(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxButton_class);
if (objscheme_is_a(obj, os_wxButton_class)) if (objscheme_is_a(obj, os_wxButton_class))
return 1; return 1;
else { else {
@ -840,7 +840,7 @@ class wxButton *objscheme_unbundle_wxButton(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxButton_class);
(void)objscheme_istype_wxButton(obj, where, nullOK); (void)objscheme_istype_wxButton(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_chce.cxx
View File

@ -899,7 +899,7 @@ int objscheme_istype_wxChoice(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxChoice_class);
if (objscheme_is_a(obj, os_wxChoice_class)) if (objscheme_is_a(obj, os_wxChoice_class))
return 1; return 1;
else { else {
@ -943,7 +943,7 @@ class wxChoice *objscheme_unbundle_wxChoice(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxChoice_class);
(void)objscheme_istype_wxChoice(obj, where, nullOK); (void)objscheme_istype_wxChoice(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_ckbx.cxx
View File

@ -821,7 +821,7 @@ int objscheme_istype_wxCheckBox(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCheckBox_class);
if (objscheme_is_a(obj, os_wxCheckBox_class)) if (objscheme_is_a(obj, os_wxCheckBox_class))
return 1; return 1;
else { else {
@ -865,7 +865,7 @@ class wxCheckBox *objscheme_unbundle_wxCheckBox(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCheckBox_class);
(void)objscheme_istype_wxCheckBox(obj, where, nullOK); (void)objscheme_istype_wxCheckBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_cnvs.cxx
View File

@ -1419,7 +1419,7 @@ int objscheme_istype_wxCanvas(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCanvas_class);
if (objscheme_is_a(obj, os_wxCanvas_class)) if (objscheme_is_a(obj, os_wxCanvas_class))
return 1; return 1;
else { else {
@ -1463,7 +1463,7 @@ class wxCanvas *objscheme_unbundle_wxCanvas(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCanvas_class);
(void)objscheme_istype_wxCanvas(obj, where, nullOK); (void)objscheme_istype_wxCanvas(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

24
src/mred/wxs/wxs_dc.cxx
View File

@ -2664,7 +2664,7 @@ int objscheme_istype_wxDC(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxDC_class);
if (objscheme_is_a(obj, os_wxDC_class)) if (objscheme_is_a(obj, os_wxDC_class))
return 1; return 1;
else { else {
@ -2708,7 +2708,7 @@ class wxDC *objscheme_unbundle_wxDC(Scheme_Object *obj, const char *where, int n
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxDC_class);
(void)objscheme_istype_wxDC(obj, where, nullOK); (void)objscheme_istype_wxDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3116,7 +3116,7 @@ int objscheme_istype_wxMemoryDC(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMemoryDC_class);
if (objscheme_is_a(obj, os_wxMemoryDC_class)) if (objscheme_is_a(obj, os_wxMemoryDC_class))
return 1; return 1;
else { else {
@ -3160,7 +3160,7 @@ class wxMemoryDC *objscheme_unbundle_wxMemoryDC(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMemoryDC_class);
(void)objscheme_istype_wxMemoryDC(obj, where, nullOK); (void)objscheme_istype_wxMemoryDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3281,7 +3281,7 @@ int objscheme_istype_wxPostScriptDC(Scheme_Object *obj, const char *stop, int nu
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPostScriptDC_class);
if (objscheme_is_a(obj, os_wxPostScriptDC_class)) if (objscheme_is_a(obj, os_wxPostScriptDC_class))
return 1; return 1;
else { else {
@ -3325,7 +3325,7 @@ class wxPostScriptDC *objscheme_unbundle_wxPostScriptDC(Scheme_Object *obj, cons
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPostScriptDC_class);
(void)objscheme_istype_wxPostScriptDC(obj, where, nullOK); (void)objscheme_istype_wxPostScriptDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3467,7 +3467,7 @@ int objscheme_istype_basePrinterDC(Scheme_Object *obj, const char *stop, int nul
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_basePrinterDC_class);
if (objscheme_is_a(obj, os_basePrinterDC_class)) if (objscheme_is_a(obj, os_basePrinterDC_class))
return 1; return 1;
else { else {
@ -3511,7 +3511,7 @@ class basePrinterDC *objscheme_unbundle_basePrinterDC(Scheme_Object *obj, const
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_basePrinterDC_class);
(void)objscheme_istype_basePrinterDC(obj, where, nullOK); (void)objscheme_istype_basePrinterDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3671,7 +3671,7 @@ int objscheme_istype_wxGL(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxGL_class);
if (objscheme_is_a(obj, os_wxGL_class)) if (objscheme_is_a(obj, os_wxGL_class))
return 1; return 1;
else { else {
@ -3715,7 +3715,7 @@ class wxGL *objscheme_unbundle_wxGL(Scheme_Object *obj, const char *where, int n
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxGL_class);
(void)objscheme_istype_wxGL(obj, where, nullOK); (void)objscheme_istype_wxGL(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -4029,7 +4029,7 @@ int objscheme_istype_wxGLConfig(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxGLConfig_class);
if (objscheme_is_a(obj, os_wxGLConfig_class)) if (objscheme_is_a(obj, os_wxGLConfig_class))
return 1; return 1;
else { else {
@ -4073,7 +4073,7 @@ class wxGLConfig *objscheme_unbundle_wxGLConfig(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxGLConfig_class);
(void)objscheme_istype_wxGLConfig(obj, where, nullOK); (void)objscheme_istype_wxGLConfig(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

24
src/mred/wxs/wxs_evnt.cxx
View File

@ -232,7 +232,7 @@ int objscheme_istype_wxEvent(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxEvent_class);
if (objscheme_is_a(obj, os_wxEvent_class)) if (objscheme_is_a(obj, os_wxEvent_class))
return 1; return 1;
else { else {
@ -275,7 +275,7 @@ class wxEvent *objscheme_unbundle_wxEvent(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxEvent_class);
(void)objscheme_istype_wxEvent(obj, where, nullOK); (void)objscheme_istype_wxEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -502,7 +502,7 @@ int objscheme_istype_wxCommandEvent(Scheme_Object *obj, const char *stop, int nu
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCommandEvent_class);
if (objscheme_is_a(obj, os_wxCommandEvent_class)) if (objscheme_is_a(obj, os_wxCommandEvent_class))
return 1; return 1;
else { else {
@ -545,7 +545,7 @@ class wxCommandEvent *objscheme_unbundle_wxCommandEvent(Scheme_Object *obj, cons
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCommandEvent_class);
(void)objscheme_istype_wxCommandEvent(obj, where, nullOK); (void)objscheme_istype_wxCommandEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -682,7 +682,7 @@ int objscheme_istype_wxPopupEvent(Scheme_Object *obj, const char *stop, int null
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPopupEvent_class);
if (objscheme_is_a(obj, os_wxPopupEvent_class)) if (objscheme_is_a(obj, os_wxPopupEvent_class))
return 1; return 1;
else { else {
@ -725,7 +725,7 @@ class wxPopupEvent *objscheme_unbundle_wxPopupEvent(Scheme_Object *obj, const ch
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPopupEvent_class);
(void)objscheme_istype_wxPopupEvent(obj, where, nullOK); (void)objscheme_istype_wxPopupEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1041,7 +1041,7 @@ int objscheme_istype_wxScrollEvent(Scheme_Object *obj, const char *stop, int nul
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxScrollEvent_class);
if (objscheme_is_a(obj, os_wxScrollEvent_class)) if (objscheme_is_a(obj, os_wxScrollEvent_class))
return 1; return 1;
else { else {
@ -1084,7 +1084,7 @@ class wxScrollEvent *objscheme_unbundle_wxScrollEvent(Scheme_Object *obj, const
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxScrollEvent_class);
(void)objscheme_istype_wxScrollEvent(obj, where, nullOK); (void)objscheme_istype_wxScrollEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -2119,7 +2119,7 @@ int objscheme_istype_wxKeyEvent(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxKeyEvent_class);
if (objscheme_is_a(obj, os_wxKeyEvent_class)) if (objscheme_is_a(obj, os_wxKeyEvent_class))
return 1; return 1;
else { else {
@ -2162,7 +2162,7 @@ class wxKeyEvent *objscheme_unbundle_wxKeyEvent(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxKeyEvent_class);
(void)objscheme_istype_wxKeyEvent(obj, where, nullOK); (void)objscheme_istype_wxKeyEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3019,7 +3019,7 @@ int objscheme_istype_wxMouseEvent(Scheme_Object *obj, const char *stop, int null
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMouseEvent_class);
if (objscheme_is_a(obj, os_wxMouseEvent_class)) if (objscheme_is_a(obj, os_wxMouseEvent_class))
return 1; return 1;
else { else {
@ -3062,7 +3062,7 @@ class wxMouseEvent *objscheme_unbundle_wxMouseEvent(Scheme_Object *obj, const ch
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMouseEvent_class);
(void)objscheme_istype_wxMouseEvent(obj, where, nullOK); (void)objscheme_istype_wxMouseEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_fram.cxx
View File

@ -1448,7 +1448,7 @@ int objscheme_istype_wxFrame(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFrame_class);
if (objscheme_is_a(obj, os_wxFrame_class)) if (objscheme_is_a(obj, os_wxFrame_class))
return 1; return 1;
else { else {
@ -1492,7 +1492,7 @@ class wxFrame *objscheme_unbundle_wxFrame(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFrame_class);
(void)objscheme_istype_wxFrame(obj, where, nullOK); (void)objscheme_istype_wxFrame(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_gage.cxx
View File

@ -756,7 +756,7 @@ int objscheme_istype_wxsGauge(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxsGauge_class);
if (objscheme_is_a(obj, os_wxsGauge_class)) if (objscheme_is_a(obj, os_wxsGauge_class))
return 1; return 1;
else { else {
@ -800,7 +800,7 @@ class wxsGauge *objscheme_unbundle_wxsGauge(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxsGauge_class);
(void)objscheme_istype_wxsGauge(obj, where, nullOK); (void)objscheme_istype_wxsGauge(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

52
src/mred/wxs/wxs_gdi.cxx
View File

@ -686,7 +686,7 @@ int objscheme_istype_wxFont(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFont_class);
if (objscheme_is_a(obj, os_wxFont_class)) if (objscheme_is_a(obj, os_wxFont_class))
return 1; return 1;
else { else {
@ -730,7 +730,7 @@ class wxFont *objscheme_unbundle_wxFont(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFont_class);
(void)objscheme_istype_wxFont(obj, where, nullOK); (void)objscheme_istype_wxFont(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -934,7 +934,7 @@ int objscheme_istype_wxFontList(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFontList_class);
if (objscheme_is_a(obj, os_wxFontList_class)) if (objscheme_is_a(obj, os_wxFontList_class))
return 1; return 1;
else { else {
@ -978,7 +978,7 @@ class wxFontList *objscheme_unbundle_wxFontList(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFontList_class);
(void)objscheme_istype_wxFontList(obj, where, nullOK); (void)objscheme_istype_wxFontList(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1320,7 +1320,7 @@ int objscheme_istype_wxColour(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxColour_class);
if (objscheme_is_a(obj, os_wxColour_class)) if (objscheme_is_a(obj, os_wxColour_class))
return 1; return 1;
else { else {
@ -1364,7 +1364,7 @@ class wxColour *objscheme_unbundle_wxColour(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxColour_class);
(void)objscheme_istype_wxColour(obj, where, nullOK); (void)objscheme_istype_wxColour(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1461,7 +1461,7 @@ int objscheme_istype_wxColourDatabase(Scheme_Object *obj, const char *stop, int
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxColourDatabase_class);
if (objscheme_is_a(obj, os_wxColourDatabase_class)) if (objscheme_is_a(obj, os_wxColourDatabase_class))
return 1; return 1;
else { else {
@ -1505,7 +1505,7 @@ class wxColourDatabase *objscheme_unbundle_wxColourDatabase(Scheme_Object *obj,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxColourDatabase_class);
(void)objscheme_istype_wxColourDatabase(obj, where, nullOK); (void)objscheme_istype_wxColourDatabase(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1710,7 +1710,7 @@ int objscheme_istype_wxPoint(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPoint_class);
if (objscheme_is_a(obj, os_wxPoint_class)) if (objscheme_is_a(obj, os_wxPoint_class))
return 1; return 1;
else { else {
@ -1753,7 +1753,7 @@ class wxPoint *objscheme_unbundle_wxPoint(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPoint_class);
(void)objscheme_istype_wxPoint(obj, where, nullOK); (void)objscheme_istype_wxPoint(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -2274,7 +2274,7 @@ int objscheme_istype_wxBrush(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxBrush_class);
if (objscheme_is_a(obj, os_wxBrush_class)) if (objscheme_is_a(obj, os_wxBrush_class))
return 1; return 1;
else { else {
@ -2318,7 +2318,7 @@ class wxBrush *objscheme_unbundle_wxBrush(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxBrush_class);
(void)objscheme_istype_wxBrush(obj, where, nullOK); (void)objscheme_istype_wxBrush(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -2471,7 +2471,7 @@ int objscheme_istype_wxBrushList(Scheme_Object *obj, const char *stop, int nullO
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxBrushList_class);
if (objscheme_is_a(obj, os_wxBrushList_class)) if (objscheme_is_a(obj, os_wxBrushList_class))
return 1; return 1;
else { else {
@ -2515,7 +2515,7 @@ class wxBrushList *objscheme_unbundle_wxBrushList(Scheme_Object *obj, const char
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxBrushList_class);
(void)objscheme_istype_wxBrushList(obj, where, nullOK); (void)objscheme_istype_wxBrushList(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3085,7 +3085,7 @@ int objscheme_istype_wxPen(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPen_class);
if (objscheme_is_a(obj, os_wxPen_class)) if (objscheme_is_a(obj, os_wxPen_class))
return 1; return 1;
else { else {
@ -3129,7 +3129,7 @@ class wxPen *objscheme_unbundle_wxPen(Scheme_Object *obj, const char *where, int
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPen_class);
(void)objscheme_istype_wxPen(obj, where, nullOK); (void)objscheme_istype_wxPen(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3287,7 +3287,7 @@ int objscheme_istype_wxPenList(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPenList_class);
if (objscheme_is_a(obj, os_wxPenList_class)) if (objscheme_is_a(obj, os_wxPenList_class))
return 1; return 1;
else { else {
@ -3331,7 +3331,7 @@ class wxPenList *objscheme_unbundle_wxPenList(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPenList_class);
(void)objscheme_istype_wxPenList(obj, where, nullOK); (void)objscheme_istype_wxPenList(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -3600,7 +3600,7 @@ int objscheme_istype_wxCursor(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCursor_class);
if (objscheme_is_a(obj, os_wxCursor_class)) if (objscheme_is_a(obj, os_wxCursor_class))
return 1; return 1;
else { else {
@ -3644,7 +3644,7 @@ class wxCursor *objscheme_unbundle_wxCursor(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxCursor_class);
(void)objscheme_istype_wxCursor(obj, where, nullOK); (void)objscheme_istype_wxCursor(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -4334,7 +4334,7 @@ int objscheme_istype_wxRegion(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxRegion_class);
if (objscheme_is_a(obj, os_wxRegion_class)) if (objscheme_is_a(obj, os_wxRegion_class))
return 1; return 1;
else { else {
@ -4378,7 +4378,7 @@ class wxRegion *objscheme_unbundle_wxRegion(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxRegion_class);
(void)objscheme_istype_wxRegion(obj, where, nullOK); (void)objscheme_istype_wxRegion(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -4953,7 +4953,7 @@ int objscheme_istype_wxPath(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPath_class);
if (objscheme_is_a(obj, os_wxPath_class)) if (objscheme_is_a(obj, os_wxPath_class))
return 1; return 1;
else { else {
@ -4997,7 +4997,7 @@ class wxPath *objscheme_unbundle_wxPath(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPath_class);
(void)objscheme_istype_wxPath(obj, where, nullOK); (void)objscheme_istype_wxPath(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -5313,7 +5313,7 @@ int objscheme_istype_wxFontNameDirectory(Scheme_Object *obj, const char *stop, i
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFontNameDirectory_class);
if (objscheme_is_a(obj, os_wxFontNameDirectory_class)) if (objscheme_is_a(obj, os_wxFontNameDirectory_class))
return 1; return 1;
else { else {
@ -5357,7 +5357,7 @@ class wxFontNameDirectory *objscheme_unbundle_wxFontNameDirectory(Scheme_Object
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxFontNameDirectory_class);
(void)objscheme_istype_wxFontNameDirectory(obj, where, nullOK); (void)objscheme_istype_wxFontNameDirectory(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

8
src/mred/wxs/wxs_item.cxx
View File

@ -164,7 +164,7 @@ int objscheme_istype_wxItem(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxItem_class);
if (objscheme_is_a(obj, os_wxItem_class)) if (objscheme_is_a(obj, os_wxItem_class))
return 1; return 1;
else { else {
@ -208,7 +208,7 @@ class wxItem *objscheme_unbundle_wxItem(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxItem_class);
(void)objscheme_istype_wxItem(obj, where, nullOK); (void)objscheme_istype_wxItem(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1027,7 +1027,7 @@ int objscheme_istype_wxMessage(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMessage_class);
if (objscheme_is_a(obj, os_wxMessage_class)) if (objscheme_is_a(obj, os_wxMessage_class))
return 1; return 1;
else { else {
@ -1071,7 +1071,7 @@ class wxMessage *objscheme_unbundle_wxMessage(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMessage_class);
(void)objscheme_istype_wxMessage(obj, where, nullOK); (void)objscheme_istype_wxMessage(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_lbox.cxx
View File

@ -1264,7 +1264,7 @@ int objscheme_istype_wxListBox(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxListBox_class);
if (objscheme_is_a(obj, os_wxListBox_class)) if (objscheme_is_a(obj, os_wxListBox_class))
return 1; return 1;
else { else {
@ -1308,7 +1308,7 @@ class wxListBox *objscheme_unbundle_wxListBox(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxListBox_class);
(void)objscheme_istype_wxListBox(obj, where, nullOK); (void)objscheme_istype_wxListBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

12
src/mred/wxs/wxs_menu.cxx
View File

@ -586,7 +586,7 @@ int objscheme_istype_wxMenu(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMenu_class);
if (objscheme_is_a(obj, os_wxMenu_class)) if (objscheme_is_a(obj, os_wxMenu_class))
return 1; return 1;
else { else {
@ -630,7 +630,7 @@ class wxMenu *objscheme_unbundle_wxMenu(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMenu_class);
(void)objscheme_istype_wxMenu(obj, where, nullOK); (void)objscheme_istype_wxMenu(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -899,7 +899,7 @@ int objscheme_istype_wxMenuBar(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMenuBar_class);
if (objscheme_is_a(obj, os_wxMenuBar_class)) if (objscheme_is_a(obj, os_wxMenuBar_class))
return 1; return 1;
else { else {
@ -943,7 +943,7 @@ class wxMenuBar *objscheme_unbundle_wxMenuBar(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxMenuBar_class);
(void)objscheme_istype_wxMenuBar(obj, where, nullOK); (void)objscheme_istype_wxMenuBar(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1119,7 +1119,7 @@ int objscheme_istype_wxsMenuItem(Scheme_Object *obj, const char *stop, int nullO
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxsMenuItem_class);
if (objscheme_is_a(obj, os_wxsMenuItem_class)) if (objscheme_is_a(obj, os_wxsMenuItem_class))
return 1; return 1;
else { else {
@ -1163,7 +1163,7 @@ class wxsMenuItem *objscheme_unbundle_wxsMenuItem(Scheme_Object *obj, const char
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxsMenuItem_class);
(void)objscheme_istype_wxsMenuItem(obj, where, nullOK); (void)objscheme_istype_wxsMenuItem(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

16
src/mred/wxs/wxs_misc.cxx
View File

@ -268,7 +268,7 @@ int objscheme_istype_wxTimer(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxTimer_class);
if (objscheme_is_a(obj, os_wxTimer_class)) if (objscheme_is_a(obj, os_wxTimer_class))
return 1; return 1;
else { else {
@ -312,7 +312,7 @@ class wxTimer *objscheme_unbundle_wxTimer(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxTimer_class);
(void)objscheme_istype_wxTimer(obj, where, nullOK); (void)objscheme_istype_wxTimer(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -608,7 +608,7 @@ int objscheme_istype_wxClipboard(Scheme_Object *obj, const char *stop, int nullO
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxClipboard_class);
if (objscheme_is_a(obj, os_wxClipboard_class)) if (objscheme_is_a(obj, os_wxClipboard_class))
return 1; return 1;
else { else {
@ -652,7 +652,7 @@ class wxClipboard *objscheme_unbundle_wxClipboard(Scheme_Object *obj, const char
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxClipboard_class);
(void)objscheme_istype_wxClipboard(obj, where, nullOK); (void)objscheme_istype_wxClipboard(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1022,7 +1022,7 @@ int objscheme_istype_wxClipboardClient(Scheme_Object *obj, const char *stop, int
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxClipboardClient_class);
if (objscheme_is_a(obj, os_wxClipboardClient_class)) if (objscheme_is_a(obj, os_wxClipboardClient_class))
return 1; return 1;
else { else {
@ -1066,7 +1066,7 @@ class wxClipboardClient *objscheme_unbundle_wxClipboardClient(Scheme_Object *obj
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxClipboardClient_class);
(void)objscheme_istype_wxClipboardClient(obj, where, nullOK); (void)objscheme_istype_wxClipboardClient(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1826,7 +1826,7 @@ int objscheme_istype_wxPrintSetupData(Scheme_Object *obj, const char *stop, int
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPrintSetupData_class);
if (objscheme_is_a(obj, os_wxPrintSetupData_class)) if (objscheme_is_a(obj, os_wxPrintSetupData_class))
return 1; return 1;
else { else {
@ -1870,7 +1870,7 @@ class wxPrintSetupData *objscheme_unbundle_wxPrintSetupData(Scheme_Object *obj,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPrintSetupData_class);
(void)objscheme_istype_wxPrintSetupData(obj, where, nullOK); (void)objscheme_istype_wxPrintSetupData(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_obj.cxx
View File

@ -120,7 +120,7 @@ int objscheme_istype_wxObject(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxObject_class);
if (objscheme_is_a(obj, os_wxObject_class)) if (objscheme_is_a(obj, os_wxObject_class))
return 1; return 1;
else { else {
@ -164,7 +164,7 @@ class wxObject *objscheme_unbundle_wxObject(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxObject_class);
(void)objscheme_istype_wxObject(obj, where, nullOK); (void)objscheme_istype_wxObject(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

8
src/mred/wxs/wxs_panl.cxx
View File

@ -958,7 +958,7 @@ int objscheme_istype_wxPanel(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPanel_class);
if (objscheme_is_a(obj, os_wxPanel_class)) if (objscheme_is_a(obj, os_wxPanel_class))
return 1; return 1;
else { else {
@ -1002,7 +1002,7 @@ class wxPanel *objscheme_unbundle_wxPanel(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxPanel_class);
(void)objscheme_istype_wxPanel(obj, where, nullOK); (void)objscheme_istype_wxPanel(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1825,7 +1825,7 @@ int objscheme_istype_wxDialogBox(Scheme_Object *obj, const char *stop, int nullO
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxDialogBox_class);
if (objscheme_is_a(obj, os_wxDialogBox_class)) if (objscheme_is_a(obj, os_wxDialogBox_class))
return 1; return 1;
else { else {
@ -1869,7 +1869,7 @@ class wxDialogBox *objscheme_unbundle_wxDialogBox(Scheme_Object *obj, const char
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxDialogBox_class);
(void)objscheme_istype_wxDialogBox(obj, where, nullOK); (void)objscheme_istype_wxDialogBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_rado.cxx
View File

@ -1100,7 +1100,7 @@ int objscheme_istype_wxRadioBox(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxRadioBox_class);
if (objscheme_is_a(obj, os_wxRadioBox_class)) if (objscheme_is_a(obj, os_wxRadioBox_class))
return 1; return 1;
else { else {
@ -1144,7 +1144,7 @@ class wxRadioBox *objscheme_unbundle_wxRadioBox(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxRadioBox_class);
(void)objscheme_istype_wxRadioBox(obj, where, nullOK); (void)objscheme_istype_wxRadioBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_slid.cxx
View File

@ -697,7 +697,7 @@ int objscheme_istype_wxSlider(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxSlider_class);
if (objscheme_is_a(obj, os_wxSlider_class)) if (objscheme_is_a(obj, os_wxSlider_class))
return 1; return 1;
else { else {
@ -741,7 +741,7 @@ class wxSlider *objscheme_unbundle_wxSlider(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxSlider_class);
(void)objscheme_istype_wxSlider(obj, where, nullOK); (void)objscheme_istype_wxSlider(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

8
src/mred/wxs/wxs_tabc.cxx
View File

@ -999,7 +999,7 @@ int objscheme_istype_wxTabChoice(Scheme_Object *obj, const char *stop, int nullO
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxTabChoice_class);
if (objscheme_is_a(obj, os_wxTabChoice_class)) if (objscheme_is_a(obj, os_wxTabChoice_class))
return 1; return 1;
else { else {
@ -1043,7 +1043,7 @@ class wxTabChoice *objscheme_unbundle_wxTabChoice(Scheme_Object *obj, const char
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxTabChoice_class);
(void)objscheme_istype_wxTabChoice(obj, where, nullOK); (void)objscheme_istype_wxTabChoice(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@ -1626,7 +1626,7 @@ int objscheme_istype_wxGroupBox(Scheme_Object *obj, const char *stop, int nullOK
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxGroupBox_class);
if (objscheme_is_a(obj, os_wxGroupBox_class)) if (objscheme_is_a(obj, os_wxGroupBox_class))
return 1; return 1;
else { else {
@ -1670,7 +1670,7 @@ class wxGroupBox *objscheme_unbundle_wxGroupBox(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxGroupBox_class);
(void)objscheme_istype_wxGroupBox(obj, where, nullOK); (void)objscheme_istype_wxGroupBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

4
src/mred/wxs/wxs_win.cxx
View File

@ -1418,7 +1418,7 @@ int objscheme_istype_wxWindow(Scheme_Object *obj, const char *stop, int nullOK)
{ {
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
if (nullOK && XC_SCHEME_NULLP(obj)) return 1; if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxWindow_class);
if (objscheme_is_a(obj, os_wxWindow_class)) if (objscheme_is_a(obj, os_wxWindow_class))
return 1; return 1;
else { else {
@ -1462,7 +1462,7 @@ class wxWindow *objscheme_unbundle_wxWindow(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK(); REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj); obj = objscheme_unwrap(obj, os_wxWindow_class);
(void)objscheme_istype_wxWindow(obj, where, nullOK); (void)objscheme_istype_wxWindow(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)obj; Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj)); WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));

51
src/mzscheme/utils/xcglue.c
View File

@ -18,10 +18,10 @@
arguments v... arguments v...
(primitive-class-prepare-struct-type! prim-class gen-property (primitive-class-prepare-struct-type! prim-class gen-property
gen-value preparer dispatcher extra-props) - prepares a class's gen-value preparer dispatcher unwrap-prop extra-props) - prepares a
struct-type for objects generated C-side; returns a constructor, class's struct-type for objects generated C-side; returns a
predicate, and a struct:type for derived classes. The constructor and constructor, predicate, and a struct:type for derived classes.
struct:type map the given dispatcher to the class. The constructor and struct:type map the given dispatcher to the class.
The preparer takes a symbol naming the method. It returns a The preparer takes a symbol naming the method. It returns a
value to be used in future calls to the dispatcher. value to be used in future calls to the dispatcher.
@ -30,6 +30,9 @@
method-specific value produced by the prepaper. It returns a method-specific value produced by the prepaper. It returns a
method procedure. method procedure.
The unwrap-prop takes a property that, if found on an object,
is paired with a function that unwraps the object.
The extra-props argument is a list of property--value pairs. The extra-props argument is a list of property--value pairs.
(primitive-class-find-method prim-class sym) - gets the method (primitive-class-find-method prim-class sym) - gets the method
@ -88,6 +91,7 @@ typedef struct Scheme_Class {
Scheme_Object **methods; Scheme_Object **methods;
Scheme_Object *base_struct_type; Scheme_Object *base_struct_type;
Scheme_Object *struct_type; Scheme_Object *struct_type;
Scheme_Object *unwrap_property;
} Scheme_Class; } Scheme_Class;
Scheme_Type objscheme_class_type; Scheme_Type objscheme_class_type;
@ -118,6 +122,7 @@ int gc_class_mark(void *_c)
gcMARK(c->methods); gcMARK(c->methods);
gcMARK(c->base_struct_type); gcMARK(c->base_struct_type);
gcMARK(c->struct_type); gcMARK(c->struct_type);
gcMARK(c->unwrap_property);
return gcBYTES_TO_WORDS(sizeof(Scheme_Class)); return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
} }
@ -133,6 +138,7 @@ int gc_class_fixup(void *_c)
gcFIXUP(c->methods); gcFIXUP(c->methods);
gcFIXUP(c->base_struct_type); gcFIXUP(c->base_struct_type);
gcFIXUP(c->struct_type); gcFIXUP(c->struct_type);
gcFIXUP(c->unwrap_property);
return gcBYTES_TO_WORDS(sizeof(Scheme_Class)); return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
} }
@ -170,8 +176,10 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv); scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv); scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv); scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type)
scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 5, argc, argv);
props = argv[5]; props = argv[6];
while (SCHEME_PAIRP(props)) { while (SCHEME_PAIRP(props)) {
name = SCHEME_CAR(props); name = SCHEME_CAR(props);
if (!SCHEME_PAIRP(name)) if (!SCHEME_PAIRP(name))
@ -181,8 +189,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
props = SCHEME_CDR(props); props = SCHEME_CDR(props);
} }
if (!SCHEME_NULLP(props)) if (!SCHEME_NULLP(props))
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 5, argc, argv); scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
props = argv[5]; props = argv[6];
objscheme_something_prepared = 1; objscheme_something_prepared = 1;
@ -233,9 +241,10 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
/* Type to derive/instantiate from Scheme: */ /* Type to derive/instantiate from Scheme: */
props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), c->unwrap_property = argv[5];
scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props);
props));
props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props);
stype = scheme_make_struct_type(name, stype = scheme_make_struct_type(name,
base_stype, base_stype,
@ -451,9 +460,25 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
return !!a; return !!a;
} }
Scheme_Object *objscheme_unwrap(Scheme_Object *o) Scheme_Object *objscheme_unwrap(Scheme_Object *obj, Scheme_Object *c)
{ {
return o; Scheme_Object *s[1], *unwrapper, *unwrap_prop;
Scheme_Class *cls = (Scheme_Class *)c;
if (!obj || !cls)
return NULL;
unwrap_prop = cls->unwrap_property;
if(!unwrap_prop)
return obj;
unwrapper = scheme_struct_type_property_ref(unwrap_prop, (Scheme_Object *)obj);
if (!unwrapper)
return obj;
s[0] = obj;
return _scheme_apply(unwrapper, 1, s);
} }
/***************************************************************************/ /***************************************************************************/
@ -542,7 +567,7 @@ void objscheme_init(Scheme_Env *env)
scheme_install_xc_global("primitive-class-prepare-struct-type!", scheme_install_xc_global("primitive-class-prepare-struct-type!",
scheme_make_prim_w_arity(class_prepare_struct_type, scheme_make_prim_w_arity(class_prepare_struct_type,
"primitive-class-prepare-struct-type!", "primitive-class-prepare-struct-type!",
6, 6), 7, 7),
env); env);
scheme_install_xc_global("primitive-class-find-method", scheme_install_xc_global("primitive-class-find-method",

2
src/mzscheme/utils/xcglue.h
View File

@ -78,7 +78,7 @@ Scheme_Object *objscheme_find_method(Scheme_Object *obj,
int objscheme_is_subclass(Scheme_Object *a, Scheme_Object *sup); int objscheme_is_subclass(Scheme_Object *a, Scheme_Object *sup);
int objscheme_is_a(Scheme_Object *o, Scheme_Object *c); int objscheme_is_a(Scheme_Object *o, Scheme_Object *c);
Scheme_Object *objscheme_unwrap(Scheme_Object *); Scheme_Object *objscheme_unwrap(Scheme_Object *, Scheme_Object *);
Scheme_Object *objscheme_unbox(Scheme_Object *, const char *where); Scheme_Object *objscheme_unbox(Scheme_Object *, const char *where);
Scheme_Object *objscheme_nullable_unbox(Scheme_Object *, const char *where); Scheme_Object *objscheme_nullable_unbox(Scheme_Object *, const char *where);

4
src/mzscheme/utils/xctocc
View File

@ -1237,7 +1237,7 @@ sub DoPrintClass
print "{\n"; print "{\n";
print " REMEMBER_VAR_STACK();\n"; print " REMEMBER_VAR_STACK();\n";
print " if (nullOK && XC_SCHEME_NULLP(obj)) return 1;\n"; print " if (nullOK && XC_SCHEME_NULLP(obj)) return 1;\n";
print " obj = objscheme_unwrap(obj);\n"; print " obj = objscheme_unwrap(obj, ${newclass}_class);\n";
print " if (objscheme_is_a(obj, ${newclass}_class))\n"; print " if (objscheme_is_a(obj, ${newclass}_class))\n";
print " return 1;\n"; print " return 1;\n";
print " else {\n"; print " else {\n";
@ -1288,7 +1288,7 @@ sub DoPrintClass
print "{\n"; print "{\n";
print " if (nullOK && XC_SCHEME_NULLP(obj)) return NULL;\n\n"; print " if (nullOK && XC_SCHEME_NULLP(obj)) return NULL;\n\n";
print " REMEMBER_VAR_STACK();\n\n"; print " REMEMBER_VAR_STACK();\n\n";
print " obj = objscheme_unwrap(obj);\n"; print " obj = objscheme_unwrap(obj, ${newclass}_class);\n";
print " (void)objscheme_istype_${oldclass}(obj, where, nullOK);\n"; print " (void)objscheme_istype_${oldclass}(obj, where, nullOK);\n";
print " Scheme_Class_Object *o = "; print " Scheme_Class_Object *o = ";