diff -u -r -N camlidl-1.00/.cvsignore camlidl-ext/.cvsignore --- camlidl-1.00/.cvsignore Fri Feb 19 15:36:25 1999 +++ camlidl-ext/.cvsignore Fri Mar 26 17:43:21 1999 @@ -1 +1,7 @@ -caml +camlidl +config.ml +parser_midl.output +parser_midl.ml +parser_midl.mli +lexer_midl.ml +linenum.ml diff -u -r -N camlidl-1.00/Makefile camlidl-ext/Makefile --- camlidl-1.00/Makefile Mon Feb 22 18:42:22 1999 +++ camlidl-ext/Makefile Tue Mar 30 10:28:26 1999 @@ -23,4 +23,3 @@ cd runtime; $(MAKE) depend cd lib; $(MAKE) depend cd tools; $(MAKE) depend - diff -u -r -N camlidl-1.00/README camlidl-ext/README --- camlidl-1.00/README Wed Feb 24 13:28:02 1999 +++ camlidl-ext/README Tue Mar 30 10:50:22 1999 @@ -1,57 +1,39 @@ OVERVIEW: -Camlidl is a stub code generator for Objective Caml. It generates -stub code for interfacing Caml with C from an IDL description of the C -functions. Thus, Camlidl automates the most tedious task in -interfacing C libraries with Caml programs. It can also be used to -interface Caml programs with other languages, as long as those -languages have a well-defined C interface. +This package contains some extensions to the Camlidl software described +in README.ORIG. These extensions are -In addition, Camlidl provides basic support for COM interfaces and -components under MS Windows. It supports both using COM components -(usually written in C++ or C) from Caml programs, and packaging Caml -objects as COM components that can then be used from C++ or C. + o a new pointer kind for handling finalized opaque pointers + o a (limited) mechanism for handling functions that accept variable argument + lists. -COPYRIGHT: +COPYRIGHT -All files marked "Copyright INRIA" in this distribution are copyright -1999 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. +see README.ORIG. +REQUIREMENTS -REQUIREMENTS: +see README.ORIG. -Camlidl requires Objective Caml 2.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/). +INSTALLATION +- see README.ORIG -INSTALLATION: - -- Under Unix, copy config/Makefile.unix to config/Makefile. - Under Windows, copy config/Makefile.windows to config/Makefile. - -- Edit config/Makefile to set configuration options, following the - comments in that file. You must set the OCAMLLIB and BINDIR variables - to reflect the location of your OCaml installation. Other variables - have reasonable defaults. - -- Do "make all". - -- Become super-user if necessary and do "make install". - - -DOCUMENTATION: - -- The doc/ subdirectory contains the user's manual in HTML and in Postscript. - -- Several examples are provided in the directories tests/ and tests/comp/. +DOCUMENTATION: see README.ORIG +- see README.ORIG +- the doc/ subdirectory contains the user's manual in HTML and in Postscript. +- the extensions themselves are described in the file ./doc/extensions.txt +- the directory ./other-tests contains several examples programs using the +extensions. To use them, just go to ./other-tests and type "make". +- the invokation mechanism and options are unchanged, except that the name +of the generated C source file containing the stub code has been changed to +[f_stubs.c], if [f.idl] if the name of IDL file. SUPPORT: -- Please send bug reports and comments to caml-light@inria.fr - +- Please send bug reports and comments _concerning the extensions_ to CamlIDL + to Jocelyn.Serot@lasmea.univ-bpclermont.fr. +- Please report bug and comments conncerning CamlIDL itself to caml + caml-light@inria.fr diff -u -r -N camlidl-1.00/README.ORIG camlidl-ext/README.ORIG --- camlidl-1.00/README.ORIG Thu Jan 1 01:00:00 1970 +++ camlidl-ext/README.ORIG Wed Feb 24 13:28:02 1999 @@ -0,0 +1,57 @@ +OVERVIEW: + +Camlidl is a stub code generator for Objective Caml. It generates +stub code for interfacing Caml with C from an IDL description of the C +functions. Thus, Camlidl automates the most tedious task in +interfacing C libraries with Caml programs. It can also be used to +interface Caml programs with other languages, as long as those +languages have a well-defined C interface. + +In addition, Camlidl provides basic support for COM interfaces and +components under MS Windows. It supports both using COM components +(usually written in C++ or C) from Caml programs, and packaging Caml +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 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. + + +REQUIREMENTS: + +Camlidl requires Objective Caml 2.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/). + + +INSTALLATION: + +- Under Unix, copy config/Makefile.unix to config/Makefile. + Under Windows, copy config/Makefile.windows to config/Makefile. + +- Edit config/Makefile to set configuration options, following the + comments in that file. You must set the OCAMLLIB and BINDIR variables + to reflect the location of your OCaml installation. Other variables + have reasonable defaults. + +- Do "make all". + +- Become super-user if necessary and do "make install". + + +DOCUMENTATION: + +- The doc/ subdirectory contains the user's manual in HTML and in Postscript. + +- Several examples are provided in the directories tests/ and tests/comp/. + + +SUPPORT: + +- Please send bug reports and comments to caml-light@inria.fr + diff -u -r -N camlidl-1.00/compiler/.depend camlidl-ext/compiler/.depend --- camlidl-1.00/compiler/.depend Thu Mar 4 17:21:41 1999 +++ camlidl-ext/compiler/.depend Fri Mar 26 18:57:19 1999 @@ -1,4 +1,3 @@ -array.cmi: idltypes.cmi constdecl.cmi: idltypes.cmi cvttyp.cmi: idltypes.cmi cvtval.cmi: idltypes.cmi @@ -6,6 +5,7 @@ enumdecl.cmi: idltypes.cmi file.cmi: constdecl.cmi funct.cmi idltypes.cmi intf.cmi typedef.cmi funct.cmi: idltypes.cmi +idlarray.cmi: idltypes.cmi intf.cmi: funct.cmi idltypes.cmi lexer_midl.cmi: parser_midl.cmi lexpr.cmi: idltypes.cmi @@ -19,11 +19,8 @@ typedef.cmi: idltypes.cmi union.cmi: idltypes.cmi uniondecl.cmi: idltypes.cmi +valist.cmi: idltypes.cmi variables.cmi: idltypes.cmi -array.cmo: cvttyp.cmi idltypes.cmi lexpr.cmi utils.cmi variables.cmi \ - array.cmi -array.cmx: cvttyp.cmx idltypes.cmi lexpr.cmx utils.cmx variables.cmx \ - array.cmi clflags.cmo: config.cmi clflags.cmx: config.cmx config.cmo: config.cmi @@ -32,10 +29,10 @@ constdecl.cmx: cvttyp.cmx idltypes.cmi lexpr.cmx utils.cmx constdecl.cmi cvttyp.cmo: idltypes.cmi lexpr.cmi utils.cmi cvttyp.cmi cvttyp.cmx: idltypes.cmi lexpr.cmx utils.cmx cvttyp.cmi -cvtval.cmo: array.cmi cvttyp.cmi enum.cmi idltypes.cmi lexpr.cmi struct.cmi \ - union.cmi utils.cmi variables.cmi cvtval.cmi -cvtval.cmx: array.cmx cvttyp.cmx enum.cmx idltypes.cmi lexpr.cmx struct.cmx \ - union.cmx utils.cmx variables.cmx cvtval.cmi +cvtval.cmo: cvttyp.cmi enum.cmi idlarray.cmi idltypes.cmi lexpr.cmi \ + struct.cmi union.cmi utils.cmi variables.cmi cvtval.cmi +cvtval.cmx: cvttyp.cmx enum.cmx idlarray.cmx idltypes.cmi lexpr.cmx \ + struct.cmx union.cmx utils.cmx variables.cmx cvtval.cmi enum.cmo: idltypes.cmi utils.cmi variables.cmi enum.cmi enum.cmx: idltypes.cmi utils.cmx variables.cmx enum.cmi enumdecl.cmo: cvttyp.cmi cvtval.cmi enum.cmi idltypes.cmi utils.cmi \ @@ -47,9 +44,13 @@ file.cmx: clflags.cmx constdecl.cmx enumdecl.cmx funct.cmx idltypes.cmi \ intf.cmx structdecl.cmx typedef.cmx uniondecl.cmx utils.cmx file.cmi funct.cmo: cvttyp.cmi cvtval.cmi idltypes.cmi lexpr.cmi typedef.cmi utils.cmi \ - variables.cmi funct.cmi + valist.cmi variables.cmi funct.cmi funct.cmx: cvttyp.cmx cvtval.cmx idltypes.cmi lexpr.cmx typedef.cmx utils.cmx \ - variables.cmx funct.cmi + valist.cmx variables.cmx funct.cmi +idlarray.cmo: cvttyp.cmi idltypes.cmi lexpr.cmi utils.cmi variables.cmi \ + idlarray.cmi +idlarray.cmx: cvttyp.cmx idltypes.cmi lexpr.cmx utils.cmx variables.cmx \ + idlarray.cmi intf.cmo: cvttyp.cmi cvtval.cmi funct.cmi idltypes.cmi utils.cmi \ variables.cmi intf.cmi intf.cmx: cvttyp.cmx cvtval.cmx funct.cmx idltypes.cmi utils.cmx \ @@ -100,5 +101,7 @@ variables.cmx uniondecl.cmi utils.cmo: utils.cmi utils.cmx: utils.cmi +valist.cmo: cvttyp.cmi idltypes.cmi utils.cmi variables.cmi valist.cmi +valist.cmx: cvttyp.cmx idltypes.cmi utils.cmx variables.cmx valist.cmi variables.cmo: cvttyp.cmi idltypes.cmi utils.cmi variables.cmi variables.cmx: cvttyp.cmx idltypes.cmi utils.cmx variables.cmi diff -u -r -N camlidl-1.00/compiler/Makefile camlidl-ext/compiler/Makefile --- camlidl-1.00/compiler/Makefile Thu Mar 4 17:21:41 1999 +++ camlidl-ext/compiler/Makefile Fri Mar 26 19:02:05 1999 @@ -2,9 +2,9 @@ OBJS=config.cmo utils.cmo clflags.cmo \ lexpr.cmo cvttyp.cmo variables.cmo \ - array.cmo struct.cmo enum.cmo union.cmo cvtval.cmo \ + idlarray.cmo struct.cmo enum.cmo union.cmo cvtval.cmo \ structdecl.cmo enumdecl.cmo uniondecl.cmo \ - typedef.cmo funct.cmo constdecl.cmo intf.cmo \ + typedef.cmo valist.cmo funct.cmo constdecl.cmo intf.cmo \ file.cmo predef.cmo \ parse_aux.cmo parser_midl.cmo lexer_midl.cmo linenum.cmo parse.cmo \ normalize.cmo \ diff -u -r -N camlidl-1.00/compiler/array.ml camlidl-ext/compiler/array.ml --- camlidl-1.00/compiler/array.ml Fri Feb 19 15:33:26 1999 +++ camlidl-ext/compiler/array.ml Mon Mar 29 12:09:12 1999 @@ -58,7 +58,7 @@ end end else begin (* Determine actual size of ML array *) - let size = new_c_variable (Type_named("", "mlsize_t")) in + let size = new_c_variable Onstack (Type_named("", "mlsize_t")) in if is_float_type ty_elt then iprintf oc "%s = Wosize_val(%s) / Double_wosize;\n" size v else iprintf oc "%s = Wosize_val(%s);\n" size v; @@ -80,7 +80,7 @@ (Lexpr.eval_int n) !current_function end; (* Copy the array elements *) - let idx = new_c_variable (Type_named("", "mlsize_t")) in + let idx = new_c_variable Onstack (Type_named("", "mlsize_t")) in begin match attr with {bound = Some n; size = None} -> iprintf oc "for (%s = 0; %s < %d; %s++) {\n" @@ -109,14 +109,10 @@ end (* Translation from a C array [c] to an ML array [v] *) - -let array_c_to_ml c_to_ml oc pref attr ty_elt c v = - if attr.is_string then - iprintf oc "%s = copy_string(%s);\n" v c - else begin - (* Determine size of ML array *) - let (nsize, size) = - match attr with + +(* Determine size of a C array *) +let c_array_size oc pref attr name = + match attr with {length = Some re} -> (max_int, Lexpr.tostring pref re) | {size = Some re} -> @@ -125,11 +121,18 @@ let n = Lexpr.eval_int le in (n, string_of_int n) | {null_terminated = true} -> - let sz = new_c_variable (Type_named("", "mlsize_t")) in - iprintf oc "%s = camlidl_ptrarray_size((void **) %s);\n" sz c; + let sz = new_c_variable Onstack (Type_named("", "mlsize_t")) in + iprintf oc "%s = camlidl_ptrarray_size((void **) %s);\n" sz name; (max_int, sz) | _ -> - error "Cannot determine array size for C -> ML conversion" in + error "Cannot determine size a C array" + +let array_c_to_ml c_to_ml oc pref attr ty_elt c v = + if attr.is_string then + iprintf oc "%s = copy_string(%s);\n" v c + else begin + (* Determine size of ML array *) + let (nsize, size) = c_array_size oc pref attr c in (* Allocate ML array *) let alloc_function = if nsize < 64 && no_allocation_type ty_elt @@ -143,7 +146,7 @@ increase_indent() end; (* Copy elements of C array *) - let idx = new_c_variable (Type_named("", "mlsize_t")) in + let idx = new_c_variable Onstack (Type_named("", "mlsize_t")) in iprintf oc "for (%s = 0; %s < %s; %s++) {\n" idx idx size idx; increase_indent(); if is_float_type ty_elt then diff -u -r -N camlidl-1.00/compiler/array.mli camlidl-ext/compiler/array.mli --- camlidl-1.00/compiler/array.mli Fri Feb 19 15:33:26 1999 +++ camlidl-ext/compiler/array.mli Mon Mar 29 12:09:48 1999 @@ -24,3 +24,9 @@ out_channel -> string -> array_attributes -> idltype -> string -> string -> unit +val c_array_size : + out_channel -> + string -> Idltypes.array_attributes -> string -> int * string + +val is_float_type : Idltypes.idltype -> bool +val no_allocation_type : Idltypes.idltype -> bool diff -u -r -N camlidl-1.00/compiler/cvttyp.ml camlidl-ext/compiler/cvttyp.ml --- camlidl-1.00/compiler/cvttyp.ml Fri Feb 19 15:33:27 1999 +++ camlidl-ext/compiler/cvttyp.ml Thu Mar 25 11:21:46 1999 @@ -62,6 +62,9 @@ Some n -> sprintf "%s[%d]" id (Lexpr.eval_int n) | None -> sprintf "*%s" id in out_c_decl oc (id', ty) + | Type_valist(attr, ty) -> + let id' = sprintf "*%s" id in + out_c_decl oc (id', ty) | Type_interface(modl, intf_name) -> fprintf oc "struct %s %s" intf_name id @@ -146,12 +149,15 @@ Ref -> out_ml_type oc ty | Unique -> fprintf oc "%a option" out_ml_type ty | Ptr -> fprintf oc "%a Com.opaque" out_ml_type ty + | Boxed _ -> fprintf oc "%a Com.opaque" out_ml_type ty | Ignore -> assert false end | Type_array(attr, ty) -> if attr.is_string then fprintf oc "string" else fprintf oc "%a array" out_ml_type ty + | Type_valist(attr, ty) -> + fprintf oc "%a array" out_ml_type ty | Type_interface(modl, name) -> fprintf oc "%a Com.interface" out_mltype_name (modl, name) diff -u -r -N camlidl-1.00/compiler/cvtval.ml camlidl-ext/compiler/cvtval.ml --- camlidl-1.00/compiler/cvtval.ml Fri Feb 19 15:33:28 1999 +++ camlidl-ext/compiler/cvtval.ml Fri Mar 26 12:07:37 1999 @@ -24,7 +24,7 @@ let allocate_space oc onstack ty c = if onstack then begin - let c' = new_c_variable ty in + let c' = new_c_variable Onstack ty in iprintf oc "%s = &%s;\n" c c'; c' end else begin @@ -102,10 +102,14 @@ iprintf oc "}\n" | Type_pointer(Ptr, ty_elt) -> iprintf oc "%s = (%a) Field(%s, 0);\n" c out_c_type ty v + | Type_pointer(Boxed _, ty_elt) -> + iprintf oc "%s = (%a) Field(%s, 1);\n" c out_c_type ty v | Type_pointer(Ignore, ty_elt) -> iprintf oc "%s = NULL;\n" c | Type_array(attr, ty_elt) -> - Array.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v c + Idlarray.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v c + | Type_valist(attr, ty_elt) -> + Idlarray.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v c | Type_interface(modl, name) -> error (sprintf "Reference to interface %s that is not a pointer" name) @@ -174,9 +178,17 @@ | Type_pointer(Ptr, ty_elt) -> iprintf oc "%s = camlidl_alloc_small(1, Abstract_tag);\n" v; iprintf oc "Field(%s, 0) = (value) %s;\n" v c + | Type_pointer(Boxed finalize, ty_elt) -> + let finalize_fun = match finalize with + None -> "camlidl_finalize" + | Some f -> f in + iprintf oc "%s = camlidl_alloc_final(2, %s, 1, 1);\n" v finalize_fun; + iprintf oc "Field(%s, 1) = (value) %s;\n" v c | Type_pointer(Ignore, ty_elt) -> () | Type_array(attr, ty_elt) -> - Array.array_c_to_ml c_to_ml oc pref attr ty_elt c v + Idlarray.array_c_to_ml c_to_ml oc pref attr ty_elt c v + | Type_valist(attr, ty_elt) -> + Idlarray.array_c_to_ml c_to_ml oc pref attr ty_elt c v | Type_interface(modl, name) -> error (sprintf "Reference to interface %s that is not a pointer" name) diff -u -r -N camlidl-1.00/compiler/enumdecl.ml camlidl-ext/compiler/enumdecl.ml --- camlidl-1.00/compiler/enumdecl.ml Mon Feb 22 10:59:55 1999 +++ camlidl-ext/compiler/enumdecl.ml Thu Mar 25 11:03:12 1999 @@ -62,7 +62,7 @@ fprintf oc "{\n"; let pc = divert_output() in increase_indent(); - let c = new_c_variable (Type_int Int) in + let c = new_c_variable Onstack (Type_int Int) in enum_ml_to_c ml_to_c pc en v c; iprintf pc "return %s;\n" c; output_variable_declarations oc; diff -u -r -N camlidl-1.00/compiler/file.ml camlidl-ext/compiler/file.ml --- camlidl-1.00/compiler/file.ml Fri Feb 19 15:33:17 1999 +++ camlidl-ext/compiler/file.ml Wed Mar 24 13:04:24 1999 @@ -162,6 +162,9 @@ (* Output the header *) fprintf oc "/* File generated from %s.idl */\n\n" !module_name; output_string oc "\ + #ifdef CAMLIDL_DEBUG\n\ + #include \n\ + #endif\n\ #include \n\ #include \n\ #include \n\ diff -u -r -N camlidl-1.00/compiler/funct.ml camlidl-ext/compiler/funct.ml --- camlidl-1.00/compiler/funct.ml Wed Feb 24 13:27:43 1999 +++ camlidl-ext/compiler/funct.ml Mon Mar 29 12:33:29 1999 @@ -30,13 +30,29 @@ fun_res: idltype; fun_params: (string * in_out * idltype) list; fun_call: string option; - fun_dealloc: string option } + fun_dealloc: string option; + fun_hasvarg: int option } (* Remove dependent parameters (parameters that are size_is, length_is, or switch_is of another parameter). Also remove ignored pointers. *) +(* + * Do _not_ remove parameters that are used as size_is or length_is for an + * output array or valist !! + * Example: + * void make_array([in] int n, [out,size_is(n)] int xs[] + * should lead to + * val make_array : int -> int array = ... + * ^^^ + *) let is_dependent_parameter name params = - List.exists (fun (_, _, ty) -> Lexpr.is_dependent name ty) params + List.exists (function + (_, Out, Type_array({size=Some (Expr_ident name)}, ty)) -> false + | (_, Out, Type_array({length=Some (Expr_ident name)}, ty)) -> false + | (_, Out, Type_valist({size=Some (Expr_ident name)}, ty)) -> false + | (_, Out, Type_valist({length=Some (Expr_ident name)}, ty)) -> false + | (_, _, ty) -> Lexpr.is_dependent name ty) + params let is_ignored = function Type_pointer(Ignore, _) -> true | _ -> false @@ -184,7 +200,7 @@ List.iter (function (name, (In|InOut), Type_pointer(attr, ty_arg)) when is_dependent_parameter name fundecl.fun_params -> - let c = new_c_variable ty_arg in + let c = new_c_variable Onstack ty_arg in iprintf pc "%s = &%s;\n" name c | _ -> ()) fundecl.fun_params; @@ -195,9 +211,30 @@ (* Initialize outs that are pointers so that they point to suitable storage *) List.iter - (function (name, Out, Type_pointer(attr, ty_arg)) -> - let c = new_c_variable ty_arg in + (function (name, Out, Type_pointer(Boxed _, ty_arg)) -> + let c = new_c_variable Onheap ty_arg in + iprintf pc "%s = %s;\n" name c + | (name, Out, Type_pointer(_, ty_arg)) -> + let c = new_c_variable Onstack ty_arg in iprintf pc "%s = &%s;\n" name c + | (name, Out, Type_array(attr, Type_pointer(Boxed _, ty_el))) -> + let nsz, sz = Idlarray.c_array_size pc "" attr name in + fill_array_boxed pc name sz ty_el + | (name, Out, Type_valist(_,(Type_pointer(Boxed _,ty_el) as ty))) -> + let ty' = Type_array( + { bound = Some (Expr_int Valist.max_va_size); + size = None; length = None; + is_string = false; null_terminated = false }, ty) in + let c = new_c_variable Onstack ty' in + iprintf pc "%s = %s;\n" name c; + fill_array_boxed pc c (sprintf "%d" Valist.max_va_size) ty_el + | (name, Out, Type_valist(_, ty_arg)) -> + let ty' = Type_array( + { bound = Some (Expr_int Valist.max_va_size); + size = None; length = None; + is_string = false; null_terminated = false }, ty_arg) in + let c = new_c_variable Onstack ty' in + iprintf pc "%s = %s;\n" name c; | _ -> ()) fundecl.fun_params; (* Generate the call to C function *) @@ -285,10 +322,45 @@ end; fprintf oc ");\n" +let emit_vararg_call oc fd = + (* Retrieve the va parameter *) + let va_idx = + match fd.fun_hasvarg with Some i -> i | _ -> error "emit_varg_call" in + let va_name, va_ty, va_size = match List.nth fd.fun_params va_idx with + n, io, Type_valist({size=Some Expr_ident e}, ty) -> n, ty, e + | n, io, Type_valist({length=Some Expr_ident e}, ty) -> n, ty, e + | _ -> error "emit_varg_call" in + (* Check the actual size of *) + iprintf oc "if (%s > %d) invalid_argument(\"%s: valist too big\");\n" + va_size Valist.max_va_size fd.fun_name; + iprintf oc "switch ( %s ) {\n" va_size; + for i = 1 to Valist.max_va_size do + iprintf oc " case %d: " i; + let fd' = {fd with fun_params = List.flatten (List.map (function + | (n, io, Type_valist(attr, ty)) -> + let hack = begin match io, va_ty with + (Out|InOut), Type_pointer (_, _) -> "" + | (Out|InOut), _ -> "&" + | In, _ -> "" end in + Array.to_list (Array.init i + (fun j -> (sprintf "%s%s[%d]" hack n j, io, ty))) + | (n, io, ty) when n = va_size -> [string_of_int i, io, ty] + | p -> [p]) + fd.fun_params) } in + emit_standard_call oc fd'; + iprintf oc " break;\n" + done; + iprintf oc " default: invalid_argument(\"%s: bad size for valist\");" + fd.fun_name; + iprintf oc "}\n" + let emit_wrapper oc fundecl = current_function := fundecl.fun_name; - let (ins, outs) = ml_view fundecl in - emit_function oc fundecl ins outs fundecl.fun_params emit_standard_call; + let (ins, outs) = ml_view fundecl + and emit_call = match fundecl.fun_hasvarg with + Some idx -> emit_vararg_call + | None -> emit_standard_call in + emit_function oc fundecl ins outs fundecl.fun_params emit_call; current_function := "" (* Emit wrapper function for COM method *) diff -u -r -N camlidl-1.00/compiler/funct.mli camlidl-ext/compiler/funct.mli --- camlidl-1.00/compiler/funct.mli Wed Feb 24 13:27:43 1999 +++ camlidl-ext/compiler/funct.mli Fri Mar 26 12:09:40 1999 @@ -24,7 +24,8 @@ fun_res: idltype; fun_params: (string * in_out * idltype) list; fun_call: string option; - fun_dealloc: string option } + fun_dealloc: string option; + fun_hasvarg: int option } val ml_view : function_decl -> (string * idltype) list * (string * idltype) list diff -u -r -N camlidl-1.00/compiler/idlarray.ml camlidl-ext/compiler/idlarray.ml --- camlidl-1.00/compiler/idlarray.ml Thu Jan 1 01:00:00 1970 +++ camlidl-ext/compiler/idlarray.ml Mon Mar 29 12:09:12 1999 @@ -0,0 +1,169 @@ +(***********************************************************************) +(* *) +(* CamlIDL *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: array.ml,v 1.10 1999/02/19 14:33:26 xleroy Exp $ *) + +(* Handling of arrays *) + +open Printf +open Utils +open Variables +open Idltypes +open Cvttyp + +(* Recognize float IDL types *) + +let is_float_type = + function Type_float -> true | Type_double -> true | _ -> false + +(* Recognize IDL types whose conversion C -> ML performs no allocation. + Due to the special treatment of float arrays, float and double + are also treated as "no allocation". *) + +let rec no_allocation_type = function + Type_int _ -> true + | Type_float -> true + | Type_double -> true + | Type_pointer(kind, ty) -> kind = Ref && no_allocation_type ty + | Type_enum _ -> true + | _ -> false + +(* Translation from an ML array [v] to a C array [c] *) + +let array_ml_to_c ml_to_c oc onstack pref attr ty_elt v c = + if attr.is_string then begin + begin match attr.bound with + None -> + if onstack + then iprintf oc "%s = String_val(%s);\n" c v + else iprintf oc "%s = camlidl_malloc_string(%s, _ctx);\n" c v + | Some n -> + iprintf oc + "if (string_length(%s) >= %d) invalid_argument(\"%s\");\n" + v (Lexpr.eval_int n) !current_function; + iprintf oc "strcpy(%s, String_val(%s));\n" c v + end; + begin match attr.size with + None -> () + | Some re -> iprintf oc "%a = string_length(%s);\n" + Lexpr.output (pref, re) v + end + end else begin + (* Determine actual size of ML array *) + let size = new_c_variable Onstack (Type_named("", "mlsize_t")) in + if is_float_type ty_elt + then iprintf oc "%s = Wosize_val(%s) / Double_wosize;\n" size v + else iprintf oc "%s = Wosize_val(%s);\n" size v; + begin match attr.bound with + None -> + (* Allocate C array of same size as ML array *) + iprintf oc "%s = camlidl_malloc(" c; + if attr.null_terminated + then fprintf oc "(%s + 1)" size + else fprintf oc "%s" size; + fprintf oc " * sizeof(%a), _ctx);\n" out_c_type ty_elt; + need_context := true; + | Some n -> + (* Check compatibility of actual size w.r.t. expected size *) + iprintf oc "if (%s %s %d) invalid_argument(\"%s\");\n" + (if attr.null_terminated then size ^ " + 1" else size) + (if attr.size = None && not attr.null_terminated + then "!=" else ">") + (Lexpr.eval_int n) !current_function + end; + (* Copy the array elements *) + let idx = new_c_variable Onstack (Type_named("", "mlsize_t")) in + begin match attr with + {bound = Some n; size = None} -> + iprintf oc "for (%s = 0; %s < %d; %s++) {\n" + idx idx (Lexpr.eval_int n) idx + | _ -> + iprintf oc "for (%s = 0; %s < %s; %s++) {\n" + idx idx size idx + end; + increase_indent(); + if is_float_type ty_elt then + iprintf oc "%s[%s] = Double_field(%s, %s);\n" c idx v idx + else begin + let v' = new_ml_variable() in + iprintf oc "%s = Field(%s, %s);\n" v' v idx; + ml_to_c oc onstack pref ty_elt v' (sprintf "%s[%s]" c idx) + end; + decrease_indent(); + iprintf oc "}\n"; + (* Null-terminate the array if requested *) + if attr.null_terminated then iprintf oc "%s[%s] = 0;\n" c size; + (* Update dependent size variable *) + begin match attr.size with + None -> () + | Some re -> iprintf oc "%a = %s;\n" Lexpr.output (pref, re) size + end + end + +(* Translation from a C array [c] to an ML array [v] *) + +(* Determine size of a C array *) +let c_array_size oc pref attr name = + match attr with + {length = Some re} -> + (max_int, Lexpr.tostring pref re) + | {size = Some re} -> + (max_int, Lexpr.tostring pref re) + | {bound = Some le} -> + let n = Lexpr.eval_int le in + (n, string_of_int n) + | {null_terminated = true} -> + let sz = new_c_variable Onstack (Type_named("", "mlsize_t")) in + iprintf oc "%s = camlidl_ptrarray_size((void **) %s);\n" sz name; + (max_int, sz) + | _ -> + error "Cannot determine size a C array" + +let array_c_to_ml c_to_ml oc pref attr ty_elt c v = + if attr.is_string then + iprintf oc "%s = copy_string(%s);\n" v c + else begin + (* Determine size of ML array *) + let (nsize, size) = c_array_size oc pref attr c in + (* Allocate ML array *) + let alloc_function = + if nsize < 64 && no_allocation_type ty_elt + then "camlidl_alloc_small" else "camlidl_alloc" in + if is_float_type ty_elt + then iprintf oc "%s = %s(%s * Double_wosize, Double_array_tag);\n" + v alloc_function size + else iprintf oc "%s = %s(%s, 0);\n" v alloc_function size; + if not (no_allocation_type ty_elt) then begin + iprintf oc "Begin_root(%s)\n" v; + increase_indent() + end; + (* Copy elements of C array *) + let idx = new_c_variable Onstack (Type_named("", "mlsize_t")) in + iprintf oc "for (%s = 0; %s < %s; %s++) {\n" idx idx size idx; + increase_indent(); + if is_float_type ty_elt then + iprintf oc "Store_double_field(%s, %s, %s[%s]);\n" v idx c idx + else if nsize < 64 && no_allocation_type ty_elt then + c_to_ml oc pref ty_elt (sprintf "%s[%s]" c idx) + (sprintf "Field(%s, %s)" v idx) + else begin + let v' = new_ml_variable() in + c_to_ml oc pref ty_elt (sprintf "%s[%s]" c idx) v'; + iprintf oc "modify(&Field(%s, %s), %s);\n" v idx v' + end; + decrease_indent(); + iprintf oc "}\n"; + (* Pop root if needed *) + if not (no_allocation_type ty_elt) then begin + decrease_indent(); + iprintf oc "End_roots()\n" + end + end diff -u -r -N camlidl-1.00/compiler/idlarray.mli camlidl-ext/compiler/idlarray.mli --- camlidl-1.00/compiler/idlarray.mli Thu Jan 1 01:00:00 1970 +++ camlidl-ext/compiler/idlarray.mli Mon Mar 29 12:09:48 1999 @@ -0,0 +1,32 @@ +(***********************************************************************) +(* *) +(* CamlIDL *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: array.mli,v 1.3 1999/02/19 14:33:26 xleroy Exp $ *) + +(* Marshaling for arrays *) + +open Idltypes + +val array_ml_to_c : + (out_channel -> bool -> string -> idltype -> string -> string -> unit) -> + out_channel -> bool -> string -> array_attributes -> idltype -> string -> string -> + unit +val array_c_to_ml : + (out_channel -> string -> idltype -> string -> string -> unit) -> + out_channel -> string -> array_attributes -> idltype -> string -> string -> + unit + +val c_array_size : + out_channel -> + string -> Idltypes.array_attributes -> string -> int * string + +val is_float_type : Idltypes.idltype -> bool +val no_allocation_type : Idltypes.idltype -> bool diff -u -r -N camlidl-1.00/compiler/idltypes.mli camlidl-ext/compiler/idltypes.mli --- camlidl-1.00/compiler/idltypes.mli Fri Feb 19 15:33:30 1999 +++ camlidl-ext/compiler/idltypes.mli Thu Mar 25 11:20:36 1999 @@ -16,7 +16,12 @@ | UInt | ULong | USmall | UShort | UChar | SChar | Byte | Boolean -type pointer_kind = Ref | Unique | Ptr | Ignore +type pointer_kind = + Ref + | Unique + | Ptr + | Boxed of string option + | Ignore type idltype = Type_int of integer_kind @@ -28,6 +33,7 @@ | Type_struct of struct_decl | Type_union of union_decl * union_attributes | Type_enum of enum_decl * enum_attributes + | Type_valist of array_attributes * idltype | Type_named of string * string (* module name, type name *) | Type_interface of string * string (* module name, interface name *) diff -u -r -N camlidl-1.00/compiler/intf.ml camlidl-ext/compiler/intf.ml --- camlidl-1.00/compiler/intf.ml Wed Feb 24 13:27:43 1999 +++ camlidl-ext/compiler/intf.ml Tue Mar 23 16:41:39 1999 @@ -167,7 +167,8 @@ fun_res = meth.fun_res; fun_params = ("this", In, self_type) :: meth.fun_params; fun_call = None; - fun_dealloc = None } in + fun_dealloc = None; + fun_hasvarg = None } in Funct.ml_declaration oc prim) intf.intf_methods; fprintf oc "\n"; diff -u -r -N camlidl-1.00/compiler/lexer_midl.mll camlidl-ext/compiler/lexer_midl.mll --- camlidl-1.00/compiler/lexer_midl.mll Thu Mar 4 17:21:43 1999 +++ camlidl-ext/compiler/lexer_midl.mll Wed Mar 17 09:11:44 1999 @@ -155,6 +155,7 @@ | "~" { TILDE } | "-" { MINUS } | "?" { QUESTIONMARK } + | "..." { ELLIPSIS } | '(' hex8 '-' hex4 '-' hex4 '-' hex4 '-' hex12 ')' { let s = Lexing.lexeme lexbuf in UUID(String.sub s 1 (String.length s - 2)) } diff -u -r -N camlidl-1.00/compiler/lexpr.ml camlidl-ext/compiler/lexpr.ml --- camlidl-1.00/compiler/lexpr.ml Thu Mar 4 17:21:43 1999 +++ camlidl-ext/compiler/lexpr.ml Tue Mar 23 17:22:30 1999 @@ -139,6 +139,8 @@ Some n -> sprintf "%s[]" trail | None -> sprintf "*%s" trail in tstype trail ty + | Type_valist(attr, ty) -> + tstype (sprintf "(...%s)" trail) ty | Type_interface(modl, intf_name) -> add_string b "struct "; add_string b intf_name; add_string b trail @@ -305,6 +307,10 @@ let rec is_dependent v ty = match ty with Type_array(attr, ty) -> + is_free_opt v attr.size || + is_free_opt v attr.length || + is_dependent v ty + | Type_valist(attr, ty) -> is_free_opt v attr.size || is_free_opt v attr.length || is_dependent v ty diff -u -r -N camlidl-1.00/compiler/main.ml camlidl-ext/compiler/main.ml --- camlidl-1.00/compiler/main.ml Fri Feb 19 15:33:33 1999 +++ camlidl-ext/compiler/main.ml Tue Mar 9 15:17:38 1999 @@ -38,12 +38,12 @@ with x -> close_out oc; remove_file (pref ^ ".ml"); raise x end; - let oc = open_out (pref ^ ".c") in + let oc = open_out (pref ^ "_stubs.c") in begin try gen_c_stub oc intf; close_out oc with x -> - close_out oc; remove_file (pref ^ ".c"); raise x + close_out oc; remove_file (pref ^ "_stubs.c"); raise x end; if !Clflags.gen_header then begin let oc = open_out (pref ^ ".h") in diff -u -r -N camlidl-1.00/compiler/normalize.ml camlidl-ext/compiler/normalize.ml --- camlidl-1.00/compiler/normalize.ml Fri Feb 19 15:33:33 1999 +++ camlidl-ext/compiler/normalize.ml Mon Mar 29 12:41:53 1999 @@ -91,6 +91,8 @@ Type_pointer(kind, normalize_type ty_elt) | Type_array(attr, ty_elt) -> Type_array(attr, normalize_type ty_elt) + | Type_valist(attr, ty_elt) -> + Type_valist(attr, normalize_type ty_elt) | Type_struct sd -> Type_struct(enter_struct sd) | Type_union(ud, discr) -> @@ -162,7 +164,16 @@ fun_mod = !module_name; fun_res = normalize_type fd.fun_res; fun_params = - List.map (fun (n, io, ty) -> (n,io, normalize_type ty)) fd.fun_params } + List.map (fun (n, io, ty) -> (n,io, normalize_type ty)) fd.fun_params; + fun_hasvarg = + let find_varg = List.fold_left (fun ps p -> match (ps, p) with + (i,is), (_, _, Type_valist (_, _)) -> i+1, i::is + | (i,is), _ -> i+1, is) (0,[]) in + match find_varg fd.fun_params with + _, [] -> None + | _, [idx] when idx = List.length fd.fun_params - 1 -> Some idx + | _, [idx] -> error "varg parameter must be the last one" + | _, _ -> error "more than one varg parameter" } in in_fundecl := false; current_function := ""; diff -u -r -N camlidl-1.00/compiler/parse_aux.ml camlidl-ext/compiler/parse_aux.ml --- camlidl-1.00/compiler/parse_aux.ml Wed Feb 24 13:27:43 1999 +++ camlidl-ext/compiler/parse_aux.ml Mon Mar 29 13:10:00 1999 @@ -60,6 +60,18 @@ type `%a', ignored.\n" out_c_type ty; ty +let rec merge_valist_attr merge_fun rexps ty = + match (rexps, ty) with + ([], _) -> ty + | (re :: rem, Type_valist(attr, ty_elt)) -> + let attr' = + if re == null_attr_var then attr else merge_fun attr re in + Type_valist(attr', merge_array_attr merge_fun rem ty_elt) + | (_, _) -> + eprintf "Warning: size_is or length_is attribute applied to \ + type `%a', ignored.\n" out_c_type ty; + ty + let is_star_attribute name = String.length name >= 1 && name.[0] = '*' let star_attribute name = String.sub name 1 (String.length name - 1) @@ -71,11 +83,18 @@ Type_pointer(Unique, ty_elt) | (("ptr", _), Type_pointer(attr, ty_elt)) -> Type_pointer(Ptr, ty_elt) + | (("boxed", []), Type_pointer(attr, ty_elt)) -> + Type_pointer((Boxed None), ty_elt) + | (("boxed", [Expr_ident finalize_fun]), Type_pointer(attr, ty_elt)) -> + Type_pointer(Boxed (Some finalize_fun), ty_elt) + | (("boxed", _), Type_pointer(attr, ty_elt)) -> + eprintf "Warning: malformed arg(s) for attribute `boxed'. ignored.\n"; + Type_pointer(Boxed None, ty_elt) | (("ignore", _), Type_pointer(attr, ty_elt)) -> Type_pointer(Ignore, ty_elt) | (("string", _), Type_array(attr, (Type_int(Char|UChar|Byte) as ty_elt))) -> Type_array({attr with is_string = true}, ty_elt) - | (("string", _), Type_pointer(attr, (Type_int(Char|UChar|Byte) as ty_elt))) -> + | (("string", _), Type_pointer(attr,(Type_int(Char|UChar|Byte) as ty_elt))) -> Type_array({no_bounds with is_string = true}, ty_elt) | (("null_terminated", _), Type_array(attr, ty_elt))-> Type_array({attr with null_terminated = true}, ty_elt) @@ -85,8 +104,15 @@ merge_array_attr (fun attr re -> {attr with size = Some re}) rexps ty | (("length_is", rexps), (Type_array(_, _) | Type_pointer(_, _))) -> - merge_array_attr (fun attr re -> {attr with length = Some re}) - rexps ty + merge_array_attr (fun attr re -> {attr with length = Some re}) rexps ty + | (("boxed", final_fun), Type_array(attr, (Type_pointer(_, _) as ty_ptd))) -> + Type_array(attr, apply_type_attribute ty_ptd ("boxed", final_fun)) + | (("size_is", rexps), Type_valist(_, ty_elt) ) -> + merge_valist_attr (fun attr re -> {attr with size = Some re}) rexps ty + | (("null_terminated", _), Type_valist(_, ty_elt) ) -> + Type_valist ({no_bounds with null_terminated = true}, ty_elt) + | (("boxed", final_fun), Type_valist(attr, (Type_pointer(_, _) as ty_ptd))) -> + Type_valist(attr, apply_type_attribute ty_ptd ("boxed", final_fun)) | (("switch_is", [rexp]), Type_union(name, attr)) -> Type_union(name, {attr with discriminant = rexp}) | (("switch_is", [rexp]), Type_pointer(attr, Type_union(name, attr'))) -> @@ -128,7 +154,10 @@ | Some In -> Some InOut | _ -> Some Out in let ty' = - match ty with Type_pointer(_, ty_elt) -> Type_pointer(Ref, ty_elt) + match ty with Type_pointer(Boxed _,ty_elt) as t -> t + (* Leave [boxed] pointers unchanged ! *) + (* All other pointers are converted to [ref]. Why ? *) + | Type_pointer(_, ty_elt) -> Type_pointer(Ref, ty_elt) | _ -> ty in merge_attributes mode' ty' rem | attr :: rem -> @@ -154,7 +183,8 @@ fun_res = merge_attributes ty_res attrs; fun_params = params; fun_call = !call; - fun_dealloc = !dealloc } + fun_dealloc = !dealloc; + fun_hasvarg = None } let make_fields attrs tybase decls = List.map @@ -212,7 +242,7 @@ td_type = Type_void; (* dummy *) td_abstract = false; td_mltype = None; td_c2ml = None; td_ml2c = None; - td_errorcode = false; td_errorcheck = None} in + td_errorcode = false; td_errorcheck = None } in let (ty', td') = merge_attributes ty td attrs in {td' with td_type = ty'} in (* If one of the decls is just a name, generate it first, @@ -239,6 +269,8 @@ ("pointer_default", [Expr_ident "ref"]) -> pointer_default := Ref | ("pointer_default", [Expr_ident "unique"]) -> pointer_default := Unique | ("pointer_default", [Expr_ident "ptr"]) -> pointer_default := Ptr + | ("pointer_default", [Expr_ident "boxed"]) -> + pointer_default := Boxed None | _ -> ()) attrs diff -u -r -N camlidl-1.00/compiler/parser_midl.mly camlidl-ext/compiler/parser_midl.mly --- camlidl-1.00/compiler/parser_midl.mly Wed Feb 24 13:27:44 1999 +++ camlidl-ext/compiler/parser_midl.mly Thu Mar 25 11:16:17 1999 @@ -48,6 +48,7 @@ %token DEFAULT %token DOT %token DOUBLE +%token ELLIPSIS %token ENUM %token EOF %token EQUAL @@ -227,7 +228,7 @@ param_declarator: /* Valid MIDL attributes: in, out, first_is, last_is, length_is, max_is, size_is, switch_type, switch_is, ref, unique, ptr, - context_handle, string */ + context_handle, string, boxed*/ attributes type_spec declarator { make_param $1 $2 $3 } ; @@ -310,6 +311,8 @@ { $2 } | direct_declarator array_bounds_declarator { fun ty -> let (id, ty1) = $1 ty in (id, Type_array($2, ty1)) } + | direct_declarator ELLIPSIS + { fun ty -> let (id, ty1) = $1 ty in (id,Type_valist(no_bounds,ty1)) } ; array_bounds_declarator: LBRACKET RBRACKET { no_bounds } diff -u -r -N camlidl-1.00/compiler/typedef.ml camlidl-ext/compiler/typedef.ml --- camlidl-1.00/compiler/typedef.ml Fri Feb 19 15:33:41 1999 +++ camlidl-ext/compiler/typedef.ml Wed Mar 24 13:01:56 1999 @@ -104,10 +104,9 @@ fprintf oc "{\n"; let pc = divert_output() in if td.td_abstract then begin - iprintf pc "%s = camlidl_alloc((sizeof(%a) + sizeof(value) - 1) / sizeof(value), Abstract_tag);\n" - v out_c_type td.td_type; - iprintf pc "*((%a *) Bp_val(%s)) = *%s;\n" - out_c_type td.td_type v c + iprintf pc "%s = camlidl_alloc( (sizeof(%a) + sizeof(value) - 1) / sizeof(value), Abstract_tag);\n" + v out_c_type td.td_type; + iprintf pc "*((%a *) Bp_val(%s)) = *%s;\n" out_c_type td.td_type v c end else begin c_to_ml pc "_badprefix." td.td_type (sprintf "(*%s)" c) v end; @@ -132,5 +131,3 @@ | None -> transl_c_to_ml oc td end - - diff -u -r -N camlidl-1.00/compiler/uniondecl.ml camlidl-ext/compiler/uniondecl.ml --- camlidl-1.00/compiler/uniondecl.ml Mon Feb 22 10:59:56 1999 +++ camlidl-ext/compiler/uniondecl.ml Thu Mar 25 11:07:18 1999 @@ -78,7 +78,7 @@ fprintf oc "{\n"; let pc = divert_output() in increase_indent(); - let discr = new_c_variable (Type_int Int) in + let discr = new_c_variable Onstack (Type_int Int) in iprintf pc "%s = -1;\n" discr; (* keeps gcc happy *) union_ml_to_c ml_to_c pc false ud v (sprintf "(*%s)" c) discr; iprintf pc "return %s;\n" discr; diff -u -r -N camlidl-1.00/compiler/utils.ml camlidl-ext/compiler/utils.ml --- camlidl-1.00/compiler/utils.ml Mon Feb 22 10:59:56 1999 +++ camlidl-ext/compiler/utils.ml Tue Mar 23 14:52:37 1999 @@ -52,8 +52,8 @@ let n = input ic buffer 0 256 in if n > 0 then (output oc buffer 0 n; copy()) in copy(); - close_in ic; - remove_file !temp_file + close_in ic(*; + remove_file !temp_file*) (* Remember current module name and current function name *) diff -u -r -N camlidl-1.00/compiler/valist.ml camlidl-ext/compiler/valist.ml --- camlidl-1.00/compiler/valist.ml Thu Jan 1 01:00:00 1970 +++ camlidl-ext/compiler/valist.ml Fri Mar 26 17:54:54 1999 @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* CamlIDL *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* Handling of va_lists *) + +open Printf +open Utils +open Variables +open Idltypes +open Cvttyp + +let max_va_size = 8 diff -u -r -N camlidl-1.00/compiler/valist.mli camlidl-ext/compiler/valist.mli --- camlidl-1.00/compiler/valist.mli Thu Jan 1 01:00:00 1970 +++ camlidl-ext/compiler/valist.mli Fri Mar 26 18:52:11 1999 @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* CamlIDL *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* Handling of va_lists *) + +open Idltypes + +val max_va_size : int diff -u -r -N camlidl-1.00/compiler/variables.ml camlidl-ext/compiler/variables.ml --- camlidl-1.00/compiler/variables.ml Fri Feb 19 15:33:43 1999 +++ camlidl-ext/compiler/variables.ml Mon Mar 29 12:17:18 1999 @@ -18,21 +18,26 @@ (* Generate temporaries *) + (* Temporaries may be allooated on stack (this is the default for v1.00) + * or the heap (for ptrs of kind boxed). *) + +type alloc_kind = Onstack | Onheap + let var_counter = ref 0 -let temp_variables = ref([] : (string * idltype) list) +let temp_variables = ref([] : (string * idltype * alloc_kind) list) let new_var prefix = incr var_counter; prefix ^ string_of_int !var_counter -let new_c_variable ty = +let new_c_variable alloc ty = let name = new_var "_c" in - temp_variables := (name, ty) :: !temp_variables; + temp_variables := (name, ty, alloc) :: !temp_variables; name let new_ml_variable () = let name = new_var "_v" in - temp_variables := (name, Type_named("", "value")) :: !temp_variables; + temp_variables := (name, Type_named("", "value"), Onstack) :: !temp_variables; name let new_ml_variable_block n = @@ -41,12 +46,16 @@ Type_array({bound = Some(Expr_int n); size=None; length=None; is_string=false; null_terminated=false}, Type_named("", "value")) in - temp_variables := (name, ty) :: !temp_variables; + temp_variables := (name, ty, Onstack) :: !temp_variables; name let output_variable_declarations oc = List.iter - (fun name_ty -> iprintf oc "%a;\n" out_c_decl name_ty) + (function + (name,ty,Onstack) -> iprintf oc "%a;\n" out_c_decl (name,ty) + | (name,ty,Onheap) -> + iprintf oc "%a *%s = (%a *) stat_alloc(sizeof(%a));\n" + out_c_type ty name out_c_type ty out_c_type ty) (List.rev !temp_variables); temp_variables := []; var_counter := 0 @@ -80,6 +89,14 @@ decrease_indent(); iprintf oc "}\n" end + +let fill_array_boxed oc name sz ty_ptd_el = + let idx = new_var "_c" in + iprintf oc "{ int %s;\n" idx; + iprintf oc "for (%s = 0; %s < %s; %s++)\n %s[%s]=\ + (%a *) stat_alloc(sizeof(%a));\n" + idx idx sz idx name idx out_c_type ty_ptd_el out_c_type ty_ptd_el; + iprintf oc "}\n" (* Record if we need the context parameter *) diff -u -r -N camlidl-1.00/compiler/variables.mli camlidl-ext/compiler/variables.mli --- camlidl-1.00/compiler/variables.mli Fri Feb 19 15:33:43 1999 +++ camlidl-ext/compiler/variables.mli Mon Mar 29 12:10:49 1999 @@ -13,11 +13,15 @@ (* Generate temporaries *) +type alloc_kind = Onstack | Onheap + val new_var : string -> string -val new_c_variable : Idltypes.idltype -> string +val new_c_variable : alloc_kind -> Idltypes.idltype -> string val new_ml_variable : unit -> string val new_ml_variable_block : int -> string val output_variable_declarations : out_channel -> unit val init_value_block : out_channel -> string -> int -> unit val copy_values_to_block : out_channel -> string -> string -> int -> unit +val fill_array_boxed : + out_channel -> string -> string -> Idltypes.idltype -> unit val need_context : bool ref diff -u -r -N camlidl-1.00/config/Makefile camlidl-ext/config/Makefile --- camlidl-1.00/config/Makefile Thu Jan 1 01:00:00 1970 +++ camlidl-ext/config/Makefile Mon Mar 8 19:35:03 1999 @@ -0,0 +1,36 @@ +## Configuration section + +# Type of system -- do not change +OSTYPE=unix + +# How to invoke the C preprocessor +# Works on most Unix systems: +CPP=/lib/cpp +# Alternatives: +# CPP=cpp +# CPP=/usr/ccs/lib/cpp +# CPP=gcc -x c -E + +# How to invoke ranlib (only relevant for Unix) +RANLIB=ranlib +# If ranlib is not needed: +#RANLIB=: + +# Location of the Objective Caml library in your installation +OCAMLLIB=/usr/local/lib/ocaml + +# Where to install the binaries +BINDIR=/usr/local/bin + +# The Objective Caml compilers (the defaults below should be OK) +OCAMLC=ocamlc -g +OCAMLOPT=ocamlopt +OCAMLYACC=ocamlyacc -v +OCAMLLEX=ocamllex +OCAMLDEP=ocamldep + +# Extra flags to pass to the C compiler +CFLAGS=-g + +# Extension for lib files (do not change) +LIB=.a diff -u -r -N camlidl-1.00/doc/extensions.txt camlidl-ext/doc/extensions.txt --- camlidl-1.00/doc/extensions.txt Thu Jan 1 01:00:00 1970 +++ camlidl-ext/doc/extensions.txt Mon Mar 29 16:29:35 1999 @@ -0,0 +1,210 @@ +This patch introduces two extensions to CamlIDL. + + o a new pointer kind for handling finalized opaque pointers + o a (limited) mechanism for handling functions that accept variable argument + lists. + +A- A new attribute for handling finalized opaque pointers +--------------------------------------------------------- + +A new IDL attribute, [boxed], can be used for pointer types. + +Like pointers of kind [ptr], IDL pointers of kind [boxed] are mapped to +a Com.opaque type (i.e. no attempt will be made to convert it to an ML +data structure). +For example, if file "foo.idl" contains: + + typedef struct { + int x; + int y; + } point ; + + void print([in,boxed] point *s); + +the generated ML interface foo.mli will be: + + external print : point Com.opaque -> unit = "camlidl_foo_print" + +On the ML side, a pointer of kind [boxed] is represented as as +_finalized block_, ie a block with an attached C finalization function that +is called when the block becomes unreachable and is about to be reclaimed. + +Finalization is crucial for handling "opaque" pointers, i.e. pointers +to abstract data allocated in the C heap. +This situation naturally occurs when the return value for a given C function +must be allocated by the generated stub code. To illustrate this situation, +let's suppose that the file "foo.idl" contains the following function +declaration: + + void make([in] int x, [out,ptr] point *s); + +Here, the C function "make" is intended to take a pointer to an +(un-initialized) point structure and fill it with appropriate values. +The [ptr] attribute is specified to prevent the point structure to be exposed +on the ML side. With this specification, the stub code generated by camlidl-1.0 +looks like: + + value camlidl_foo_make( + value _v_x) + { + int x; /*in*/ + point *s; /*out*/ + point _c1; + value _vres; + + x = Int_val(_v_x); + s = &_c1; + make(x, s); + _vres = camlidl_alloc_small(1, Abstract_tag); + Field(_vres, 0) = (value) s; + return _vres; + } + +which shows that the result is, as requested, an abstract block only holding +a pointer to a C datum, but also that this encapsulated pointer actually +points to a _local_ variable of the stub code, so will become erroneous +as soon as the stub function exits. + +With the following specification: + + void make([in] int x, [out,boxed] point *s); + +the generated stub code will be: + + value camlidl_foo_make( + value _v_x) + { + int x; /*in*/ + point *s; /*out*/ + point *_c1 = (point *) stat_alloc(sizeof(point )); + value _vres; + + x = Int_val(_v_x); + s = _c1; + make(x, s); + _vres = camlidl_alloc_final(2, camlidl_finalize, 1, 1); + Field(_vres, 1) = (value) s; + return _vres; + } + +In this case, the C struct initialized by the make function is automatically +allocated and reclaimed by the ML GC (the reclamation rate can be adjusted +by modifying the last two parameters of the alloc_final function as +explained in the Caml manual - http://caml.inria.fr/ocaml/htmlman/node16.html). +This is very useful when the make function deals with large data types - ex +images - and is invoked repeatedly from an looping process. + +The finalization function generated in the stub code be customized by +providing a specific de-allocation function for the given type. This +is done by attaching an extra-parameter to the [boxed] attribute. For instance, +if the [boxed(finalize_point)] attribute is used in the previous specification, +the function [finalize_point] will be called by the GC when the corresponding +object become unreachable. The prototype of this function must be: + + void finalize_xxx(value v); + +The input parameter is a structured block, whose second cell contains the +(boxed) C pointer. A possible (but un-needed, in this case) definition of +finalize_point could therefore be: + + void finalize_point(value v) + { + point *p = (point *) Field(v, 1); + printf("Finalizing a point at address %p !\n", p); + free(p); + } + +Rq1: +--- + +The [boxed] attribute has been made valid for interface +declarations. So it is possible to write + + [pointer_default(boxed)] interface foo { ... } + +to make the above the default behaviour for an interface. + +Rq2: +--- + +It is possible to declare _arrays_ of [boxed] pointers by giving the +attribute [boxed] (or [boxed(finalize_fun)] to the array itself. +For instance + + void make([in] int x, [out,boxed] point *s[4]); + +will create a stub function [camlidl_xxx_make()] which, when called, +will + 1- allocate four fresh _point_ structs in the C heap + 2- pass to the C function [make] an array containing their addresses + 3- return an ML array of four finalized blocks, each block holding a ptr + to the allocated C struct. + +Note: this "transitive" application of the [boxed] attribute from an array type +to the type of its element is also valid for the valists described in the +next section + +B- Handling functions that accept variable argument lists. +---------------------------------------------------------- + +The mechanism presented here is very experimental, and is probably not +as useful as the previous one. So it just be quickly described. + +The idea is to map C variable argument lists to Caml arrays. +For instance, given the following C function + + #include + void print(int n, /* double */ ...) + { + va_list xs; + int i; + va_start(xs, n); + printf("["); + for ( i=0; i unit = "camlidl_foo_print" + +The main difference appears in the calling sequence of the generated stub code, +which must explicitely switch on the actual number of parameters, giving +something like: + + value camlidl_foo_print(value _v_xs) + { + int n; /*in*/ + double *xs; /*in*/ + mlsize_t _c1; + mlsize_t _c2; + _c1 = Wosize_val(_v_xs) / Double_wosize; + xs = camlidl_malloc(_c1 * sizeof(double ), _ctx); + for (_c2 = 0; _c2 < _c1; _c2++) { xs[_c2] = Double_field(_v_xs, _c2); } + switch ( _c1 ) { + case 1: print(1, xs[0]); + break; + case 2: print(2, xs[0], xs[1]); + break; + case 3: print(3, xs[0], xs[1], xs[2]); + break; + ... + } + return Val_unit; + } + +For this, function parameters passed as variable argument lists must be +declared as follows in the IDL file: + + void print([in] int n, [in,size_is(n)] double xs ...); + +Caveats: + +* It is not possible to handle va lists containing arguments of different types +* The size of the va list must appear as the parameter immediately preceding it +* Handling of null-terminated va lists is not supported. + +Please report bugs and comments to + Jocelyn.Serot@lasmea.univ-bpclermont.fr diff -u -r -N camlidl-1.00/other-tests/Makefile camlidl-ext/other-tests/Makefile --- camlidl-1.00/other-tests/Makefile Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/Makefile Mon Mar 29 15:58:54 1999 @@ -0,0 +1,57 @@ +CAMLC=ocamlc +CAMLOPT=ocamlopt +CAMLDEP=ocamldep +INCLUDES= +CAMLFLAGS=$(INCLUDES) -ccopt -g +CAMLOPTFLAGS=$(INCLUDES) +CAMLIDLFLAGS= +CAMLLIB=/usr/local/lib/ocaml +CAMLIDL=../compiler/camlidl +CC=gcc +CFLAGS=-I$(CAMLLIB) -g +EXTLIBS=../runtime/libcamlidl.a + +all: test_boxed test_boxed2 test_valist + +test_boxed: boxed_stubs.o boxed.o test_boxed.cmo + $(CAMLC) -custom -o test_boxed boxed_stubs.o boxed.o test_boxed.cmo $(EXTLIBS) + +test_boxed2: boxed2_stubs.o boxed2.o test_boxed2.cmo + $(CAMLC) -custom -o test_boxed2 boxed2_stubs.o boxed2.o test_boxed2.cmo $(EXTLIBS) + +test_valist: valist_stubs.o valist.o test_valist.cmo + $(CAMLC) -custom -o test_valist valist_stubs.o valist.o test_valist.cmo $(EXTLIBS) + +%_stubs.o: %.idl + $(CAMLIDL) $(CAMLIDLFLAGS) $*.idl + $(CAMLC) -c $*.mli + $(CAMLC) -c $*.ml + $(CC) $(CFLAGS) -c $*_stubs.c + +.SUFFIXES: +.SUFFIXES: .idl .c .o .ml .mli .cmo .cmi .cmx + +.c.o: + $(CC) $(CFLAGS) -c $< + +.ml.cmo: + $(CAMLC) $(CAMLFLAGS) -c $< + +.mli.cmi: + $(CAMLC) $(CAMLFLAGS) -c $< + +.ml.cmx: + $(CAMLOPT) $(CAMLOPTFLAGS) -c $< + +clean: + rm -f test_boxed test_boxed2 test_valist *.o + rm -f *.cm[iox] + +clobber: clean + rm -f *_stubs.c boxed.ml* boxed2.ml* valist.ml* + +# Dependencies +depend: + $(CAMLDEP) $(INCLUDES) *.mli *.ml > .depend + +#include .depend diff -u -r -N camlidl-1.00/other-tests/README camlidl-ext/other-tests/README --- camlidl-1.00/other-tests/README Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/README Mon Mar 29 16:33:46 1999 @@ -0,0 +1,6 @@ +* test_boxed: a small example showing how to declare and manipulate pointers + to finalized blocks pointers + +* test_boxed2: the same for _arrays_ of such pointers + +* test_valist: a very simple example with va lists diff -u -r -N camlidl-1.00/other-tests/boxed.c camlidl-ext/other-tests/boxed.c --- camlidl-1.00/other-tests/boxed.c Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/boxed.c Sat Mar 27 10:18:56 1999 @@ -0,0 +1,16 @@ +#include "boxed.h" + +void make(int x, point *s) { + s->x = x; + s->y = 0; + } + +void print(point *s) { + printf("X=%d Y=%d\n", s->x, s->y); + } + +void finalize_point(value v) { + point *p = (point *)Field(v, 1); + printf("Finalizing a point at address %p !\n", p); + free(p); + } diff -u -r -N camlidl-1.00/other-tests/boxed.h camlidl-ext/other-tests/boxed.h --- camlidl-1.00/other-tests/boxed.h Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/boxed.h Sat Mar 27 10:19:18 1999 @@ -0,0 +1,12 @@ +typedef struct { + int x; + int y; +} point; + +extern void make(/*in*/ int x, /*out*/ point *s); +extern void print(/*in*/ point *s); + +#include + +void finalize_point(value v); + diff -u -r -N camlidl-1.00/other-tests/boxed.idl camlidl-ext/other-tests/boxed.idl --- camlidl-1.00/other-tests/boxed.idl Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/boxed.idl Sat Mar 27 10:05:13 1999 @@ -0,0 +1,7 @@ +typedef [abstract,c2ml(unused),ml2c(unused)] struct { + int x; + int y; +} point ; + +void make([in] int x, [out,boxed(finalize_point)] point *s); +void print([in,boxed] point *s); diff -u -r -N camlidl-1.00/other-tests/boxed2.c camlidl-ext/other-tests/boxed2.c --- camlidl-1.00/other-tests/boxed2.c Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/boxed2.c Mon Mar 29 13:05:10 1999 @@ -0,0 +1,22 @@ +#include "boxed2.h" + +void make(int x, point *s[4]) { + int i; + for ( i=0; i<4; i++) { + s[i]->x = x; + s[i]->y = 0; + } + } + +void print(point *s[4]) { + int i; + for ( i=0; i<4; i++) + printf("X[%d]=%d Y[%d]=%d\n", i, s[i]->x, i, s[i]->y); + printf("\n"); + } + +void finalize_point(value v) { + point *p = (point *)Field(v, 1); + printf("Finalizing a point at address %p !\n", p); + free(p); + } diff -u -r -N camlidl-1.00/other-tests/boxed2.h camlidl-ext/other-tests/boxed2.h --- camlidl-1.00/other-tests/boxed2.h Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/boxed2.h Mon Mar 29 13:05:15 1999 @@ -0,0 +1,9 @@ +typedef struct { + int x; + int y; +} point; + +extern void make(/*in*/ int x, /*out*/ point *s[4]); +extern void print(/*in*/ point *s[4]); +#include +extern void finalize_point(value v); diff -u -r -N camlidl-1.00/other-tests/boxed2.idl camlidl-ext/other-tests/boxed2.idl --- camlidl-1.00/other-tests/boxed2.idl Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/boxed2.idl Mon Mar 29 13:03:22 1999 @@ -0,0 +1,10 @@ +typedef [abstract,c2ml(unused),ml2c(unused)] struct { + int x; + int y; +} point ; + +// The [boxed] attribute can also apply to _arrays_ to ptrs +// This means that _each_ cell of this points to an finalized block + +void make([in] int x, [out,boxed(finalize_point)] point *s[4]); +void print([in,boxed] point *s[4]); diff -u -r -N camlidl-1.00/other-tests/test_boxed.ml camlidl-ext/other-tests/test_boxed.ml --- camlidl-1.00/other-tests/test_boxed.ml Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/test_boxed.ml Sat Mar 27 10:20:12 1999 @@ -0,0 +1,5 @@ +open Boxed +let f i = + let p = make i in + print p +let _ = for i = 0 to 8 do f i done diff -u -r -N camlidl-1.00/other-tests/test_boxed2.ml camlidl-ext/other-tests/test_boxed2.ml --- camlidl-1.00/other-tests/test_boxed2.ml Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/test_boxed2.ml Mon Mar 29 13:07:48 1999 @@ -0,0 +1,5 @@ +open Boxed2 +let f i = + let p = make i in + print p +let _ = for i = 0 to 8 do f i done diff -u -r -N camlidl-1.00/other-tests/test_valist.ml camlidl-ext/other-tests/test_valist.ml --- camlidl-1.00/other-tests/test_valist.ml Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/test_valist.ml Sat Mar 27 10:21:30 1999 @@ -0,0 +1,8 @@ +open Valist +let f i = + let a = make 1.0 i in + let a' = update a in + print a' +let _ = for i = 1 to 9 do f i done +(* The last loop should cause an uncaught exception + Invalid_argument("valist too big") !.. *) diff -u -r -N camlidl-1.00/other-tests/valist.c camlidl-ext/other-tests/valist.c --- camlidl-1.00/other-tests/valist.c Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/valist.c Sat Mar 27 10:11:31 1999 @@ -0,0 +1,34 @@ +#include "valist.h" +#include + +void print(int n, /* double */ ...) +{ + va_list xs; + int i; + va_start(xs, n); + printf("["); + for ( i=0; i + +void make(double z, int n, /* double* */ ...); +void print(int n, /* double */ ...); +void update(int n, /* double* */ ...); diff -u -r -N camlidl-1.00/other-tests/valist.idl camlidl-ext/other-tests/valist.idl --- camlidl-1.00/other-tests/valist.idl Thu Jan 1 01:00:00 1970 +++ camlidl-ext/other-tests/valist.idl Sat Mar 27 10:11:43 1999 @@ -0,0 +1,14 @@ +void print([in] int n, [in,size_is(n)] double xs ...); +// +// Comes from: void print(int n, /* double */ ...); +// Should lead to: val print : float array -> unit + +void make([in] float z, [in] int n, [out,size_is(n)] double xs ...); +// +// Comes from: void make(double z, int n, /* double* */ ...); +// Should lead to: val make : float -> int -> float array + +void update([in] int n, [in,out,size_is(n)] double xs ...); +// +// Comes from: void update(int n, /* double* */ ...); +// Should lead to: val make : float array -> float array diff -u -r -N camlidl-1.00/runtime/camlidlruntime.h camlidl-ext/runtime/camlidlruntime.h --- camlidl-1.00/runtime/camlidlruntime.h Fri Feb 19 15:33:45 1999 +++ camlidl-ext/runtime/camlidlruntime.h Wed Mar 24 12:44:11 1999 @@ -21,6 +21,7 @@ #if !defined(CAMLVERSION) || CAMLVERSION >= 201 #define camlidl_alloc alloc #define camlidl_alloc_small alloc_small +#define camlidl_alloc_final alloc_final #else value camlidl_alloc(mlsize_t size, tag_t tag); #define camlidl_alloc_small alloc @@ -52,6 +53,8 @@ void * camlidl_malloc(size_t sz, camlidl_ctx ctx); void camlidl_free(camlidl_ctx ctx); char * camlidl_malloc_string(value mlstring, camlidl_ctx ctx); + +void camlidl_finalize(value _v); /* Helper functions for handling COM interfaces */ diff -u -r -N camlidl-1.00/runtime/idlalloc.c camlidl-ext/runtime/idlalloc.c --- camlidl-1.00/runtime/idlalloc.c Wed Feb 24 13:27:42 1999 +++ camlidl-ext/runtime/idlalloc.c Sat Mar 27 10:16:57 1999 @@ -104,6 +104,17 @@ return res; } +/* Default function for finalizing a block */ + +void camlidl_finalize(value _v) +{ +#ifdef CAMLIDL_DEBUG + fprintf(stdout, "*** camlidl_finalize !\n"); +#endif + stat_free((void *)Field(_v, 0)); +} + + /* This function is for compatibility with OCaml 2.00 and earlier */ #if defined(CAMLVERSION) && CAMLVERSION < 201 diff -u -r -N camlidl-1.00/tests/basics.c camlidl-ext/tests/basics.c --- camlidl-1.00/tests/basics.c Thu Jan 1 01:00:00 1970 +++ camlidl-ext/tests/basics.c Mon Mar 8 19:40:22 1999 @@ -0,0 +1,198 @@ +/* File generated from basics.idl */ + +#include +#include +#include +#include +#include +#include +#include +#include + + +#include "basics.h" + +value camlidl_basics_f1( + value _v_x) +{ + int x; /*in*/ + int _res; + value _vres; + + x = Int_val(_v_x); + _res = f1(x); + _vres = Val_int(_res); + return _vres; +} + +value camlidl_basics_f2( + value _v_x) +{ + long x; /*in*/ + unsigned long _res; + value _vres; + + x = Long_val(_v_x); + _res = f2(x); + _vres = Val_long(_res); + return _vres; +} + +value camlidl_basics_f3(value _unit) +{ + int *p; /*out*/ + int _c1; + value _vres; + + p = &_c1; + f3(p); + _vres = Val_int(*p); + return _vres; +} + +value camlidl_basics_f4( + value _v_p) +{ + int *p; /*in,out*/ + int _c1; + value _vres; + + p = &_c1; + _c1 = Int_val(_v_p); + f4(p); + _vres = Val_int(*p); + return _vres; +} + +value camlidl_basics_f5( + value _v_x) +{ + int x; /*in*/ + int *p; /*out*/ + int _res; + int _c1; + value _vresult; + value _vres[2] = { 0, 0, }; + + x = Int_val(_v_x); + p = &_c1; + _res = f5(x, p); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(_res); + _vres[1] = Val_int(*p); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + return _vresult; +} + +value camlidl_basics_f6( + value _v_x) +{ + int *x; /*in*/ + int *_res; + value _v1; + int _c2; + value _v3; + value _vres; + + if (_v_x == Val_int(0)) { + x = NULL; + } else { + _v1 = Field(_v_x, 0); + x = &_c2; + _c2 = Int_val(_v1); + } + _res = f6(x); + if (_res == NULL) { + _vres = Val_int(0); + } else { + _v3 = Val_int(*_res); + Begin_root(_v3) + _vres = camlidl_alloc_small(1, 0); + Field(_vres, 0) = _v3; + End_roots(); + } + return _vres; +} + +value camlidl_basics_f7( + value _v_x) +{ + int *x; /*in*/ + int *_res; + value _vres; + + x = (int *) Field(_v_x, 0); + _res = f7(x); + _vres = camlidl_alloc_small(1, Abstract_tag); + Field(_vres, 0) = (value) _res; + return _vres; +} + +value camlidl_basics_f8( + value _v_p, + value _v_q) +{ + int *p; /*in,out*/ + long *q; /*in,out*/ + int _c1; + long _c2; + value _vresult; + value _vres[2] = { 0, 0, }; + + p = &_c1; + _c1 = Int_val(_v_p); + q = &_c2; + _c2 = Long_val(_v_q); + f8(p, q); + Begin_roots_block(_vres, 2) + _vres[0] = Val_int(*p); + _vres[1] = Val_long(*q); + _vresult = camlidl_alloc_small(2, 0); + Field(_vresult, 0) = _vres[0]; + Field(_vresult, 1) = _vres[1]; + End_roots() + return _vresult; +} + +value camlidl_basics_f9( + value _v_i1, + value _v_i2, + value _v_i3, + value _v_i4, + value _v_i5, + value _v_i6, + value _v_i7, + value _v_i8) +{ + int i1; /*in*/ + int i2; /*in*/ + int i3; /*in*/ + int i4; /*in*/ + int i5; /*in*/ + int i6; /*in*/ + int i7; /*in*/ + int i8; /*in*/ + int _res; + value _vres; + + i1 = Int_val(_v_i1); + i2 = Int_val(_v_i2); + i3 = Int_val(_v_i3); + i4 = Int_val(_v_i4); + i5 = Int_val(_v_i5); + i6 = Int_val(_v_i6); + i7 = Int_val(_v_i7); + i8 = Int_val(_v_i8); + _res = f9(i1, i2, i3, i4, i5, i6, i7, i8); + _vres = Val_int(_res); + return _vres; +} + +value camlidl_basics_f9_bytecode(value * argv, int argn) +{ + return camlidl_basics_f9(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7]); +} + diff -u -r -N camlidl-1.00/tests/boxed.c camlidl-ext/tests/boxed.c --- camlidl-1.00/tests/boxed.c Thu Jan 1 01:00:00 1970 +++ camlidl-ext/tests/boxed.c Sat Mar 27 09:58:03 1999 @@ -0,0 +1,18 @@ +#include "foo.h" + +void make(int x, point *s) { + s->x = x; + s->y = 0; + } + +void print(point *s) { + printf("X=%d Y=%d\n", s->x, s->y); + } + +#include + +void finalize_point(value v) { + point *p = (point *)Field(v, 1); + printf("Finalizing a point at address %p !\n", p); + free(p); + } diff -u -r -N camlidl-1.00/tests/boxed.h camlidl-ext/tests/boxed.h --- camlidl-1.00/tests/boxed.h Thu Jan 1 01:00:00 1970 +++ camlidl-ext/tests/boxed.h Sat Mar 27 09:57:48 1999 @@ -0,0 +1,8 @@ +typedef struct { + int x; + int y; +} point; + +extern void make(/*in*/ int x, /*out*/ point *s); + +extern void print(/*in*/ point *s); diff -u -r -N camlidl-1.00/tests/boxed.idl camlidl-ext/tests/boxed.idl --- camlidl-1.00/tests/boxed.idl Thu Jan 1 01:00:00 1970 +++ camlidl-ext/tests/boxed.idl Sat Mar 27 09:57:28 1999 @@ -0,0 +1,7 @@ +typedef [abstract,c2ml(unused),ml2c(unused)] struct { + int x; + int y; +} point ; + +void make([in] int x, [out,boxed(finalize_point)] point *s); +void print([in,boxed] point *s); diff -u -r -N camlidl-1.00/tests/structs.idl camlidl-ext/tests/structs.idl --- camlidl-1.00/tests/structs.idl Tue Feb 16 19:35:57 1999 +++ camlidl-ext/tests/structs.idl Wed Mar 10 10:08:23 1999 @@ -49,3 +49,15 @@ [unique] struct s6 * data; }; +// Opaque structures + +typedef [abstract] struct s7 { + int x; + double d; + float f; + long l[3]; +} t7; + +int foo8([in,ptr] struct s1 * s); // Ok +void foo9([in] int x, [out,ptr] struct s1 * s); +//int foo10([in] struct s7 * s);