ffi/com: add support for type descriptions on values

collects/ffi/com.rkt

@@ -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)

collects/ffi/unsafe/com.rkt

@@ -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]

collects/scribblings/foreign/com-auto.scrbl

@@ -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}

collects/tests/racket/com.rkt

@@ -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)