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

ffi/com: add support for type descriptions on values

Browse Source
This commit is contained in:
Matthew Flatt 2012-04-16 08:28:18 -06:00
parent c321608856
commit 38e628be80
4 changed files with 170 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/ffi/com.rkt
View File

@ -23,4 +23,8 @@
com-make-event-executor com-event-executor?
com-object-get-iunknown com-iunknown?
com-object-get-idispatch com-idispatch?)
com-object-get-idispatch com-idispatch?
type-description?
type-describe type-described?
type-described-value type-described-description)

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

@ -59,7 +59,11 @@
com-unregister-event-callback
com-object-get-iunknown com-iunknown?
com-object-get-idispatch com-idispatch?)
com-object-get-idispatch com-idispatch?
type-description?
type-describe type-described?
type-described-value type-described-description)
;; FIXME:
;; call args via var-desc (instead of func-dec)
@ -1106,8 +1110,24 @@
`(array ? ,(vt-to-scheme-type (- vt VT_ARRAY)))
(string->symbol (format "COM-0x~x" vt)))]))
(define (arg-to-type arg)
(define (arg-to-type arg [in-array 0])
(cond
[(type-described? arg)
(type-described-description arg)]
[(vector? arg) `(array ,(vector-length arg)
,(if (zero? (vector-length arg))
'int
(for/fold ([t (arg-to-type (vector-ref arg 0) (add1 in-array))]) ([v (in-vector arg)])
(define t2 (arg-to-type v (add1 in-array)))
(let loop ([t t] [t2 t2])
(cond
[(equal? t t2) t]
[(and (pair? t) (pair? t2)
(eq? (car t) 'array) (eq? (car t2) 'array)
(equal? (cadr t) (cadr t2)))
`(array ,(cadr t) ,(loop (caddr t) (caddr t2)))]
[else 'any])))))]
[(in-array . > . 1) 'any]
[(boolean? arg) 'boolean]
[(signed-int? arg 32) 'int]
[(unsigned-int? arg 32) 'unsigned-int]
@ -1117,19 +1137,6 @@
[(real? arg) 'double]
[(com-object? arg) 'com-object]
[(IUnknown? arg) 'iunknown]
[(vector? arg) `(array ,(vector-length arg)
,(if (zero? (vector-length arg))
'int
(for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)])
(define t2 (arg-to-type v))
(let loop ([t t] [t2 t2])
(cond
[(equal? t t2) t]
[(and (pair? t) (pair? t2)
(eq? (car t) 'array) (eq? (car t2) 'array)
(equal? (cadr t) (cadr t2)))
`(array ,(cadr t) ,(loop (caddr t) (caddr t2)))]
[else 'any])))))]
[else (error 'com "cannot infer marshal format for value: ~e" arg)]))
(define (elem-desc-ref func-desc i)
@ -1342,6 +1349,8 @@
(define (ok-argument? arg type)
(cond
[(type-described? arg)
(ok-argument? (type-described-value arg) type)]
[(symbol? type)
(case type
[(void) (void? arg)]
@ -1377,6 +1386,55 @@
(ok-argument? v (caddr type))))]
[else #f]))
(define (type-description? type)
(cond
[(symbol? type)
(hash-ref
#hasheq((void . #t)
(char . #t)
(unsigned-short . #t)
(unsigned-int . #t)
(unsigned-long-long . #t)
(signed-char . #t)
(short-int . #t)
(int . #t)
(long-long . #t)
(float . #t)
(double . #t)
(string . #t)
(currency . #t)
(date . #t)
(boolean . #t)
(scode . #t)
(iunknown . #t)
(com-object . #t)
(any . #t)
(com-enumeration . #t))
type
#f)]
[(and (list? type)
(pair? type))
(cond
[(eq? 'opt (car type))
(and (= (length type) 2)
(type-description? (cadr type)))]
[(eq? 'box (car type))
(and (= (length type) 2)
(type-description? (cadr type)))]
[(eq? 'array (car type))
(and (= (length type) 3)
(exact-positive-integer? (cadr type))
(type-description? (caddr type)))]
[else #f])]
[else #f]))
(struct type-described (value description))
(define (type-describe v desc)
(unless (type-description? desc)
(raise-type-error 'type-describe "type description" desc))
(type-described v desc))
(define (check-argument who method arg type)
(unless (ok-argument? arg type)
(raise-type-error (string->symbol method) (format "~s" type) arg)))
@ -1395,6 +1453,8 @@
(define (scheme-to-variant! var a elem-desc scheme-type)
(cond
[(type-described? a)
(scheme-to-variant! var (type-described-value a) elem-desc scheme-type)]
[(eq? a com-omit)
(if (and elem-desc
(elem-desc-has-default? elem-desc))
@ -1538,7 +1598,7 @@
[else #f]))
(define (to-vt type)
;; only used for inferred types
;; used for inferred or described types
(case type
[(void) VT_VOID]
[(char) VT_UI1]

74
collects/scribblings/foreign/com-auto.scrbl
View File

@ -161,6 +161,7 @@ the object itself.}
Returns @racket[#t] if @racket[t1] and @racket[t2] represent the same
type information, @racket[#f] otherwise.}
@; ----------------------------------------
@section{COM Methods}
@ -174,7 +175,8 @@ type information, @racket[#f] otherwise.}
@defproc[(com-method-type [obj/type (or/c com-object? com-type?)]
[method-name string?])
(list/c '-> list? any/c)]{
(list/c '-> (listof type-description?)
type-description?)]{
Returns a list indicating the type of the specified method in
@racket[obj/type]. The list after the @racket['->] represents the
@ -188,7 +190,14 @@ type information, @racket[#f] otherwise.}
Invokes @racket[method-name] on @racket[obj] with @racket[v]s as the
arguments. The special value @racket[com-omit] may be used for
optional arguments, which useful when values are supplied for
arguments after the omitted argument(s).}
arguments after the omitted argument(s).
The types of arguments are determined via @racket[com-method-type],
if possible, and @racket[type-describe] wrappers in the @racket[v]s
are simply replaced with the values that they wrap. If the types are
not available from @racket[com-method-type], then types are inferred
for each @racket[v] with attention to descriptions in any
@racket[type-describe] wrappers in @racket[v].}
@defthing[com-omit any/c]{
@ -210,7 +219,7 @@ argument.}
@defproc[(com-get-property-type [obj/type (or/c com-object? com-type?)]
[property-name string?])
(list/c '-> '() any/c)]{
(list/c '-> '() type-description?)]{
Returns a type for @racket[property-name] like a result of
@racket[com-method], where the result type corresponds to the
@ -235,7 +244,7 @@ argument.}
@defproc[(com-set-property-type [obj/type (or/c com-object? com-type?)]
[property-name string?])
(list/c '-> (list/c any/c) 'void)]{
(list/c '-> (list/c type-description?) 'void)]{
Returns a type for @racket[property-name] like a result of
@racket[com-method], where the sole argument type corresponds to the
@ -250,7 +259,15 @@ argument.}
Sets the value of the final property in @racket[obj] to @racket[v]
by following the @racket[property]s, where the value of each
intermediate property must be a COM object.}
intermediate property must be a COM object.
The type of the property is determined via
@racket[com-property-type], if possible, and
@racket[type-describe] wrappers in @racket[v] are then replaced
with the values that they wrap. If the type is not available from
@racket[com-property-type], then a type is inferred for @racket[v]
with attention to the descriptions in any @racket[type-describe]
wrappers in @racket[v].}
@; ----------------------------------------
@ -265,7 +282,7 @@ argument.}
@defproc[(com-event-type [obj/type (or/c com-object? com-type?)]
[event-name string?])
(list/c '-> list? 'void)]{
(list/c '-> (listof type-description?) 'void)]{
Returns a list indicating the type of the specified events in
@racket[obj/type]. The list after the @racket['->] represents the
@ -420,7 +437,7 @@ used to represent various atomic types:
@item{@racket['com-enumeration] --- a 32-bit signed integer}
@item{@racket['any] --- any of the above}
@item{@racket['any] --- any of the above, or an array when not nested in an array type}
@item{@racket['void] --- no value}
@ -434,6 +451,49 @@ A type wrapped in a list with @racket['opt], such as @racket['(opt
(box int))], is an optional argument. The argument can be omitted or
replaced with @racket[com-omit].
A type wrapped in a list with @racket['array] and a positive exact
integer, such as @racket['(array 7 int)], represents a vector of
values to be used as a COM array. Array types can be nested to
specify a multidimensional array as represented by nested vectors.
When type information is not available, functions like @racket[com-invoke]
infer type descriptions from arguments. Inference chooses @racket['boolean]
for booleans; the first of @racket['int], @racket['unsigned-int],
@racket['long-long], @racket['unsigned-long-long] that fits for an exact integer;
@racket['double] for inexact real numbers; @racket['string] for a string;
@racket['com-object] and @racket['iunknown] for corresponding COM object references;
and an @racket['array] type for a vector, where the element type is inferred
from vector values, resorting to @racket['any] if any two elements have different
inferred types or if the array is multidimensional.
@defproc[(type-description? [v any/c]) boolean?]{
Return @racket[#t] if @racket[v] is a COM argument or result type
description as above, @racket[#f] otherwise.}
@deftogether[(
@defproc[(type-described? [v any/c]) boolean?]
@defproc[(type-describe [v any/c] [desc type-description?])
type-described?]
@defproc[(type-described-value [td type-described?]) any/c]
@defproc[(type-described-description [td type-described?])
type-description?]
)]{
The @racket[type-described?] predicate recognizes wrappers produced
with @racket[type-describe], and @racket[type-described-value] and
@racket[type-described-description] extract the value and description
parts of a @racket[type-describe] value.
A @racket[type-describe] wrapper combines a base value with a type
description. The description is used instead of an automatically
inferred COM argument type when no type is available for from COM
automation a method for @racket[com-invoke] or a property for
@racket[com-set-property!]. A wrapper can be placed on an immediate
value, or it can be on a value within a box or vector.}
@; ----------------------------------------
@section{Class Display Names}

22
collects/tests/racket/com.rkt
View File

@ -52,6 +52,8 @@
(test '(-> () void) (com-method-type mzcom "Reset"))
(test '(-> (string) string) (com-method-type mzcom "Eval"))
(test "3" (com-invoke mzcom "Eval" "(+ 1 2)"))
(test "4" (com-invoke mzcom "Eval" (type-describe "(+ 2 2)" 'string)))
(test "5" (com-invoke mzcom "Eval" (type-describe "(+ 3 2)" 'int))) ; description is not used
(test '() (com-get-properties mzcom))
(test '() (com-get-properties (com-object-type mzcom)))
@ -132,6 +134,26 @@
(test (void) (com-release ie))
(test #t (type-description? 'int))
(test #t (type-description? 'long-long))
(test #t (type-description? 'string))
(test #t (type-description? 'any))
(test #t (type-description? 'char))
(test #f (type-description? 'long))
(test #f (type-description? '(int)))
(test #t (type-description? '(opt int)))
(test #f (type-description? '(opt)))
(test #f (type-description? '(opt int int)))
(test #t (type-description? '(box int)))
(test #f (type-description? '(box)))
(test #f (type-description? '(box int int)))
(test #f (type-description? '(-> (int) int)))
(test #t (type-description? '(array 8 int)))
(test #f (type-description? '(array 8)))
(test #f (type-description? '(array)))
(test #f (type-description? '(array int)))
(test #t (type-description? '(array 8 (array 4 any))))
(void))
(printf "~a passed\n" count)