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
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(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!
c prop:object class preparer dispatcher more-props))
c prop:object class preparer dispatcher prop:unwrap more-props))
kernel:initialize-primitive-object
'print-name super (list intf ...) 'args
'(old ...)

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

@ -246,51 +246,6 @@
(raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
[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 (se->il se)
(cond
@ -317,61 +272,29 @@
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
[(method-name ...) (map mtd-name 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-name ...) (map fld-name flds)]
[(field-ctc-var ...) (generate-temporaries flds)]
[(field-var ...) (generate-temporaries flds)]
[(field/app-var ...) (generate-temporaries flds)])
[(field-ctc-var ...) (generate-temporaries flds)])
(syntax
(let ([method-ctc-var method-ctc-stx]
...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...)
(let ([method-var (contract-projection method-ctc-var)]
...
[field-var (contract-projection field-ctc-var)]
...)
(let ([cls (make-wrapper-class 'wrapper-class
'(method-name ...)
(list methods ...)
'(field-name ...)
#t)])
(make-contract
#:name
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
#: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)) ...
)))))))))))))]))))
(make-contract
#:name
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
#:projection
(lambda (blame)
(lambda (val)
(make-wrapper-object val blame
(list 'method-name ...) (list method-ctc-var ...)
(list 'field-name ...) (list field-ctc-var ...))))
#:first-order
(lambda (val)
(check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))]))))
(define (check-object val blame)

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

@ -13,27 +13,6 @@
implementation?/c
object-contract)
;; example of how one contract is constructed
#;
(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
[cf (-> integer? integer?)]
[m-proj ((contract-projection cm)
(make-blame #'here #f "whatever" 'pos 'neg #t))]
[f-proj ((contract-projection cf)
(make-blame #'here #f "whatever" 'pos 'neg #t))]
[cls (make-wrapper-class 'wrapper-class
'(m)
(list
(m-proj (λ (this x) (send (wrapper-object-wrapped this) m x))))
'(f)
#f)]
[o (new (class object%
(field [f (λ (x) x)])
(define/public (m x) x)
(super-new)))]
[wo (make-object cls o (f-proj (get-field/proc 'f o)))])
((get-field/proc 'f wo) #f))
(define-for-syntax (parse-object-contract stx args)
(let loop ([args (syntax->list args)]
[mtds '()]
@ -52,55 +31,17 @@
[_
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
(define (o-c-first-order ctc val blame meth-projs)
(let/ec return
(define (failed str . args)
(if blame
(apply raise-blame-error blame val str args)
(return #f)))
(unless (object? val)
(failed "expected an object, got ~e" val))
(let ([meth-names (object-contract-methods ctc)])
(for-each (λ (m proj)
(let-values ([(method unwrapper)
(find-method/who 'object-contract val m #:error? #f)])
(unless method
(failed "expected an object with method ~s" m))
;; verify the first-order properties by apply the projection and
;; throwing the result away. Without this, the contract wrappers
;; just check the first-order properties of the wrappers, which is
;; the wrong thing.
(proj method)))
meth-names
meth-projs))
(let ([ctc-field-names (object-contract-fields ctc)]
[fields (field-names val)])
(for-each (λ (f)
(unless (memq f fields)
(failed "expected an object with field ~s" f)))
ctc-field-names))
#t))
(define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs)
(define-struct object-contract (methods method-ctcs fields field-ctcs)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let ([meth-names (object-contract-methods ctc)]
[meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))]
[ctc-field-names (object-contract-fields ctc)]
[field-param-projs (map contract-projection (object-contract-field-ctcs ctc))])
(λ (blame)
(let* ([meth-projs (map (λ (x) (x blame)) meth-param-projs)]
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
[field-projs (map (λ (x) (x blame)) field-param-projs)])
(λ (val)
(o-c-first-order ctc val blame meth-projs)
(apply make-object cls val
(map (λ (field proj) (proj (get-field/proc field val)))
ctc-field-names field-projs)))))))
(λ (blame)
(λ (val)
(make-wrapper-object val blame
(object-contract-methods ctc) (object-contract-method-ctcs ctc)
(object-contract-fields ctc) (object-contract-field-ctcs ctc)))))
#:name
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc)
@ -112,7 +53,7 @@
#:first-order
(λ (ctc)
(λ (val)
(o-c-first-order ctc val #f (map (λ (x) values) (object-contract-method-ctcs ctc)))))))
(check-object-contract val #f (object-contract-methods ctc) (object-contract-fields ctc))))))
(define-syntax (object-contract stx)
(syntax-case stx ()
@ -124,14 +65,12 @@
(syntax->list #'(method-id ...)))])
#'(build-object-contract '(method-id ...)
(syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
(list (λ (this . x) (send (wrapper-object-wrapped this) method-id . x)) ...)
'(field-id ...)
(list field-ctc ...))))]))
(define (build-object-contract methods method-ctcs wrappers fields field-ctcs)
(define (build-object-contract methods method-ctcs fields field-ctcs)
(make-object-contract methods
(map (λ (x) (coerce-contract 'object-contract x)) method-ctcs)
wrappers
fields
(map (λ (x) (coerce-contract 'object-contract x)) field-ctcs)))

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

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

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

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

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();
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))
return 1;
else {
@ -703,7 +703,7 @@ class wxBitmap *objscheme_unbundle_wxBitmap(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxBitmap_class);
(void)objscheme_istype_wxBitmap(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -840,7 +840,7 @@ class wxButton *objscheme_unbundle_wxButton(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxButton_class);
(void)objscheme_istype_wxButton(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -943,7 +943,7 @@ class wxChoice *objscheme_unbundle_wxChoice(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxChoice_class);
(void)objscheme_istype_wxChoice(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -865,7 +865,7 @@ class wxCheckBox *objscheme_unbundle_wxCheckBox(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxCheckBox_class);
(void)objscheme_istype_wxCheckBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1463,7 +1463,7 @@ class wxCanvas *objscheme_unbundle_wxCanvas(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxCanvas_class);
(void)objscheme_istype_wxCanvas(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -2708,7 +2708,7 @@ class wxDC *objscheme_unbundle_wxDC(Scheme_Object *obj, const char *where, int n
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxDC_class);
(void)objscheme_istype_wxDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3160,7 +3160,7 @@ class wxMemoryDC *objscheme_unbundle_wxMemoryDC(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxMemoryDC_class);
(void)objscheme_istype_wxMemoryDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3325,7 +3325,7 @@ class wxPostScriptDC *objscheme_unbundle_wxPostScriptDC(Scheme_Object *obj, cons
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPostScriptDC_class);
(void)objscheme_istype_wxPostScriptDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3511,7 +3511,7 @@ class basePrinterDC *objscheme_unbundle_basePrinterDC(Scheme_Object *obj, const
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_basePrinterDC_class);
(void)objscheme_istype_basePrinterDC(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3715,7 +3715,7 @@ class wxGL *objscheme_unbundle_wxGL(Scheme_Object *obj, const char *where, int n
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxGL_class);
(void)objscheme_istype_wxGL(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -4073,7 +4073,7 @@ class wxGLConfig *objscheme_unbundle_wxGLConfig(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxGLConfig_class);
(void)objscheme_istype_wxGLConfig(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -275,7 +275,7 @@ class wxEvent *objscheme_unbundle_wxEvent(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxEvent_class);
(void)objscheme_istype_wxEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -545,7 +545,7 @@ class wxCommandEvent *objscheme_unbundle_wxCommandEvent(Scheme_Object *obj, cons
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxCommandEvent_class);
(void)objscheme_istype_wxCommandEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -725,7 +725,7 @@ class wxPopupEvent *objscheme_unbundle_wxPopupEvent(Scheme_Object *obj, const ch
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPopupEvent_class);
(void)objscheme_istype_wxPopupEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1084,7 +1084,7 @@ class wxScrollEvent *objscheme_unbundle_wxScrollEvent(Scheme_Object *obj, const
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxScrollEvent_class);
(void)objscheme_istype_wxScrollEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -2162,7 +2162,7 @@ class wxKeyEvent *objscheme_unbundle_wxKeyEvent(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxKeyEvent_class);
(void)objscheme_istype_wxKeyEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3062,7 +3062,7 @@ class wxMouseEvent *objscheme_unbundle_wxMouseEvent(Scheme_Object *obj, const ch
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxMouseEvent_class);
(void)objscheme_istype_wxMouseEvent(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1492,7 +1492,7 @@ class wxFrame *objscheme_unbundle_wxFrame(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxFrame_class);
(void)objscheme_istype_wxFrame(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -800,7 +800,7 @@ class wxsGauge *objscheme_unbundle_wxsGauge(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxsGauge_class);
(void)objscheme_istype_wxsGauge(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -730,7 +730,7 @@ class wxFont *objscheme_unbundle_wxFont(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxFont_class);
(void)objscheme_istype_wxFont(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -978,7 +978,7 @@ class wxFontList *objscheme_unbundle_wxFontList(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxFontList_class);
(void)objscheme_istype_wxFontList(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1364,7 +1364,7 @@ class wxColour *objscheme_unbundle_wxColour(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxColour_class);
(void)objscheme_istype_wxColour(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1505,7 +1505,7 @@ class wxColourDatabase *objscheme_unbundle_wxColourDatabase(Scheme_Object *obj,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxColourDatabase_class);
(void)objscheme_istype_wxColourDatabase(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1753,7 +1753,7 @@ class wxPoint *objscheme_unbundle_wxPoint(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPoint_class);
(void)objscheme_istype_wxPoint(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -2318,7 +2318,7 @@ class wxBrush *objscheme_unbundle_wxBrush(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxBrush_class);
(void)objscheme_istype_wxBrush(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -2515,7 +2515,7 @@ class wxBrushList *objscheme_unbundle_wxBrushList(Scheme_Object *obj, const char
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxBrushList_class);
(void)objscheme_istype_wxBrushList(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3129,7 +3129,7 @@ class wxPen *objscheme_unbundle_wxPen(Scheme_Object *obj, const char *where, int
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPen_class);
(void)objscheme_istype_wxPen(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3331,7 +3331,7 @@ class wxPenList *objscheme_unbundle_wxPenList(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPenList_class);
(void)objscheme_istype_wxPenList(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -3644,7 +3644,7 @@ class wxCursor *objscheme_unbundle_wxCursor(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxCursor_class);
(void)objscheme_istype_wxCursor(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -4378,7 +4378,7 @@ class wxRegion *objscheme_unbundle_wxRegion(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxRegion_class);
(void)objscheme_istype_wxRegion(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -4997,7 +4997,7 @@ class wxPath *objscheme_unbundle_wxPath(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPath_class);
(void)objscheme_istype_wxPath(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -5357,7 +5357,7 @@ class wxFontNameDirectory *objscheme_unbundle_wxFontNameDirectory(Scheme_Object
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxFontNameDirectory_class);
(void)objscheme_istype_wxFontNameDirectory(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -208,7 +208,7 @@ class wxItem *objscheme_unbundle_wxItem(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxItem_class);
(void)objscheme_istype_wxItem(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1071,7 +1071,7 @@ class wxMessage *objscheme_unbundle_wxMessage(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxMessage_class);
(void)objscheme_istype_wxMessage(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1308,7 +1308,7 @@ class wxListBox *objscheme_unbundle_wxListBox(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxListBox_class);
(void)objscheme_istype_wxListBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -630,7 +630,7 @@ class wxMenu *objscheme_unbundle_wxMenu(Scheme_Object *obj, const char *where, i
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxMenu_class);
(void)objscheme_istype_wxMenu(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -943,7 +943,7 @@ class wxMenuBar *objscheme_unbundle_wxMenuBar(Scheme_Object *obj, const char *wh
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxMenuBar_class);
(void)objscheme_istype_wxMenuBar(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1163,7 +1163,7 @@ class wxsMenuItem *objscheme_unbundle_wxsMenuItem(Scheme_Object *obj, const char
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxsMenuItem_class);
(void)objscheme_istype_wxsMenuItem(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -312,7 +312,7 @@ class wxTimer *objscheme_unbundle_wxTimer(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxTimer_class);
(void)objscheme_istype_wxTimer(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -652,7 +652,7 @@ class wxClipboard *objscheme_unbundle_wxClipboard(Scheme_Object *obj, const char
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxClipboard_class);
(void)objscheme_istype_wxClipboard(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1066,7 +1066,7 @@ class wxClipboardClient *objscheme_unbundle_wxClipboardClient(Scheme_Object *obj
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxClipboardClient_class);
(void)objscheme_istype_wxClipboardClient(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1870,7 +1870,7 @@ class wxPrintSetupData *objscheme_unbundle_wxPrintSetupData(Scheme_Object *obj,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPrintSetupData_class);
(void)objscheme_istype_wxPrintSetupData(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -164,7 +164,7 @@ class wxObject *objscheme_unbundle_wxObject(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxObject_class);
(void)objscheme_istype_wxObject(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1002,7 +1002,7 @@ class wxPanel *objscheme_unbundle_wxPanel(Scheme_Object *obj, const char *where,
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxPanel_class);
(void)objscheme_istype_wxPanel(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1869,7 +1869,7 @@ class wxDialogBox *objscheme_unbundle_wxDialogBox(Scheme_Object *obj, const char
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxDialogBox_class);
(void)objscheme_istype_wxDialogBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1144,7 +1144,7 @@ class wxRadioBox *objscheme_unbundle_wxRadioBox(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxRadioBox_class);
(void)objscheme_istype_wxRadioBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -741,7 +741,7 @@ class wxSlider *objscheme_unbundle_wxSlider(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxSlider_class);
(void)objscheme_istype_wxSlider(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1043,7 +1043,7 @@ class wxTabChoice *objscheme_unbundle_wxTabChoice(Scheme_Object *obj, const char
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxTabChoice_class);
(void)objscheme_istype_wxTabChoice(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1670,7 +1670,7 @@ class wxGroupBox *objscheme_unbundle_wxGroupBox(Scheme_Object *obj, const char *
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxGroupBox_class);
(void)objscheme_istype_wxGroupBox(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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();
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))
return 1;
else {
@ -1462,7 +1462,7 @@ class wxWindow *objscheme_unbundle_wxWindow(Scheme_Object *obj, const char *wher
REMEMBER_VAR_STACK();
obj = objscheme_unwrap(obj);
obj = objscheme_unwrap(obj, os_wxWindow_class);
(void)objscheme_istype_wxWindow(obj, where, nullOK);
Scheme_Class_Object *o = (Scheme_Class_Object *)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...
(primitive-class-prepare-struct-type! prim-class gen-property
gen-value preparer dispatcher extra-props) - prepares a class's
struct-type for objects generated C-side; returns a constructor,
predicate, and a struct:type for derived classes. The constructor and
struct:type map the given dispatcher to the class.
gen-value preparer dispatcher unwrap-prop extra-props) - prepares a
class's struct-type for objects generated C-side; returns a
constructor, predicate, and a struct:type for derived classes.
The constructor and struct:type map the given dispatcher to the class.
The preparer takes a symbol naming the method. It returns a
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 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.
(primitive-class-find-method prim-class sym) - gets the method
@ -88,6 +91,7 @@ typedef struct Scheme_Class {
Scheme_Object **methods;
Scheme_Object *base_struct_type;
Scheme_Object *struct_type;
Scheme_Object *unwrap_property;
} Scheme_Class;
Scheme_Type objscheme_class_type;
@ -118,6 +122,7 @@ int gc_class_mark(void *_c)
gcMARK(c->methods);
gcMARK(c->base_struct_type);
gcMARK(c->struct_type);
gcMARK(c->unwrap_property);
return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
}
@ -133,6 +138,7 @@ int gc_class_fixup(void *_c)
gcFIXUP(c->methods);
gcFIXUP(c->base_struct_type);
gcFIXUP(c->struct_type);
gcFIXUP(c->unwrap_property);
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_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);
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)) {
name = SCHEME_CAR(props);
if (!SCHEME_PAIRP(name))
@ -181,8 +189,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
props = SCHEME_CDR(props);
}
if (!SCHEME_NULLP(props))
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 5, argc, argv);
props = argv[5];
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
props = argv[6];
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: */
props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]),
scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]),
props));
c->unwrap_property = argv[5];
props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props);
props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props);
stype = scheme_make_struct_type(name,
base_stype,
@ -451,9 +460,25 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
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_make_prim_w_arity(class_prepare_struct_type,
"primitive-class-prepare-struct-type!",
6, 6),
7, 7),
env);
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_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_nullable_unbox(Scheme_Object *, const char *where);

4
src/mzscheme/utils/xctocc
View File

@ -1237,7 +1237,7 @@ sub DoPrintClass
print "{\n";
print " REMEMBER_VAR_STACK();\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 " return 1;\n";
print " else {\n";
@ -1288,7 +1288,7 @@ sub DoPrintClass
print "{\n";
print " if (nullOK && XC_SCHEME_NULLP(obj)) return NULL;\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 " Scheme_Class_Object *o = ";