Module:    WIN32-Automation
Synopsis:  miscellaneous utilities
Author:    David N. Gray
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      See License.txt in this distribution for details.
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

/*
define function assert(ok? :: <boolean>) => ();
  unless (ok?)
    error("assert failure in OLE-Automation library");
  end unless;
  values()
end assert;
*/

// These type names aren't used in the original .h files, but references
// are generated by the translation patterns.
define constant <LPDESCKIND> = <C-int*>;
define constant <LPDISPID> = <C-both-long*>;
define constant <LPHREFTYPE> = <LPDWORD>;
define C-pointer-type <LPLPDISPATCH> => <LPDISPATCH>;
define constant <LPLPUNKNOWN> = <Interface*>;
define constant <LPMEMBERID> = <LPDISPID>;
define constant <LPTYPEKIND> = <C-int*>;
define constant <LPUSHORT> = <PUSHORT>;

define C-pointer-type <SAFEARRAY**> => <LPSAFEARRAY>;
define C-pointer-type <TYPEATTR**>  => <LPTYPEATTR>;
define C-pointer-type <FUNCDESC**>  => <LPFUNCDESC>;
define C-pointer-type <VARDESC**>   => <LPVARDESC>;
define C-pointer-type <TLIBATTR**>  => <LPTLIBATTR>;

// These enumeration types need to have their members defined, but
// the types themselves are not used.
// Suppress "defined but not referenced" warning.
ignore(<LIBFLAGS>, <DESCKIND>, <VARFLAGS>, <TYPEFLAGS>, <FUNCFLAGS>);

// Some foreign components have DISP IDs that don't fit in 30 bits.
define constant <disp-id> = <ffi-integer>;


// These need to be open generics because methods are also defined in the
// ole-controls library:
define open-accessor lcid-value;
define open-accessor dwHelpContext-value;

define open generic guid-value (struct) => (guid);
define open generic guid-value-setter (guid, struct) => (guid);

// For specifying the element type of arrays.
// It would be nicer to be able to just use `limited(<array>, of: ...)', but
// there are no introspection functions provided for that.
define class <array-type-description> ( <object> )
  constant slot element-type :: <ole-type>, required-init-keyword: of:;
end class;

define function ole-array-type(element-type :: <ole-type>)
 =>  ( description :: <array-type-description> );
  make(<array-type-description>, of: element-type)
end;

define constant <ole-type> =
  type-union(<type>, <array-type-description>, <LPTYPEDESC>);


define method empty? ( parms :: <LPDISPPARAMS> ) => empty :: <boolean>;
  zero?(parms.cArgs-value)
end;

define method size ( parms :: <LPDISPPARAMS> ) => num :: <integer>;
  parms.cArgs-value
end;

define method element (parms :: <LPDISPPARAMS>, index :: <integer>,
                       #key default = unsupplied())
 => element :: <object>;
  let numargs = parms.cArgs-value;
  if (index >= 0 & index < numargs)
    pointer-value(parms.rgvarg-value, index: numargs - index - 1)
  elseif (supplied?(default))
    default
  else
    element-range-error(parms, index);
  end if;
end;

//  ====  representation of data members of interface  ====

// Accessors for slots of anonymous union
define method oInst-value ( vd :: <LPVARDESC> ) => value :: <integer>;
  vd.u-value.oInst-value
end;

define method lpvarValue-value ( vd :: <LPVARDESC> ) => value :: <LPVARIANT>;
  vd.u-value.lpvarValue-value
end;

define method oInst-value-setter ( value :: <integer>, vd :: <LPVARDESC> )
 => value :: <integer>;
  vd.u-value.oInst-value := value
end;

define method lpvarValue-value-setter ( value :: <LPVARIANT>,
				       vd :: <LPVARDESC> )
 => value :: <LPVARIANT>;
  vd.u-value.lpvarValue-value := value
end;

