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

ffi/unsafe/com: repair for optional `any' arguments

Browse Source 
Merge to 5.3
This commit is contained in:
Matthew Flatt 2012-04-11 16:50:11 -06:00
parent c5e5a0349a
commit bcb22a3adb
1 changed files with 11 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1400,17 +1400,23 @@
_VARIANT)) _VARIANT))
(begin (begin
(set-VARIANT-vt! var VT_ERROR) (set-VARIANT-vt! var VT_ERROR)
(variant-set! var _long DISP_E_PARAMNOTFOUND)))] (variant-set! var _ulong DISP_E_PARAMNOTFOUND)))]
[(and elem-desc (not (eq? 'any scheme-type))) [(and elem-desc (not (any-type? scheme-type)))
(set-VARIANT-vt! var (get-var-type-from-elem-desc elem-desc)) (set-VARIANT-vt! var (get-var-type-from-elem-desc elem-desc))
(variant-set! var (to-ctype scheme-type) a)] (variant-set! var (to-ctype scheme-type) a)]
[else [else
(define use-scheme-type (if (eq? scheme-type 'any) (define use-scheme-type (if (any-type? scheme-type)
(arg-to-type a) (arg-to-type a)
scheme-type)) scheme-type))
(set-VARIANT-vt! var (to-vt use-scheme-type)) (set-VARIANT-vt! var (to-vt use-scheme-type))
(variant-set! var (to-ctype use-scheme-type) a)])) (variant-set! var (to-ctype use-scheme-type) a)]))
(define (any-type? t)
(or (eq? t 'any)
(and (pair? t)
(eq? (car t) 'opt)
(any-type? (cadr t)))))
(define _float* (define _float*
(make-ctype _float (make-ctype _float
(lambda (v) (exact->inexact v)) (lambda (v) (exact->inexact v))
@ -1510,7 +1516,7 @@
[(com-enumeration) _int] [(com-enumeration) _int]
[else (error 'to-ctype "Internal error: unknown type ~s" type)])] [else (error 'to-ctype "Internal error: unknown type ~s" type)])]
[(eq? 'opt (car type)) [(eq? 'opt (car type))
(to-ctype type)] (to-ctype (cadr type))]
[(eq? 'box (car type)) [(eq? 'box (car type))
(_box/permanent (to-ctype (cadr type)))] (_box/permanent (to-ctype (cadr type)))]
[(eq? 'array (car type)) [(eq? 'array (car type))
@ -1550,6 +1556,7 @@
(case (and (pair? type) (case (and (pair? type)
(car type)) (car type))
[(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))] [(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))]
[(opt) (to-vt (cadr type))]
[else [else
(error 'to-vt "Internal error: unsupported type ~s" type)])])) (error 'to-vt "Internal error: unsupported type ~s" type)])]))