Commit c26d6b6d authored by Sylvain Le Gall's avatar Sylvain Le Gall

Imported Upstream version 1.05

parent 60412c3a
CamlIDL 1.05:
-------------
* Update to the new representation of objects introduced in OCaml 3.08.
* Fixed compiler failure with bigarrays of "const" elements.
* Fixed bug in conversion from C's signed char to Caml's char type.
* Function declarations support the [mlname] attribute (to set the
Caml name of the function) and the [blocking] attribute (for long-running
C functions).
* Fixed cpp preprocessing problem on MacOS X 10.2 and later.
* Fixed bug in conversion from a struct of floats to a Caml record of floats.
* Fixed incorrect initialization of DLL generated for a COM component.
CamlIDL 1.04:
-------------
......
......@@ -16,23 +16,25 @@ objects as COM components that can then be used from C++ or C.
COPYRIGHT:
All files marked "Copyright INRIA" in this distribution are copyright
1999, 2000, 2001 Institut National de Recherche en Informatique et en
Automatique (INRIA) and distributed under the conditions stated in
file LICENSE. They can be freely redistributed for non-commercial
purposes, provided the copyright notice remains attached.
1999, 2000, 2001, 2002, 2003, 2004 Institut National de Recherche en
Informatique et en Automatique (INRIA) and distributed under the
conditions stated in file LICENSE.
REQUIREMENTS:
Camlidl requires Objective Caml 3.02 or later. Under MS Windows,
Microsoft's Visual C++ 6.0 is required, as well as the Cygnus CYGWIN32
tools (http://sourceware.cygnus.com/cygwin/).
Camlidl requires Objective Caml 3.08 or later. This version will not work
with earlier releases of Objective Caml.
Under MS Windows, you must use the MSVC port of Objective Caml.
Microsoft's Visual C++ 6.0 is required, as well as
the Cygnus CYGWIN32 tools (http://sourceware.cygnus.com/cygwin/).
INSTALLATION:
- Under Unix, copy config/Makefile.unix to config/Makefile.
Under Windows, copy config/Makefile.windows to config/Makefile.
Under Windows, copy config/Makefile.win32 to config/Makefile.
- Edit config/Makefile to set configuration options, following the
comments in that file. You must set the OCAMLLIB and BINDIR variables
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: cvttyp.ml,v 1.26 2002/01/16 16:15:30 xleroy Exp $ *)
(* $Id: cvttyp.ml,v 1.27 2004/07/08 11:24:43 xleroy Exp $ *)
open Utils
open Printf
......@@ -136,7 +136,7 @@ let out_mltype_stamp oc kind modl name stamp =
(* Convert an IDL type to an ML bigarray element type *)
let ml_bigarray_kind ty =
let rec ml_bigarray_kind ty =
match ty with
Type_int((Char | UChar | Byte), _) -> "Bigarray.int8_unsigned_elt"
| Type_int((SChar | Small), _) -> "Bigarray.int8_signed_elt"
......@@ -148,6 +148,7 @@ let ml_bigarray_kind ty =
| Type_int((Hyper | UHyper), _) -> "Bigarray.int64_elt"
| Type_float -> "Bigarray.float32_elt"
| Type_double -> "Bigarray.float64_elt"
| Type_const ty -> ml_bigarray_kind ty
| _ -> assert false
(* Convert an IDL type to an ML type *)
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: cvtval.ml,v 1.24 2002/01/16 09:42:01 xleroy Exp $ *)
(* $Id: cvtval.ml,v 1.25 2004/07/08 10:10:18 xleroy Exp $ *)
open Printf
open Utils
......@@ -158,7 +158,9 @@ let rec ml_to_c oc onstack pref ty v c =
let rec c_to_ml oc pref ty c v =
match ty with
Type_int(kind, repr) ->
| Type_int((Char | SChar), repr) ->
iprintf oc "%s = Val_int((unsigned char)(%s));\n" v c
| Type_int(kind, repr) ->
let conv =
match repr with
Iunboxed ->
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: funct.ml,v 1.29 2002/05/01 15:25:39 xleroy Exp $ *)
(* $Id: funct.ml,v 1.30 2004/07/08 09:50:23 xleroy Exp $ *)
(* Generation of stub code for functions *)
......@@ -30,8 +30,10 @@ type function_decl =
fun_mod: string;
fun_res: idltype;
fun_params: (string * in_out * idltype) list;
fun_mlname: string option;
fun_call: string option;
fun_dealloc: string option }
fun_dealloc: string option;
fun_blocking: bool }
(* Remove dependent parameters (parameters that are size_is, length_is,
or switch_is of another parameter).
......@@ -94,9 +96,12 @@ let ml_view fundecl =
(* Generate the ML declaration for a function *)
let mlname fundecl =
match fundecl.fun_mlname with Some n -> n | None -> fundecl.fun_name
let ml_declaration oc fundecl =
let (ins, outs) = ml_view fundecl in
fprintf oc "external %s : " (String.uncapitalize fundecl.fun_name);
fprintf oc "external %s : " (String.uncapitalize (mlname fundecl));
out_ml_types oc "->" ins;
fprintf oc " -> ";
out_ml_types oc "*" outs;
......@@ -279,7 +284,8 @@ let emit_function oc fundecl ins outs locals emit_call =
(* Emit wrapper function for C function *)
let emit_standard_call oc fundecl =
match fundecl.fun_call with
if fundecl.fun_blocking then iprintf oc "enter_blocking_section();\n";
begin match fundecl.fun_call with
Some s ->
iprintf oc "/* begin user-supplied calling sequence */\n";
output_string oc s;
......@@ -297,6 +303,8 @@ let emit_standard_call oc fundecl =
List.iter (fun (name, _, _) -> fprintf oc ", %s" name) rem
end;
fprintf oc ");\n"
end;
if fundecl.fun_blocking then iprintf oc "leave_blocking_section();\n"
let emit_wrapper oc fundecl =
current_function := fundecl.fun_name;
......@@ -312,7 +320,8 @@ let emit_method_call intfname methname oc fundecl =
(* Reset the error mechanism *)
iprintf oc "SetErrorInfo(0L, NULL);\n";
(* Emit the call *)
match fundecl.fun_call with
if fundecl.fun_blocking then iprintf oc "enter_blocking_section();\n";
begin match fundecl.fun_call with
Some s ->
iprintf oc "/* begin user-supplied calling sequence */\n";
output_string oc s;
......@@ -324,6 +333,8 @@ let emit_method_call intfname methname oc fundecl =
fprintf oc "this->lpVtbl->%s(this" methname;
List.iter (fun (name, _, _) -> fprintf oc ", %s" name) fundecl.fun_params;
fprintf oc ");\n"
end;
if fundecl.fun_blocking then iprintf oc "leave_blocking_section();\n"
let emit_method_wrapper oc intf_name meth =
current_function := sprintf "%s %s" intf_name meth.fun_name;
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: funct.mli,v 1.10 2000/08/19 11:04:56 xleroy Exp $ *)
(* $Id: funct.mli,v 1.11 2004/07/08 09:50:23 xleroy Exp $ *)
(* Generation of stub code for functions *)
......@@ -24,8 +24,10 @@ type function_decl =
fun_mod: string;
fun_res: idltype;
fun_params: (string * in_out * idltype) list;
fun_mlname: string option;
fun_call: string option;
fun_dealloc: string option }
fun_dealloc: string option;
fun_blocking: bool }
val ml_view :
function_decl -> (string * idltype) list * (string * idltype) list
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: intf.ml,v 1.22 2002/01/16 09:42:02 xleroy Exp $ *)
(* $Id: intf.ml,v 1.23 2004/07/08 09:51:21 xleroy Exp $ *)
(* Handling of COM-style interfaces *)
......@@ -180,8 +180,10 @@ let ml_class_definition oc intf =
fun_mod = intf.intf_mod;
fun_res = meth.fun_res;
fun_params = ("this", In, self_type) :: meth.fun_params;
fun_mlname = None;
fun_call = None;
fun_dealloc = None } in
fun_dealloc = None;
fun_blocking = false } in
Funct.ml_declaration oc prim)
intf.intf_methods;
fprintf oc "\n";
......@@ -238,7 +240,6 @@ let emit_callback_wrapper oc intf meth =
for i = 0 to num_ins do fprintf oc "0, " done;
fprintf oc "};\n";
fprintf oc " value _vres;\n";
fprintf oc " static value _vlabel = 0;\n";
if meth.fun_res <> Type_void then
fprintf oc " %a;\n" out_c_decl ("_res", meth.fun_res);
(* Convert inputs from C to Caml *)
......@@ -251,15 +252,15 @@ let emit_callback_wrapper oc intf meth =
iter_index
(fun pos (name, ty) -> c_to_ml pc pref ty name (sprintf "_varg[%d]" pos))
1 ins;
(* Recover the label.
_vlabel is not registered as a root because it's an integer. *)
iprintf pc "if (_vlabel == 0) _vlabel = camlidl_lookup_method(\"%s\");\n"
(String.uncapitalize meth.fun_name);
decrease_indent();
iprintf pc "End_roots();\n";
(* The method label *)
let label =
(Obj.magic
(Oo.public_method_label (String.uncapitalize meth.fun_name)) : int) in
(* Do the callback *)
iprintf pc "_vres = callbackN_exn(Lookup(_varg[0], _vlabel), %d, _varg);\n"
(num_ins + 1);
iprintf pc "_vres = callbackN_exn(caml_get_public_method(_varg[0], Val_int(%d)), %d, _varg);\n"
label (num_ins + 1);
(* Check if exception occurred *)
begin match meth.fun_res with
Type_named(_, "HRESULT") ->
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: lexer_midl.mll,v 1.12 2002/01/16 16:15:32 xleroy Exp $ *)
(* $Id: lexer_midl.mll,v 1.13 2004/05/12 12:40:40 xleroy Exp $ *)
(* Lexer for IDL interface files *)
......@@ -101,6 +101,9 @@ rule token = parse
| "#" ("line")? [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * eol
(* # linenum "filename" flags \n *)
{ token lexbuf }
| "#" blank* "pragma" [^ '\n' '\r'] * eol
(* #pragma introduced by some C preprocessors *)
{ token lexbuf }
| identstart identchar *
{ let s = Lexing.lexeme lexbuf in
try
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: parse_aux.ml,v 1.19 2002/05/01 15:24:19 xleroy Exp $ *)
(* $Id: parse_aux.ml,v 1.20 2004/07/08 09:50:40 xleroy Exp $ *)
(* Auxiliary functions for parsing *)
......@@ -221,7 +221,11 @@ let make_param attrs tybase decl =
merge_attributes None ty attrs
let make_fun_declaration attrs ty_res name params quotes =
let call = ref None and dealloc = ref None in
let truename = ref name
and mlname = ref None
and call = ref None
and dealloc = ref None
and blocking = ref false in
let parse_quote (label, text) =
match String.lowercase label with
"call" -> call := Some text
......@@ -230,9 +234,12 @@ let make_fun_declaration attrs ty_res name params quotes =
eprintf "%t: Warning: quote type `%s' unknown, ignoring the quote.\n"
print_location label in
List.iter parse_quote quotes;
let truename = ref name in
let rec merge_attributes ty = function
[] -> ty
| ("mlname", [Expr_ident s]) :: rem ->
mlname := Some s; merge_attributes ty rem
| ("blocking", _) :: rem ->
blocking := true; merge_attributes ty rem
| (("callback" | "local"), _) :: rem ->
merge_attributes ty rem
| ("propget", _) :: rem ->
......@@ -243,12 +250,15 @@ let make_fun_declaration attrs ty_res name params quotes =
truename := "putref_" ^ name; merge_attributes ty rem
| attr :: rem ->
merge_attributes (apply_type_attribute ty attr) rem in
let ty_res' = merge_attributes ty_res attrs in
{ fun_name = !truename;
fun_mod = "";
fun_res = merge_attributes ty_res attrs;
fun_res = ty_res';
fun_params = params;
fun_mlname = !mlname;
fun_call = !call;
fun_dealloc = !dealloc }
fun_dealloc = !dealloc;
fun_blocking = !blocking }
let make_field attrs tybase decl =
let rec merge_attributes name ty = function
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: struct.ml,v 1.14 2002/01/16 09:42:03 xleroy Exp $ *)
(* $Id: struct.ml,v 1.15 2004/07/08 09:55:09 xleroy Exp $ *)
(* Handling of structures *)
......@@ -101,7 +101,8 @@ let struct_c_to_ml c_to_ml oc pref sd c v =
let rec convert_fields pos = function
[] -> ()
| f :: rem ->
iprintf oc "Store_double_val(%s, %s.%s);\n" v c f.field_name;
iprintf oc "Store_double_field(%s, %d, %s.%s);\n"
v pos c f.field_name;
convert_fields (pos + 1) rem in
convert_fields 0 sd.sd_fields
end else begin
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: utils.mli,v 1.10 2002/01/16 16:15:34 xleroy Exp $ *)
(* $Id: utils.mli,v 1.12 2004/01/09 21:12:12 doligez Exp $ *)
(* Utility functions *)
......
......@@ -10,7 +10,7 @@
#* *
#***********************************************************************
#* $Id: Makefile.win32,v 1.5 2002/04/22 11:50:46 xleroy Exp $
#* $Id: Makefile.win32,v 1.6 2004/07/08 12:21:58 xleroy Exp $
## Configuration section
......@@ -29,10 +29,10 @@ OBJEXT=obj
RANLIB=echo
# Location of the Objective Caml library in your installation
OCAMLLIB=/ocaml/lib
OCAMLLIB=C:/ocaml/lib
# Where to install the binaries
BINDIR=/ocaml/bin
BINDIR=C:/ocaml/bin
# The Objective Caml compilers (the defaults below should be OK)
OCAMLC=ocamlc -g
......
......@@ -10,7 +10,7 @@
(* *)
(***********************************************************************)
(* $Id: com.ml,v 1.8 2000/08/19 11:04:59 xleroy Exp $ *)
(* $Id: com.ml,v 1.9 2004/07/08 09:44:40 xleroy Exp $ *)
(* Run-time library for COM components *)
......@@ -36,7 +36,6 @@ type iDispatch
let iUnknown_of (intf : 'a interface) = (Obj.magic intf : iUnknown interface)
let _ =
Callback.register "Oo.new_method" Oo.new_method;
Callback.register_exception "Com.Error" (Error(0, "", ""))
external combine: 'a interface -> 'b interface -> 'a interface =
......
......@@ -10,28 +10,24 @@
/* */
/***********************************************************************/
/* $Id: camlidlruntime.h,v 1.12 2001/06/09 14:48:20 xleroy Exp $ */
/* $Id: camlidlruntime.h,v 1.13 2004/07/08 09:48:15 xleroy Exp $ */
/* Helper functions for stub code generated by camlidl */
#include <stddef.h>
#include <caml/mlvalues.h>
#include <caml/signals.h>
/* Functions for allocating in the Caml heap */
#if !defined(CAMLVERSION) || CAMLVERSION >= 201
#define camlidl_alloc alloc
#define camlidl_alloc_small alloc_small
#else
value camlidl_alloc(mlsize_t size, tag_t tag);
#define camlidl_alloc_small alloc
#endif
#define camlidl_alloc caml_alloc
#define camlidl_alloc_small caml_alloc_small
/* Helper functions for conversion */
value camlidl_find_enum(int n, int *flags, int nflags, char *errmsg);
value camlidl_alloc_flag_list (int n, int *flags, int nflags);
mlsize_t camlidl_ptrarray_size(void ** array);
extern value camlidl_find_enum(int n, int *flags, int nflags, char *errmsg);
extern value camlidl_alloc_flag_list (int n, int *flags, int nflags);
extern mlsize_t camlidl_ptrarray_size(void ** array);
/* Malloc-like allocation with en masse deallocation */
......@@ -53,9 +49,9 @@ struct camlidl_ctx_struct {
typedef struct camlidl_ctx_struct * camlidl_ctx;
void * camlidl_malloc(size_t sz, camlidl_ctx ctx);
void camlidl_free(camlidl_ctx ctx);
char * camlidl_malloc_string(value mlstring, camlidl_ctx ctx);
extern void * camlidl_malloc(size_t sz, camlidl_ctx ctx);
extern void camlidl_free(camlidl_ctx ctx);
extern char * camlidl_malloc_string(value mlstring, camlidl_ctx ctx);
void camlidl_register_allocation(camlidl_free_function free_fn,
void * block,
camlidl_ctx ctx);
......@@ -90,10 +86,8 @@ typedef HRESULT HRESULT_bool;
#define VTBL_PADDING
#endif
value camlidl_lookup_method(char * name);
void * camlidl_unpack_interface(value vintf, camlidl_ctx ctx);
value camlidl_pack_interface(void * intf, camlidl_ctx ctx);
extern void * camlidl_unpack_interface(value vintf, camlidl_ctx ctx);
extern value camlidl_pack_interface(void * intf, camlidl_ctx ctx);
struct camlidl_component;
......@@ -111,67 +105,62 @@ struct camlidl_component {
struct camlidl_intf intf[1];
};
value camlidl_make_interface(void * vtbl, value caml_object, IID * iid,
int has_dispatch);
extern value camlidl_make_interface(void * vtbl, value caml_object,
IID * iid, int has_dispatch);
/* Basic methods (QueryInterface, AddRef, Release) for COM objects
encapsulating a Caml object */
HRESULT STDMETHODCALLTYPE
extern HRESULT STDMETHODCALLTYPE
camlidl_QueryInterface(struct camlidl_intf * self, REFIID iid,
void ** object);
ULONG STDMETHODCALLTYPE
extern ULONG STDMETHODCALLTYPE
camlidl_AddRef(struct camlidl_intf * self);
ULONG STDMETHODCALLTYPE
extern ULONG STDMETHODCALLTYPE
camlidl_Release(struct camlidl_intf * self);
/* Extra methods for the IDispatch interface */
#ifdef _WIN32
HRESULT STDMETHODCALLTYPE
extern HRESULT STDMETHODCALLTYPE
camlidl_GetTypeInfoCount(struct camlidl_intf * self, UINT * count_type_info);
HRESULT STDMETHODCALLTYPE
extern HRESULT STDMETHODCALLTYPE
camlidl_GetTypeInfo(struct camlidl_intf * self, UINT iTypeInfo,
LCID localization, ITypeInfo ** res);
HRESULT STDMETHODCALLTYPE
extern HRESULT STDMETHODCALLTYPE
camlidl_GetIDsOfNames(struct camlidl_intf * self, REFIID iid,
OLECHAR** arrayNames, UINT countNames,
LCID localization, DISPID * arrayDispIDs);
HRESULT STDMETHODCALLTYPE
extern HRESULT STDMETHODCALLTYPE
camlidl_Invoke(struct camlidl_intf * self, DISPID dispidMember, REFIID iid,
LCID localization, WORD wFlags, DISPPARAMS * dispParams,
VARIANT * varResult, EXCEPINFO * excepInfo, UINT * argErr);
#endif
/* Lookup a method in a method suite */
/* (Should be in mlvalues.h?) */
#define Lookup(obj, lab) \
Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \
((lab) / sizeof (value)) & 0xFF)
/* Raise an error */
void camlidl_error(HRESULT errcode, char * who, char * msg);
extern void camlidl_error(HRESULT errcode, char * who, char * msg);
/* Handle HRESULTs */
void camlidl_check_hresult(HRESULT hr);
value camlidl_c2ml_Com_HRESULT_bool(HRESULT_bool * hr, camlidl_ctx ctx);
void camlidl_ml2c_Com_HRESULT_bool(value v, HRESULT_bool * hr,
camlidl_ctx ctx);
value camlidl_c2ml_Com_HRESULT_int(HRESULT_int * hr, camlidl_ctx ctx);
void camlidl_ml2c_Com_HRESULT_int(value v, HRESULT_int * hr, camlidl_ctx ctx);
extern void camlidl_check_hresult(HRESULT hr);
extern value camlidl_c2ml_Com_HRESULT_bool(HRESULT_bool * hr,
camlidl_ctx ctx);
extern void camlidl_ml2c_Com_HRESULT_bool(value v, HRESULT_bool * hr,
camlidl_ctx ctx);
extern value camlidl_c2ml_Com_HRESULT_int(HRESULT_int * hr, camlidl_ctx ctx);
extern void camlidl_ml2c_Com_HRESULT_int(value v, HRESULT_int * hr,
camlidl_ctx ctx);
/* Handle uncaught exceptions in C-to-ML callbacks */
HRESULT camlidl_result_exception(char * methname, value exn_bucket);
void camlidl_uncaught_exception(char * methname, value exn_bucket);
extern HRESULT camlidl_result_exception(char * methname, value exn_bucket);
extern void camlidl_uncaught_exception(char * methname, value exn_bucket);
/* Conversion functions for OLE Automation types */
#ifdef _WIN32
void camlidl_ml2c_Com_BSTR(value s, BSTR * res, camlidl_ctx ctx);
value camlidl_c2ml_Com_BSTR(BSTR * bs, camlidl_ctx ctx);
extern void camlidl_ml2c_Com_BSTR(value s, BSTR * res, camlidl_ctx ctx);
extern value camlidl_c2ml_Com_BSTR(BSTR * bs, camlidl_ctx ctx);
#endif
......@@ -10,7 +10,7 @@
/* */
/***********************************************************************/
/* $Id: cfactory.cpp,v 1.8 2001/07/30 14:05:17 xleroy Exp $ */
/* $Id: cfactory.cpp,v 1.9 2004/07/08 09:48:33 xleroy Exp $ */
/* The class factory and DLL support */
......@@ -26,6 +26,11 @@ extern "C" {
#include "comstuff.h"
#include "registry.h"
#ifdef __CYGWIN32__
#include <sys/param.h>
#define _MAX_PATH MAXPATHLEN
#endif
/* Count of server locks */
static long camlidl_num_server_locks = 0;
......@@ -175,11 +180,14 @@ STDAPI DllCanUnloadNow()
BOOL APIENTRY DllMain(HANDLE module, DWORD reason, void *reserved)
{
char * argv[1];
char * argv[2];
char dll_path[_MAX_PATH];
switch(reason) {
case DLL_PROCESS_ATTACH:
argv[0] = NULL;
GetModuleFileName( (HMODULE) module, dll_path, _MAX_PATH );
argv[0] = dll_path;
argv[1] = NULL;
camlidl_module_handle = (HMODULE) module;
#if 0
int fd = open("/tmp/camllog", O_RDWR|O_TRUNC|O_CREAT, _S_IWRITE|_S_IREAD);
......
......@@ -10,7 +10,7 @@
/* */
/***********************************************************************/
/* $Id: comintf.c,v 1.10 2000/08/19 11:05:00 xleroy Exp $ */
/* $Id: comintf.c,v 1.11 2004/07/08 09:49:37 xleroy Exp $ */
/* Helper functions for handling COM interfaces */
......@@ -26,17 +26,6 @@
int camlidl_num_components = 0;
value camlidl_lookup_method(char * name)
{
static value * lookup_clos = NULL;
if (lookup_clos == NULL) {
lookup_clos = caml_named_value("Oo.new_method");
if (lookup_clos == NULL) invalid_argument("Oo.new_method not registered");
}
return callback(*lookup_clos, copy_string(name));
}
static void camlidl_finalize_interface(value intf)
{
interface IUnknown * i = (interface IUnknown *) Field(intf, 1);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment