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

ffi/com: fixes for IUnknown and enumeration values

Browse Source
This commit is contained in:
Matthew Flatt 2012-06-25 13:13:52 -06:00
parent d346415903
commit 90b5aad56b
1 changed files with 32 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/ffi/unsafe/com.rkt
View File

@ -1009,17 +1009,26 @@
(define (get-var-type-from-elem-desc elem-desc) (define (get-var-type-from-elem-desc elem-desc)
(define param-desc (union-ref (ELEMDESC-u elem-desc) 1)) (define param-desc (union-ref (ELEMDESC-u elem-desc) 1))
(define flags (PARAMDESC-wParamFlags param-desc)) (define flags (PARAMDESC-wParamFlags param-desc))
(define (fixup-vt vt)
(cond
[(= vt (bitwise-ior VT_USERDEFINED VT_BYREF))
VT_UNKNOWN]
[(= vt VT_USERDEFINED)
VT_INT]
[else vt]))
(cond (cond
[(and (bit-and? flags PARAMFLAG_FOPT) [(and (bit-and? flags PARAMFLAG_FOPT)
(bit-and? flags PARAMFLAG_FHASDEFAULT)) (bit-and? flags PARAMFLAG_FHASDEFAULT))
(VARIANT-vt (PARAMDESCEX-varDefaultValue (PARAMDESC-pparamdescex param-desc)))] (fixup-vt
(VARIANT-vt (PARAMDESCEX-varDefaultValue (PARAMDESC-pparamdescex param-desc))))]
[(= (TYPEDESC-vt (ELEMDESC-tdesc elem-desc)) VT_PTR) [(= (TYPEDESC-vt (ELEMDESC-tdesc elem-desc)) VT_PTR)
(bitwise-ior VT_BYREF (fixup-vt
(TYPEDESC-vt (cast (union-ref (TYPEDESC-u (ELEMDESC-tdesc elem-desc)) 0) (bitwise-ior VT_BYREF
_pointer (TYPEDESC-vt (cast (union-ref (TYPEDESC-u (ELEMDESC-tdesc elem-desc)) 0)
_TYPEDESC-pointer)))] _pointer
_TYPEDESC-pointer))))]
[else [else
(TYPEDESC-vt (ELEMDESC-tdesc elem-desc))])) (fixup-vt (TYPEDESC-vt (ELEMDESC-tdesc elem-desc)))]))
(define (elem-desc-has-default? elem-desc) (define (elem-desc-has-default? elem-desc)
(define param-desc (union-ref (ELEMDESC-u elem-desc) 1)) (define param-desc (union-ref (ELEMDESC-u elem-desc) 1))
@ -1040,7 +1049,8 @@
(define (elem-desc-to-scheme-type elem-desc ignore-by-ref? is-opt? internal?) (define (elem-desc-to-scheme-type elem-desc ignore-by-ref? is-opt? internal?)
(define vt (let ([vt (get-var-type-from-elem-desc elem-desc)]) (define vt (let ([vt (get-var-type-from-elem-desc elem-desc)])
(if ignore-by-ref? (if (and ignore-by-ref?
(not (bit-and? vt VT_USERDEFINED)))
(- vt (bitwise-and vt VT_BYREF)) (- vt (bitwise-and vt VT_BYREF))
vt))) vt)))
(cond (cond
@ -1063,10 +1073,13 @@
_SAFEARRAYBOUND)) _SAFEARRAYBOUND))
,base))] ,base))]
[else [else
(define base (vt-to-scheme-type (- vt (bitwise-and vt VT_BYREF)))) (define base (vt-to-scheme-type (if (bit-and? vt VT_USERDEFINED)
vt
(- vt (bitwise-and vt VT_BYREF)))))
(define new-base (define new-base
(if (bit-and? vt VT_BYREF) (if (and (not (bit-and? vt VT_USERDEFINED))
`(box ,base) (bit-and? vt VT_BYREF))
`(box ,base)
base)) base))
(if is-opt? (if is-opt?
`(opt ,new-base) `(opt ,new-base)
@ -1106,9 +1119,13 @@
'com-enumeration] 'com-enumeration]
[VT_VOID 'void] [VT_VOID 'void]
[else [else
(if (= VT_ARRAY (bitwise-and vt VT_ARRAY)) (cond
`(array ? ,(vt-to-scheme-type (- vt VT_ARRAY))) [(= VT_ARRAY (bitwise-and vt VT_ARRAY))
(string->symbol (format "COM-0x~x" vt)))])) `(array ? ,(vt-to-scheme-type (- vt VT_ARRAY)))]
[(= vt (bitwise-ior VT_USERDEFINED VT_BYREF))
'iunknown]
[else
(string->symbol (format "COM-0x~x" vt))])]))
(define (arg-to-type arg [in-array 0]) (define (arg-to-type arg [in-array 0])
(cond (cond
@ -1568,7 +1585,7 @@
v)) v))
(lambda (p) (lambda (p)
(((allocator Release) (lambda () p))) (((allocator Release) (lambda () p)))
(define obj (make-com-object p)) (define obj (make-com-object p #f))
(register-with-custodian obj) (register-with-custodian obj)
obj))) obj)))
@ -1636,6 +1653,7 @@
[(iunknown) VT_UNKNOWN] [(iunknown) VT_UNKNOWN]
[(com-object) VT_DISPATCH] [(com-object) VT_DISPATCH]
[(any) VT_VARIANT] [(any) VT_VARIANT]
[(com-enumeration) VT_INT]
[else [else
(case (and (pair? type) (case (and (pair? type)
(car type)) (car type))