pax_global_header00006660000000000000000000000064136617626110014523gustar00rootroot0000000000000052 comment=b192760875fe6e97b13004bd289720618e12ee22 camlidl-camlidl109/000077500000000000000000000000001366176261100143315ustar00rootroot00000000000000camlidl-camlidl109/.cvsignore000066400000000000000000000000051366176261100163240ustar00rootroot00000000000000caml camlidl-camlidl109/.gitignore000066400000000000000000000003341366176261100163210ustar00rootroot00000000000000*.cm[ioxa] *.cmx[as] *.[oa] *.so *.annot config/Makefile /compiler/camlidl /compiler/config.ml /compiler/lexer_midl.ml /compiler/linenum.ml /compiler/parser_midl.ml /compiler/parser_midl.mli /compiler/parser_midl.output camlidl-camlidl109/Changes000066400000000000000000000100741366176261100156260ustar00rootroot00000000000000CamlIDL 1.09: ------------- * Revert a problematic change of default configuration (cpp -traditional instead of cpp) CamlIDL 1.08: ------------- * Update to OCaml 4.09 and up * Support more IDL features: import lists, fixed-width integer types (int8, int32, etc), MIDL-stlye nonencapsulatedu unions (pull request #13, Philipp Gesang) * Generate C code that respects CAML_NAME_SPACE * The runtime library referenced a IID_IUnknown symbol that could not be resolved under Unix (pull request #15, Github user ygrek) CamlIDL 1.07: ------------- * Update to OCaml 4.06 and up (issues #6 and #11). * Auto-link the C runtime library from com.cma and com.cmxa (issue #8). * Re-license the compiler under the LGPL v2.1 (instead of the QPL 1.0). CamlIDL 1.06: ------------- * Update to OCaml 4.03. * Avoid name clash on Array module. 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: ------------- * Fixed silly bug in abstract typedefs, introduced in 1.03. * Strings, arrays and bigarrays are now non-NULL if "unique" is not specified, even if the pointer default is "unique". * "out" parameters dependent on "out" parameters are now removed from the Caml view of a function. * Removed spurious warning on the "mlname" attribute. CamlIDL 1.03: ------------- * Revised handling of integer constants, which can now be of Caml boxed int types (int32, int64, nativeint). * Dependent fields can now reference all variables that are in lexical scope, e.g. struct { int n; struct { [size_is(x)] int * n; } s; } * The C file generated from x.idl is now named x_stubs.c rather than x.c to avoid a name clash on file x.o when compiling x.ml to native code. * Added [finalize(fn)], [compare(fn)] and [hash(fn)] on abstract typedefs to associate user-provided finalization, comparison or hashing functions to typedefs. * Fixed some oddities with the "const" qualifier. CamlIDL 1.02: ------------- * Added support for the "long long", "hyper int" and "__int64" types (64-bit C integers) * Added support for "const" modifier on pointer types * Support for [unique] attribute on big arrays, turned into option types in the Caml interface * Generated C code should now compile cleanly with a C++ compiler * Print source location for most warnings * Error location was sometimes way off; this is now fixed * Fixed incorrect code generated for the types HRESULT_int and HRESULT_bool * Fixed refcount management bug causing early deallocation of interfaces implemented in Caml. CamlIDL 1.01: ------------- * Added support for Caml boxed int types (int32, int64, nativeint) and for big arrays (module Bigarray) * Fixed bug in allocation of working space for out parameters of array types. * Disambiguation of record labels that belong to several struct types. * Support for [unique] attribute on strings and arrays, turned into option types in the Caml interface. * Fixed bug with anonymous enum types (forgot to define the corresponding translation table). * Fixed bug with dependent parameters depending on out parameters (these must not be omitted in the Caml function declaration). * "in,out" parameters of type string or big array are now presented as an "in,out" parameter of the Caml function and modified in place, rather than presented as a parameter and a result. * Added minimal support for COM dispatch interfaces. * Fixed lack of initialization of ignored pointers for structs with only one significant field. * Relicensed under the QPL (for the compiler) and the LGPL (for everything else). CamlIDL 1.00: ------------- First public release. camlidl-camlidl109/LICENSE000066400000000000000000000650241366176261100153450ustar00rootroot00000000000000In the following, "the CamlIDL System" refers to all files marked "Copyright INRIA" in this distribution. The CamlIDL System is distributed under the terms of the GNU Lesser General Public License (LGPL) version 2.1 (included below). As a special exception to the GNU Lesser General Public License, you may link, statically or dynamically, a "work that uses the CamlIDL System" with a publicly distributed version of the CamlIDL System to produce an executable file containing portions of the CamlIDL System, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Lesser General Public License. By "a publicly distributed version of the CamlIDL System", we mean either the unmodified CamlIDL System as distributed by INRIA, or a modified version of the CamlIDL System that is distributed under the conditions defined in clause 2 of the GNU Lesser General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Lesser General Public License. ---------------------------------------------------------------------- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. one line to give the library's name and an idea of what it does. Copyright (C) year name of author This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. signature of Ty Coon, 1 April 1990 Ty Coon, President of Vice That's all there is to it! -------------------------------------------------- camlidl-camlidl109/Makefile000066400000000000000000000024701366176261100157740ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile,v 1.18 2000-08-19 11:04:55 xleroy Exp $ include config/Makefile all: cd compiler; $(MAKE) all cd runtime; $(MAKE) all cd lib; $(MAKE) all cd tools; $(MAKE) all install: cd compiler; $(MAKE) install cd runtime; $(MAKE) install cd lib; $(MAKE) install cd tools; $(MAKE) install clean: cd compiler; $(MAKE) clean cd runtime; $(MAKE) clean cd lib; $(MAKE) clean cd tools; $(MAKE) clean depend: cd compiler; $(MAKE) depend cd runtime; $(MAKE) depend cd lib; $(MAKE) depend cd tools; $(MAKE) depend camlidl-camlidl109/README000066400000000000000000000034371366176261100152200ustar00rootroot00000000000000OVERVIEW: 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 Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the conditions stated in file LICENSE. For members of the Caml Consortium, the special Consortium license applies to this distribution. REQUIREMENTS: Camlidl requires Objective Caml 4.03 or later. Under MS Windows, you must use the MSVC port of Objective Caml. INSTALLATION: - Under Unix, copy config/Makefile.unix 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 BINDIR variable to say where to install the camlidl executable. 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 PDF. - Several examples are provided in the directories tests/ and tests/comp/. SUPPORT: - Please use the Github bug tracker and pull request manager at http://www.github.com/xavierleroy/camlidl camlidl-camlidl109/compiler/000077500000000000000000000000001366176261100161435ustar00rootroot00000000000000camlidl-camlidl109/compiler/.cvsignore000066400000000000000000000001351366176261100201420ustar00rootroot00000000000000camlidl config.ml parser_midl.output parser_midl.ml parser_midl.mli lexer_midl.ml linenum.ml camlidl-camlidl109/compiler/.depend000066400000000000000000000135721366176261100174130ustar00rootroot00000000000000config.cmi : constdecl.cmi : idltypes.cmi cvttyp.cmi : idltypes.cmi cvtval.cmi : prefix.cmi idltypes.cmi enum.cmi : prefix.cmi idltypes.cmi enumdecl.cmi : idltypes.cmi file.cmi : typedef.cmi intf.cmi idltypes.cmi funct.cmi constdecl.cmi fixlabels.cmi : file.cmi funct.cmi : idltypes.cmi idlarray.cmi : prefix.cmi idltypes.cmi idltypes.cmi : intf.cmi : idltypes.cmi funct.cmi lexer_midl.cmi : parser_midl.cmi lexer_simple.cmi : lexpr.cmi : prefix.cmi idltypes.cmi linenum.cmi : normalize.cmi : file.cmi parse.cmi : file.cmi parse_aux.cmi : typedef.cmi idltypes.cmi funct.cmi file.cmi constdecl.cmi parser_midl.cmi : file.cmi predef.cmi : typedef.cmi intf.cmi prefix.cmi : idltypes.cmi struct.cmi : prefix.cmi idltypes.cmi structdecl.cmi : idltypes.cmi typedef.cmi : idltypes.cmi union.cmi : prefix.cmi idltypes.cmi uniondecl.cmi : idltypes.cmi utils.cmi : variables.cmi : idltypes.cmi clflags.cmo : config.cmi clflags.cmx : config.cmx config.cmo : config.cmi config.cmx : config.cmi constdecl.cmo : utils.cmi prefix.cmi lexpr.cmi idltypes.cmi cvttyp.cmi \ constdecl.cmi constdecl.cmx : utils.cmx prefix.cmx lexpr.cmx idltypes.cmi cvttyp.cmx \ constdecl.cmi cvttyp.cmo : utils.cmi prefix.cmi lexpr.cmi idltypes.cmi config.cmi \ cvttyp.cmi cvttyp.cmx : utils.cmx prefix.cmx lexpr.cmx idltypes.cmi config.cmx \ cvttyp.cmi cvtval.cmo : variables.cmi utils.cmi union.cmi struct.cmi lexpr.cmi \ idltypes.cmi idlarray.cmi enum.cmi cvttyp.cmi cvtval.cmi cvtval.cmx : variables.cmx utils.cmx union.cmx struct.cmx lexpr.cmx \ idltypes.cmi idlarray.cmx enum.cmx cvttyp.cmx cvtval.cmi enum.cmo : variables.cmi utils.cmi idltypes.cmi enum.cmi enum.cmx : variables.cmx utils.cmx idltypes.cmi enum.cmi enumdecl.cmo : variables.cmi utils.cmi idltypes.cmi enum.cmi cvtval.cmi \ cvttyp.cmi enumdecl.cmi enumdecl.cmx : variables.cmx utils.cmx idltypes.cmi enum.cmx cvtval.cmx \ cvttyp.cmx enumdecl.cmi file.cmo : utils.cmi uniondecl.cmi typedef.cmi structdecl.cmi intf.cmi \ idltypes.cmi funct.cmi enumdecl.cmi constdecl.cmi clflags.cmo file.cmi file.cmx : utils.cmx uniondecl.cmx typedef.cmx structdecl.cmx intf.cmx \ idltypes.cmi funct.cmx enumdecl.cmx constdecl.cmx clflags.cmx file.cmi fixlabels.cmo : utils.cmi typedef.cmi intf.cmi idltypes.cmi funct.cmi \ file.cmi clflags.cmo fixlabels.cmi fixlabels.cmx : utils.cmx typedef.cmx intf.cmx idltypes.cmi funct.cmx \ file.cmx clflags.cmx fixlabels.cmi funct.cmo : variables.cmi utils.cmi typedef.cmi prefix.cmi lexpr.cmi \ idltypes.cmi cvtval.cmi cvttyp.cmi funct.cmi funct.cmx : variables.cmx utils.cmx typedef.cmx prefix.cmx lexpr.cmx \ idltypes.cmi cvtval.cmx cvttyp.cmx funct.cmi idlarray.cmo : variables.cmi utils.cmi lexpr.cmi idltypes.cmi cvttyp.cmi \ idlarray.cmi idlarray.cmx : variables.cmx utils.cmx lexpr.cmx idltypes.cmi cvttyp.cmx \ idlarray.cmi intf.cmo : variables.cmi utils.cmi prefix.cmi idltypes.cmi funct.cmi \ cvtval.cmi cvttyp.cmi intf.cmi intf.cmx : variables.cmx utils.cmx prefix.cmx idltypes.cmi funct.cmx \ cvtval.cmx cvttyp.cmx intf.cmi lexer_midl.cmo : utils.cmi parser_midl.cmi parse_aux.cmi lexer_midl.cmi lexer_midl.cmx : utils.cmx parser_midl.cmx parse_aux.cmx lexer_midl.cmi lexpr.cmo : utils.cmi prefix.cmi idltypes.cmi config.cmi lexpr.cmi lexpr.cmx : utils.cmx prefix.cmx idltypes.cmi config.cmx lexpr.cmi linenum.cmo : linenum.cmi linenum.cmx : linenum.cmi main.cmo : utils.cmi normalize.cmi idltypes.cmi file.cmi clflags.cmo main.cmx : utils.cmx normalize.cmx idltypes.cmi file.cmx clflags.cmx normalize.cmo : utils.cmi typedef.cmi predef.cmi parse.cmi lexpr.cmi \ intf.cmi idltypes.cmi funct.cmi fixlabels.cmi file.cmi constdecl.cmi \ normalize.cmi normalize.cmx : utils.cmx typedef.cmx predef.cmx parse.cmx lexpr.cmx \ intf.cmx idltypes.cmi funct.cmx fixlabels.cmx file.cmx constdecl.cmx \ normalize.cmi parse.cmo : utils.cmi parser_midl.cmi parse_aux.cmi linenum.cmi \ lexer_midl.cmi clflags.cmo parse.cmi parse.cmx : utils.cmx parser_midl.cmx parse_aux.cmx linenum.cmx \ lexer_midl.cmx clflags.cmx parse.cmi parse_aux.cmo : typedef.cmi predef.cmi linenum.cmi intf.cmi idltypes.cmi \ funct.cmi file.cmi cvttyp.cmi constdecl.cmi parse_aux.cmi parse_aux.cmx : typedef.cmx predef.cmx linenum.cmx intf.cmx idltypes.cmi \ funct.cmx file.cmx cvttyp.cmx constdecl.cmx parse_aux.cmi parser_midl.cmo : typedef.cmi parse_aux.cmi intf.cmi idltypes.cmi funct.cmi \ file.cmi cvttyp.cmi constdecl.cmi parser_midl.cmi parser_midl.cmx : typedef.cmx parse_aux.cmx intf.cmx idltypes.cmi funct.cmx \ file.cmx cvttyp.cmx constdecl.cmx parser_midl.cmi predef.cmo : typedef.cmi intf.cmi idltypes.cmi predef.cmi predef.cmx : typedef.cmx intf.cmx idltypes.cmi predef.cmi prefix.cmo : utils.cmi idltypes.cmi prefix.cmi prefix.cmx : utils.cmx idltypes.cmi prefix.cmi struct.cmo : variables.cmi utils.cmi prefix.cmi lexpr.cmi idltypes.cmi \ cvttyp.cmi struct.cmi struct.cmx : variables.cmx utils.cmx prefix.cmx lexpr.cmx idltypes.cmi \ cvttyp.cmx struct.cmi structdecl.cmo : variables.cmi utils.cmi struct.cmi prefix.cmi idltypes.cmi \ cvtval.cmi cvttyp.cmi structdecl.cmi structdecl.cmx : variables.cmx utils.cmx struct.cmx prefix.cmx idltypes.cmi \ cvtval.cmx cvttyp.cmx structdecl.cmi typedef.cmo : variables.cmi utils.cmi prefix.cmi idltypes.cmi cvtval.cmi \ cvttyp.cmi typedef.cmi typedef.cmx : variables.cmx utils.cmx prefix.cmx idltypes.cmi cvtval.cmx \ cvttyp.cmx typedef.cmi union.cmo : variables.cmi utils.cmi idltypes.cmi cvttyp.cmi union.cmi union.cmx : variables.cmx utils.cmx idltypes.cmi cvttyp.cmx union.cmi uniondecl.cmo : variables.cmi utils.cmi union.cmi prefix.cmi idltypes.cmi \ cvtval.cmi cvttyp.cmi uniondecl.cmi uniondecl.cmx : variables.cmx utils.cmx union.cmx prefix.cmx idltypes.cmi \ cvtval.cmx cvttyp.cmx uniondecl.cmi utils.cmo : utils.cmi utils.cmx : utils.cmi variables.cmo : utils.cmi idltypes.cmi cvttyp.cmi variables.cmi variables.cmx : utils.cmx idltypes.cmi cvttyp.cmx variables.cmi camlidl-camlidl109/compiler/Makefile000066400000000000000000000043451366176261100176110ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile,v 1.6 2002-01-16 09:42:00 xleroy Exp $ include ../config/Makefile OBJS=config.cmo utils.cmo clflags.cmo \ prefix.cmo lexpr.cmo cvttyp.cmo variables.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 \ file.cmo predef.cmo \ linenum.cmo parse_aux.cmo parser_midl.cmo lexer_midl.cmo parse.cmo \ fixlabels.cmo normalize.cmo \ main.cmo PROG=camlidl$(EXE) all: $(PROG) $(PROG): $(OBJS) $(OCAMLC) -o $(PROG) $(OBJS) clean:: rm -f $(PROG) parser_midl.ml parser_midl.mli: parser_midl.mly $(OCAMLYACC) parser_midl.mly clean:: rm -f parser_midl.ml parser_midl.mli parser_midl.output beforedepend:: parser_midl.ml parser_midl.mli lexer_midl.ml: lexer_midl.mll $(OCAMLLEX) lexer_midl.mll clean:: rm -f lexer_midl.ml beforedepend:: lexer_midl.ml config.ml: config.mlp ../config/Makefile -rm -f config.ml sed -e 's|%%CPP%%|$(CPP)|' \ config.mlp > config.ml -chmod -w config.ml clean:: rm -f config.ml beforedepend:: config.ml linenum.ml: linenum.mll $(OCAMLLEX) linenum.mll clean:: rm -f linenum.ml beforedepend:: linenum.ml .SUFFIXES: .ml .mli .cmo .cmi .cmx .ml.cmo: $(OCAMLC) -c $< .mli.cmi: $(OCAMLC) -c $< .ml.cmx: $(OCAMLOPT) -c $< # Install install: cp $(PROG) $(BINDIR) # Clean up clean:: rm -f *.cm[iox] *~ # Dependencies depend: beforedepend $(OCAMLDEP) *.mli *.ml > .depend include .depend camlidl-camlidl109/compiler/clflags.ml000066400000000000000000000024501366176261100201110ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: clflags.ml,v 1.5 2000-08-19 11:04:56 xleroy Exp $ *) (* Command-line flags *) let search_path = ref [Filename.current_dir_name] (* -I *) let include_header = ref true (* -no-include *) let gen_header = ref false (* -make-header *) let prepro_defines = ref ["CAMLIDL"] (* -D *) let use_cpp = ref true (* -cpp / -nocpp *) let preprocessor = ref Config.cpp (* -prepro *) let prefix_all_labels = ref false (* -prefix-all-labels *) let keep_labels = ref false (* -keep-labels *) camlidl-camlidl109/compiler/config.mli000066400000000000000000000020601366176261100201110ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: config.mli,v 1.4 2001-06-29 13:29:59 xleroy Exp $ *) (* Compile-time configuration *) (* How to invoke the C preprocessor *) val cpp: string (* The C names for 64-bit signed and unsigned integers *) val int64_type: string val uint64_type: string camlidl-camlidl109/compiler/config.mlp000066400000000000000000000021271366176261100201240ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: config.mlp,v 1.3 2001-06-29 13:29:59 xleroy Exp $ *) (* Compile-time configuration *) (* How to invoke the C preprocessor *) let cpp = "%%CPP%%" (* The C names for 64-bit signed and unsigned integers *) let (int64_type, uint64_type) = match Sys.os_type with "Win32" -> ("__int64", "unsigned __int64") | _ -> ("long long", "unsigned long long") camlidl-camlidl109/compiler/constdecl.ml000066400000000000000000000056501366176261100204610ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: constdecl.ml,v 1.14 2002-01-16 16:15:30 xleroy Exp $ *) (* Handling of constant declarations *) open Printf open Utils open Idltypes open Lexpr open Cvttyp type constant_decl = { cd_name: string; cd_type: idltype; cd_value: lexpr } (* Record the value of a constant declaration *) let record c = Lexpr.bind_const c.cd_name (cast_value c.cd_type (eval c.cd_value)) (* Declare the constant in ML *) let ml_declaration oc c = fprintf oc "val %s : " (String.uncapitalize_ascii c.cd_name); match scrape_type c.cd_type with Type_int(_, _) -> fprintf oc "%a\n" out_ml_type c.cd_type | Type_pointer(_, Type_int((Char | UChar | SChar), _)) | Type_array({is_string = true}, _) -> fprintf oc "string\n" | _ -> error "unsupported type for constant expression" (* #define the constant in C *) let c_declaration oc c = fprintf oc "#define %s (%a)\n\n" c.cd_name Lexpr.output (Prefix.empty, c.cd_value) (* Generate the ML let binding corresponding to the constant declaration *) let ml_definition oc c = let v = eval c.cd_value in let name = String.uncapitalize_ascii c.cd_name in match scrape_type c.cd_type with Type_int((Char | UChar | SChar), _) -> fprintf oc "let %s = '%s'\n\n" name (Char.escaped (Char.chr ((int_val v) land 0xFF))) | Type_int(Boolean, _) -> fprintf oc "let %s = %s\n\n" name (if is_true v then "true" else "false") | Type_int(_, Iunboxed) -> fprintf oc "let %s = %d\n\n" name (int_val v) | Type_int(_, Inative) -> fprintf oc "let %s = Nativeint.of_string \"%nd\"\n\n" name (nativeint_val v) | Type_int(_, I32) -> fprintf oc "let %s = Int32.of_string \"%ld\"\n\n" name (int32_val v) | Type_int(_, I64) -> fprintf oc "let %s = Int64.of_string \"%Ld\"\n\n" name (int64_val v) | Type_pointer(_, Type_int((Char | UChar | SChar), _)) | Type_array({is_string = true}, _) -> fprintf oc "let %s = \"%s\"\n\n" name (String.escaped (string_val v)) | _ -> error "unsupported type for constant expression" camlidl-camlidl109/compiler/constdecl.mli000066400000000000000000000023021366176261100206210ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: constdecl.mli,v 1.8 2000-08-19 11:04:56 xleroy Exp $ *) (* Handling of constant declarations *) open Idltypes type constant_decl = { cd_name: string; cd_type: idltype; cd_value: lexpr } val ml_declaration: out_channel -> constant_decl -> unit val c_declaration: out_channel -> constant_decl -> unit val ml_definition: out_channel -> constant_decl -> unit val record: constant_decl -> unit camlidl-camlidl109/compiler/cvttyp.ml000066400000000000000000000173071366176261100200360ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: cvttyp.ml,v 1.27 2004-07-08 11:24:43 xleroy Exp $ *) open Utils open Printf open Idltypes (* Convert an IDL type to a C declarator *) let integer_type = function Int -> "int" | Long -> "long" | Hyper -> Config.int64_type | Small -> "signed char" | Short -> "short" | Char -> "char" | UInt -> "unsigned int" | ULong -> "unsigned long" | UHyper -> Config.uint64_type | USmall -> "unsigned char" | UShort -> "unsigned short" | UChar -> "unsigned char" | SChar -> "signed char" | Byte -> "unsigned char" | Boolean -> "int" let parenthesize_if_pointer id = if String.length id > 0 && id.[0] = '*' then "(" ^ id ^ ")" else id let rec out_c_decl oc (id, ty) = match ty with Type_int(kind, repr) -> fprintf oc "%s %s" (integer_type kind) id | Type_float -> fprintf oc "float %s" id | Type_double -> fprintf oc "double %s" id | Type_void -> fprintf oc "void %s" id | Type_struct sd -> if sd.sd_name <> "" then fprintf oc "struct %s %s" sd.sd_name id else fprintf oc "%a %s" out_struct sd id | Type_union(ud, discr) -> if ud.ud_name <> "" then fprintf oc "union %s %s" ud.ud_name id else fprintf oc "%a %s" out_union ud id | Type_enum (en, attr) -> if en.en_name <> "" then fprintf oc "int %s" id else fprintf oc "%a %s" out_enum en id | Type_named(modl, ty_name) -> fprintf oc "%s %s" ty_name id | Type_pointer(attr, ty) -> out_c_decl oc (sprintf "*%s" id, ty) | Type_array(attr, ty) -> let id' = match attr.bound with Some n -> sprintf "%s[%d]" (parenthesize_if_pointer id) (Lexpr.eval_int n) | None -> sprintf "*%s" id in out_c_decl oc (id', ty) | Type_bigarray(attr, ty) -> out_c_decl oc (sprintf "*%s" id, ty) | Type_interface(modl, intf_name) -> fprintf oc "struct %s %s" intf_name id | Type_const ty' -> out_c_decl oc (sprintf "const %s" id, ty') and out_struct oc sd = fprintf oc "struct "; if sd.sd_name <> "" then fprintf oc "%s " sd.sd_name; fprintf oc "{\n"; increase_indent(); List.iter (out_field oc) sd.sd_fields; decrease_indent(); iprintf oc "}" and out_field oc f = iprintf oc "%a;\n" out_c_decl (f.field_name, f.field_typ) and out_union oc ud = fprintf oc "union "; if ud.ud_name <> "" then fprintf oc "%s " ud.ud_name; fprintf oc "{\n"; increase_indent(); List.iter (out_case oc) ud.ud_cases; decrease_indent(); iprintf oc "}" and out_case oc c = match c.case_field with None -> () | Some f -> out_field oc f and out_enum oc en = fprintf oc "enum "; if en.en_name <> "" then fprintf oc "%s " en.en_name; fprintf oc "{\n"; increase_indent(); List.iter (out_enum_const oc) en.en_consts; decrease_indent(); iprintf oc "}" and out_enum_const oc cst = fprintf oc "%s" cst.const_name; begin match cst.const_val with None -> () | Some le -> fprintf oc " = %a" Lexpr.output (Prefix.empty, le) end; fprintf oc ",\n" (* Convert an IDL type to a C type *) let out_c_type oc ty = out_c_decl oc ("", ty) (* Print an ML type name, qualified if necessary *) let out_mltype_name oc (modl, name) = if modl <> !module_name then fprintf oc "%s." (String.capitalize_ascii modl); output_string oc (String.uncapitalize_ascii name) (* Same, but use stamp if no name is provided *) let out_mltype_stamp oc kind modl name stamp = if modl <> !module_name then fprintf oc "%s." (String.capitalize_ascii modl); if name = "" then fprintf oc "%s_%d" kind stamp else output_string oc (String.uncapitalize_ascii name) (* Convert an IDL type to an ML bigarray element type *) 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" | Type_int(Short, _) -> "Bigarray.int16_signed_elt" | Type_int(UShort, _) -> "Bigarray.int16_unsigned_elt" | Type_int((Int | UInt), _) -> "Bigarray.int32_elt" | Type_int((Long | ULong), I64) -> "Bigarray.int64_elt" | Type_int((Long | ULong), _) -> "Bigarray.nativeint_elt" | 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 *) let rec out_ml_type oc ty = match ty with Type_int(Boolean, _) -> output_string oc "bool" | Type_int((Char | UChar | SChar), _) -> output_string oc "char" | Type_int(_, Iunboxed) -> output_string oc "int" | Type_int(_, Inative) -> output_string oc "nativeint" | Type_int(_, I32) -> output_string oc "int32" | Type_int(_, I64) -> output_string oc "int64" | Type_float | Type_double -> output_string oc "float" | Type_void -> output_string oc "void" | Type_named(modl, name) -> out_mltype_name oc (modl, name) | Type_struct sd -> out_mltype_stamp oc "struct" sd.sd_mod sd.sd_name sd.sd_stamp | Type_union(ud, discr) -> out_mltype_stamp oc "union" ud.ud_mod ud.ud_name ud.ud_stamp | Type_enum (en, attr) -> out_mltype_stamp oc "enum" en.en_mod en.en_name en.en_stamp; if attr.bitset then fprintf oc " list" | Type_pointer(kind, ty) -> begin match kind with 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 | 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; if attr.maybe_null then fprintf oc " option" | Type_bigarray(attr, ty) -> let layout = if attr.fortran_layout then "Bigarray.fortran_layout" else "Bigarray.c_layout" in let typeconstr = match List.length attr.dims with 1 -> "Bigarray.Array1.t" | 2 -> "Bigarray.Array2.t" | 3 -> "Bigarray.Array3.t" | _ -> "Bigarray.Genarray.t" in fprintf oc "(%a, %s, %s) %s" out_ml_type ty (ml_bigarray_kind ty) layout typeconstr; if attr.bigarray_maybe_null then fprintf oc " option" | Type_interface(modl, name) -> fprintf oc "%a Com.interface" out_mltype_name (modl, name) | Type_const ty' -> out_ml_type oc ty' (* Output a list of ML types *) let out_ml_types oc sep types = match types with [] -> fprintf oc "unit" | (_, ty1) :: tyl -> out_ml_type oc ty1; List.iter (fun (_, ty) -> fprintf oc " %s " sep; out_ml_type oc ty) tyl (* Expand typedef and const in type *) let rec scrape_type = function Type_named(modname, tyname) -> scrape_type (!Lexpr.expand_typedef tyname) | Type_const ty -> scrape_type ty | ty -> ty (* Remove leading "const" from a type *) let rec scrape_const = function Type_const ty -> scrape_const ty | ty -> ty (* Determine if a type is an ignored pointer *) let rec is_ignored = function Type_pointer(Ignore, _) -> true | Type_const ty -> is_ignored ty | _ -> false camlidl-camlidl109/compiler/cvttyp.mli000066400000000000000000000034641366176261100202060ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: cvttyp.mli,v 1.12 2002-01-16 16:15:31 xleroy Exp $ *) open Idltypes (* Convert an IDL type to a C declarator *) val out_c_decl : out_channel -> string * idltype -> unit (* Convert an IDL type to a C type *) val out_c_type : out_channel -> idltype -> unit (* Print C declarations for structs, unions, enums *) val out_struct : out_channel -> struct_decl -> unit val out_union : out_channel -> union_decl -> unit val out_enum : out_channel -> enum_decl -> unit (* Convert an IDL type to an ML type *) val out_ml_type: out_channel -> idltype -> unit (* Convert a list of IDL types to an ML type *) val out_ml_types: out_channel -> string -> ('a * idltype) list -> unit (* Print an ML type name, qualified if necessary *) val out_mltype_name: out_channel -> string * string -> unit (* Expand typedef and const in type *) val scrape_type: idltype -> idltype (* Remove leading "const" from a type *) val scrape_const: idltype -> idltype (* Determine if a type is an ignored pointer *) val is_ignored: idltype -> bool camlidl-camlidl109/compiler/cvtval.ml000066400000000000000000000222241366176261100177760ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: cvtval.ml,v 1.25 2004-07-08 10:10:18 xleroy Exp $ *) open Printf open Utils open Idltypes open Variables open Cvttyp (* Allocate space to hold a C value of type [ty], and store a pointer to this space in [c]. If [on_stack] is true, the space is allocated on stack. Otherwise, it is allocated in the heap. *) let allocate_space oc onstack ty c = if onstack then begin let c' = new_c_variable ty in iprintf oc "%s = &%s;\n" c c'; c' end else begin iprintf oc "%s = (%a *) camlidl_malloc(sizeof(%a), _ctx);\n" c out_c_type ty out_c_type ty; "*" ^ c end (* Helper functions to deal with option types / NULL pointers *) let option_ml_to_c oc v c conv = iprintf oc "if (%s == Val_int(0)) {\n" v; increase_indent(); iprintf oc "%s = NULL;\n" c; decrease_indent(); iprintf oc "} else {\n"; increase_indent(); let v' = new_ml_variable() in iprintf oc "%s = Field(%s, 0);\n" v' v; conv v'; decrease_indent(); iprintf oc "}\n" let option_c_to_ml oc c v conv = iprintf oc "if (%s == NULL) {\n" c; increase_indent(); iprintf oc "%s = Val_int(0);\n" v; decrease_indent(); iprintf oc "} else {\n"; increase_indent(); let v' = new_ml_variable() in conv v'; iprintf oc "Begin_root(%s)\n" v'; increase_indent(); iprintf oc "%s = camlidl_alloc_small(1, 0);\n" v; iprintf oc "Field(%s, 0) = %s;\n" v v'; decrease_indent(); iprintf oc "End_roots();\n"; decrease_indent(); iprintf oc "}\n" (* Translate the ML value [v] and store it into the C lvalue [c]. [ty] is the IDL type of the value being converted. [pref] is the access prefix for the dependent parameters (size, discriminants, etc) to be updated. [onstack] is true if C structures should be allocated on stack (their lifetime is that of the current function). [onstack] is false if C structures should be heap-allocated (they may be returned by the current function). *) let rec ml_to_c oc onstack pref ty v c = match ty with Type_int(kind, repr) -> let conv = match repr with Iunboxed -> if kind = Long || kind = ULong then "Long_val" else "Int_val" | Inative -> "Nativeint_val" | I32 -> "Int32_val" | I64 -> "Int64_val" in iprintf oc "%s = %s(%s);\n" c conv v | Type_float | Type_double -> iprintf oc "%s = Double_val(%s);\n" c v | Type_void -> () | Type_struct sd -> if sd.sd_name = "" then Struct.struct_ml_to_c ml_to_c oc onstack pref sd v c else begin iprintf oc "camlidl_ml2c_%s_struct_%s(%s, &%s, _ctx);\n" sd.sd_mod sd.sd_name v c; need_context := true end | Type_union(ud, attr) -> if ud.ud_name = "" then Union.union_ml_to_c ml_to_c oc onstack pref ud v c (Lexpr.tostring pref attr.discriminant) else begin iprintf oc "%a = camlidl_ml2c_%s_union_%s(%s, &%s, _ctx);\n" Lexpr.output (pref, attr.discriminant) ud.ud_mod ud.ud_name v c; need_context := true end | Type_enum(en, attr) -> if attr.bitset then Enum.enumset_ml_to_c ml_to_c oc en v c else if en.en_name = "" then Enum.enum_ml_to_c ml_to_c oc en v c else iprintf oc "%s = camlidl_ml2c_%s_enum_%s(%s);\n" c en.en_mod en.en_name v | Type_named(modl, name) -> iprintf oc "camlidl_ml2c_%s_%s(%s, &%s, _ctx);\n" modl name v c; need_context := true | Type_pointer(Ref, Type_interface(modl, name)) -> iprintf oc "%s = (struct %s *) camlidl_unpack_interface(%s, _ctx);\n" c name v; need_context := true | Type_pointer(Ref, ty_elt) -> let c' = allocate_space oc onstack ty_elt c in ml_to_c oc onstack pref ty_elt v c' | Type_pointer(Unique, ty_elt) -> option_ml_to_c oc v c (fun v' -> ml_to_c oc onstack pref (Type_pointer(Ref, ty_elt)) v' c) | Type_pointer(Ptr, ty_elt) -> iprintf oc "%s = (%a) Field(%s, 0);\n" c out_c_type ty v | Type_pointer(Ignore, ty_elt) -> iprintf oc "%s = NULL;\n" c | Type_array({maybe_null=false} as attr, ty_elt) -> Idlarray.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v c | Type_array({maybe_null=true} as attr, ty_elt) -> option_ml_to_c oc v c (fun v' -> Idlarray.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v' c) | Type_bigarray({bigarray_maybe_null=false} as attr, ty_elt) -> Idlarray.bigarray_ml_to_c oc pref attr ty_elt v c | Type_bigarray({bigarray_maybe_null=true} as attr, ty_elt) -> option_ml_to_c oc v c (fun v' -> Idlarray.bigarray_ml_to_c oc pref attr ty_elt v' c) | Type_interface(modl, name) -> error (sprintf "Reference to interface %s that is not a pointer" name) | Type_const ty' -> ml_to_c oc onstack pref ty' v c (* Translate the C value [c] and store it into the ML variable [v]. [ty] is the IDL type of the value being converted. [pref] is the access prefix for the dependent parameters (size, discriminants, etc) to be updated. *) let rec c_to_ml oc pref ty c v = match ty with | 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 -> if kind = Long || kind = ULong then "Val_long" else "Val_int" | Inative -> "caml_copy_nativeint" | I32 -> "caml_copy_int32" | I64 -> "caml_copy_int64" in iprintf oc "%s = %s(%s);\n" v conv c | Type_float | Type_double -> iprintf oc "%s = caml_copy_double(%s);\n" v c | Type_void -> () | Type_struct sd -> if sd.sd_name = "" then Struct.struct_c_to_ml c_to_ml oc pref sd c v else iprintf oc "%s = camlidl_c2ml_%s_struct_%s(&%s, _ctx);\n" v sd.sd_mod sd.sd_name c; need_context := true | Type_union(ud, attr) -> if ud.ud_name = "" then Union.union_c_to_ml c_to_ml oc pref ud c v (Lexpr.tostring pref attr.discriminant) else iprintf oc "%s = camlidl_c2ml_%s_union_%s(%a, &%s, _ctx);\n" v ud.ud_mod ud.ud_name Lexpr.output (pref, attr.discriminant) c; need_context := true | Type_enum(en, attr) -> if attr.bitset then Enum.enumset_c_to_ml c_to_ml oc en c v else if en.en_name = "" then Enum.enum_c_to_ml c_to_ml oc en c v else iprintf oc "%s = camlidl_c2ml_%s_enum_%s(%s);\n" v en.en_mod en.en_name c | Type_named(modl, name) -> iprintf oc "%s = camlidl_c2ml_%s_%s(&%s, _ctx);\n" v modl name c; need_context := true | Type_pointer(Ref, Type_interface(modl, name)) -> iprintf oc "%s = camlidl_pack_interface(%s, _ctx);\n" v c; need_context := true | Type_pointer(Ref, ty_elt) -> c_to_ml oc pref ty_elt (sprintf "*%s" c) v; | Type_pointer(Unique, ty_elt) -> option_c_to_ml oc c v (c_to_ml oc pref (Type_pointer(Ref, ty_elt)) c) | 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(Ignore, ty_elt) -> () | Type_array({maybe_null=false} as attr, ty_elt) -> Idlarray.array_c_to_ml c_to_ml oc pref attr ty_elt c v | Type_array({maybe_null=true} as attr, ty_elt) -> option_c_to_ml oc c v (Idlarray.array_c_to_ml c_to_ml oc pref attr ty_elt c) | Type_bigarray({bigarray_maybe_null=false} as attr, ty_elt) -> Idlarray.bigarray_c_to_ml oc pref attr ty_elt c v | Type_bigarray({bigarray_maybe_null=true} as attr, ty_elt) -> option_c_to_ml oc c v (Idlarray.bigarray_c_to_ml oc pref attr ty_elt c) | Type_interface(modl, name) -> error (sprintf "Reference to interface %s that is not a pointer" name) | Type_const ty' -> c_to_ml oc pref ty' c v (* Allocate suitable space for the C out parameter [c]. *) let rec allocate_output_space oc pref c ty = match ty with Type_pointer(attr, ty_arg) -> let c' = new_c_variable ty_arg in iprintf oc "%s = &%s;\n" c c' | Type_array(attr, ty_arg) -> Idlarray.array_allocate_output_space oc pref attr ty_arg c | Type_bigarray(attr, ty_arg) -> Idlarray.bigarray_allocate_output_space oc pref attr ty_arg c | Type_const ty' -> (* does this make sense? *) allocate_output_space oc pref c ty' | _ -> () camlidl-camlidl109/compiler/cvtval.mli000066400000000000000000000022431366176261100201460ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: cvtval.mli,v 1.11 2002-01-16 09:42:01 xleroy Exp $ *) (* Conversion of values between ML and C *) open Idltypes val ml_to_c : out_channel -> bool -> Prefix.t -> idltype -> string -> string -> unit val c_to_ml : out_channel -> Prefix.t -> idltype -> string -> string -> unit val allocate_output_space : out_channel -> Prefix.t -> string -> idltype -> unit camlidl-camlidl109/compiler/enum.ml000066400000000000000000000046531366176261100174510ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: enum.ml,v 1.9 2000-08-19 11:04:56 xleroy Exp $ *) (* Handling of enums *) open Printf open Utils open Variables open Idltypes (* Translate an ML datatype [v] to a C enum [c] *) let enum_ml_to_c ml_to_c oc en v c = iprintf oc "%s = camlidl_transl_table_%s_enum_%d[Int_val(%s)];\n" c en.en_mod en.en_stamp v (* Translate a C enum [c] to an ML datatype [v] *) let enum_c_to_ml c_to_ml oc en c v = if List.length en.en_consts <= 4 then begin iprintf oc "switch(%s) {\n" c; iter_index (fun i c -> iprintf oc "case %s: %s = Val_int(%d); break;\n" c.const_name v i) 0 en.en_consts; iprintf oc "default: caml_invalid_argument(\"%s: bad enum %s value\");\n" !current_function en.en_name; iprintf oc "}\n" end else begin iprintf oc "%s = camlidl_find_enum(%s, camlidl_transl_table_%s_enum_%d, %d, \"%s: bad enum %s value\");\n" v c en.en_mod en.en_stamp (List.length en.en_consts) !current_function en.en_name end (* Translate an ML list [v] to a C enumset [c] *) let enumset_ml_to_c ml_to_c oc en v c = if en.en_name = "" then error "[set] attribute does not apply to anonymous enum"; iprintf oc "%s = caml_convert_flag_list(%s, camlidl_transl_table_%s_enum_%d);\n" c v en.en_mod en.en_stamp (* Translate a C enumset [c] to an ML list [v] *) let enumset_c_to_ml c_to_ml oc en c v = if en.en_name = "" then error "[set] attribute does not apply to anonymous enum"; iprintf oc "%s = camlidl_alloc_flag_list(%s, camlidl_transl_table_%s_enum_%d, %d);\n" v c en.en_mod en.en_stamp (List.length en.en_consts) camlidl-camlidl109/compiler/enum.mli000066400000000000000000000027671366176261100176260ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: enum.mli,v 1.7 2002-01-16 09:42:01 xleroy Exp $ *) (* Handling of enums *) open Idltypes val enum_ml_to_c : (out_channel -> bool -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> enum_decl -> string -> string -> unit val enum_c_to_ml : (out_channel -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> enum_decl -> string -> string -> unit val enumset_ml_to_c : (out_channel -> bool -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> enum_decl -> string -> string -> unit val enumset_c_to_ml : (out_channel -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> enum_decl -> string -> string -> unit camlidl-camlidl109/compiler/enumdecl.ml000066400000000000000000000064461366176261100203030ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: enumdecl.ml,v 1.11 2000-08-19 11:04:56 xleroy Exp $ *) (* Generation of converters for enums *) open Printf open Utils open Variables open Idltypes open Cvttyp open Cvtval open Enum (* Convert an IDL enum declaration to an ML datatype declaration *) let ml_declaration oc en = if en.en_name = "" then fprintf oc "enum_%d =\n" en.en_stamp else fprintf oc "%s =\n" (String.uncapitalize_ascii en.en_name); List.iter (fun c -> fprintf oc " | %s\n" (String.capitalize_ascii c.const_name)) en.en_consts (* Convert an IDL enum declaration to a C enum declaration *) let c_declaration oc en = out_enum oc en; fprintf oc ";\n\n" (* External (forward) declaration of the translation functions *) let declare_transl oc en = fprintf oc "extern int camlidl_ml2c_%s_enum_%s(value);\n" en.en_mod en.en_name; fprintf oc "extern value camlidl_c2ml_%s_enum_%s(int);\n\n" en.en_mod en.en_name; fprintf oc "extern int camlidl_transl_table_%s_enum_%s[];\n\n" en.en_mod en.en_name (* Translation function from an ML datatype to a C enum *) let emit_transl_table oc en = fprintf oc "int camlidl_transl_table_%s_enum_%d[%d] = {\n" en.en_mod en.en_stamp (List.length en.en_consts); List.iter (fun c -> fprintf oc " %s,\n" c.const_name) en.en_consts; fprintf oc "};\n\n" let transl_ml_to_c oc en = current_function := sprintf "enum %s" en.en_name; let v = new_var "_v" in fprintf oc "int camlidl_ml2c_%s_enum_%s(value %s)\n" en.en_mod en.en_name v; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); let c = new_c_variable (Type_int(Int, Iunboxed)) in enum_ml_to_c ml_to_c pc en v c; iprintf pc "return %s;\n" c; output_variable_declarations oc; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; current_function := "" (* Translation function from a C enum to an ML datatype *) let transl_c_to_ml oc en = current_function := sprintf "enum %s" en.en_name; let c = new_var "_c" in fprintf oc "value camlidl_c2ml_%s_enum_%s(int %s)\n" en.en_mod en.en_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); let v = new_ml_variable() in enum_c_to_ml c_to_ml pc en c v; iprintf pc "return %s;\n" v; output_variable_declarations oc; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; current_function := "" (* Emit the translation functions *) let emit_transl oc en = emit_transl_table oc en; transl_ml_to_c oc en; transl_c_to_ml oc en camlidl-camlidl109/compiler/enumdecl.mli000066400000000000000000000022641366176261100204460ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: enumdecl.mli,v 1.5 2000-08-19 11:04:56 xleroy Exp $ *) (* Generation of converters for enums *) open Idltypes val ml_declaration : out_channel -> enum_decl -> unit val c_declaration : out_channel -> enum_decl -> unit val declare_transl: out_channel -> enum_decl -> unit val emit_transl : out_channel -> enum_decl -> unit val emit_transl_table : out_channel -> enum_decl -> unit camlidl-camlidl109/compiler/file.ml000066400000000000000000000170551366176261100174240ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: file.ml,v 1.18 2002-04-19 13:24:29 xleroy Exp $ *) (* Handling of interfaces *) open Printf open Utils open Idltypes open Intf type diversion_type = Div_c | Div_h | Div_ml | Div_mli | Div_ml_mli type component = Comp_typedecl of Typedef.type_decl | Comp_structdecl of struct_decl | Comp_uniondecl of union_decl | Comp_enumdecl of enum_decl | Comp_fundecl of Funct.function_decl | Comp_constdecl of Constdecl.constant_decl | Comp_diversion of diversion_type * string | Comp_interface of Intf.interface | Comp_import of string * components and components = component list (* Evaluate all constant definitions *) let rec eval_constants intf = List.iter (function Comp_constdecl cd -> Constdecl.record cd | Comp_import(file, comps) -> eval_constants comps | _ -> ()) intf (* Generate the ML interface *) (* Generate the type definitions common to the .ml and the .mli *) let gen_type_def oc intf = let first = ref true in let start_decl () = if !first then fprintf oc "type " else fprintf oc "and "; first := false in let emit_typedef = function Comp_typedecl td -> start_decl(); Typedef.ml_declaration oc td | Comp_structdecl s -> if s.sd_fields <> [] then begin start_decl(); Structdecl.ml_declaration oc s end | Comp_uniondecl u -> if u.ud_cases <> [] then begin start_decl(); Uniondecl.ml_declaration oc u end | Comp_enumdecl e -> start_decl(); Enumdecl.ml_declaration oc e | Comp_interface i -> if i.intf_methods <> [] then begin start_decl(); Intf.ml_declaration oc i end | _ -> () in List.iter emit_typedef intf; fprintf oc "\n" (* Generate the .mli file *) let gen_mli_file oc intf = fprintf oc "(* File generated from %s.idl *)\n\n" !module_name; gen_type_def oc intf; (* Generate the function declarations *) let emit_fundecl = function Comp_fundecl fd -> Funct.ml_declaration oc fd | Comp_constdecl cd -> Constdecl.ml_declaration oc cd | Comp_diversion((Div_mli | Div_ml_mli), txt) -> output_string oc txt; output_char oc '\n' | Comp_interface i -> if i.intf_methods <> [] then Intf.ml_class_declaration oc i | _ -> () in List.iter emit_fundecl intf (* Generate the .ml file *) let gen_ml_file oc intf = fprintf oc "(* File generated from %s.idl *)\n\n" !module_name; gen_type_def oc intf; (* Generate the function declarations and class definitions *) let emit_fundecl = function Comp_fundecl fd -> Funct.ml_declaration oc fd | Comp_constdecl cd -> Constdecl.ml_definition oc cd | Comp_diversion((Div_ml | Div_ml_mli), txt) -> output_string oc txt; output_char oc '\n' | Comp_interface i -> if i.intf_methods <> [] then Intf.ml_class_definition oc i | _ -> () in List.iter emit_fundecl intf (* Process an import: declare the translation functions *) let rec declare_comp oc = function Comp_typedecl td -> Typedef.declare_transl oc td | Comp_structdecl sd -> if sd.sd_name <> "" then Structdecl.declare_transl oc sd | Comp_uniondecl ud -> if ud.ud_name <> "" then Uniondecl.declare_transl oc ud | Comp_enumdecl en -> if en.en_name <> "" then Enumdecl.declare_transl oc en | Comp_fundecl fd -> () | Comp_constdecl cd -> () | Comp_diversion(kind, txt) -> () | Comp_interface i -> Intf.declare_transl oc i | Comp_import(filename, comps) -> List.iter (declare_comp oc) comps (* Process a component *) let rec process_comp oc = function Comp_typedecl td -> Typedef.emit_transl oc td | Comp_structdecl sd -> if sd.sd_name <> "" then if sd.sd_fields = [] then Structdecl.declare_transl oc sd else Structdecl.emit_transl oc sd | Comp_uniondecl ud -> if ud.ud_name <> "" then if ud.ud_cases = [] then Uniondecl.declare_transl oc ud else Uniondecl.emit_transl oc ud | Comp_enumdecl en -> if en.en_name <> "" then Enumdecl.emit_transl oc en else Enumdecl.emit_transl_table oc en | Comp_fundecl fd -> Funct.emit_wrapper oc fd | Comp_constdecl cd -> () | Comp_diversion(kind, txt) -> if kind = Div_c || (kind = Div_h && not !Clflags.include_header) then begin output_string oc txt; output_char oc '\n' end | Comp_interface i -> if i.intf_methods <> [] then Intf.emit_transl oc i | Comp_import(filename, comps) -> List.iter (declare_comp oc) comps (* Generate the C stub file *) let gen_c_stub oc intf = (* Output the header *) fprintf oc "/* File generated from %s.idl */\n\n" !module_name; output_string oc "\ #include \n\ #include \n\ #include \n\ #include \n\ #include \n\ #include \n\ #include \n\ #ifdef Custom_tag\n\ #include \n\ #include \n\ #endif\n\ #include \n\n"; if !Clflags.include_header then (* Include the .h for the module (as generated by us or by MIDL, or written by the user) *) fprintf oc "\n#include \"%s.h\"\n\n" !module_name; (* Process the interface *) List.iter (process_comp oc) intf (* Generate the C header file *) let process_definition oc = function Comp_typedecl td -> Typedef.c_declaration oc td | Comp_structdecl sd -> if sd.sd_name <> "" then Structdecl.c_declaration oc sd | Comp_uniondecl ud -> if ud.ud_name <> "" then Uniondecl.c_declaration oc ud | Comp_enumdecl en -> if en.en_name <> "" then Enumdecl.c_declaration oc en | Comp_fundecl fd -> Funct.c_declaration oc fd | Comp_constdecl cd -> Constdecl.c_declaration oc cd | Comp_diversion(kind, txt) -> if kind = Div_h then begin output_string oc txt; output_char oc '\n' end | Comp_interface i -> Intf.c_declaration oc i | Comp_import(basename, comps) -> fprintf oc "#include \"%s.h\"\n" basename let gen_c_header oc intf = (* Output the header *) fprintf oc "/* File generated from %s.idl */\n\n" !module_name; (* TODO: emit relevant #include *) let symbname = "_CAMLIDL_" ^ String.uppercase_ascii !module_name ^ "_H" in fprintf oc "\ #ifndef %s\n\ #define %s\n\n" symbname symbname; fprintf oc "\ #ifdef __cplusplus\n\ #define _CAMLIDL_EXTERN_C extern \"C\"\n\ #else\n\ #define _CAMLIDL_EXTERN_C extern\n\ #endif\n\n\ #ifdef _WIN32\n\ #pragma pack(push,8) /* necessary for COM interfaces */\n\ #endif\n\n"; (* Emit the definitions *) List.iter (process_definition oc) intf; fprintf oc "\ #ifdef _WIN32\n\ #pragma pack(pop)\n\ #endif\n\n"; fprintf oc "\n\ #endif /* !%s */\n" symbname camlidl-camlidl109/compiler/file.mli000066400000000000000000000031321366176261100175640ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: file.mli,v 1.10 2000-08-19 11:04:56 xleroy Exp $ *) (* Handling of files *) open Idltypes type diversion_type = Div_c | Div_h | Div_ml | Div_mli | Div_ml_mli type component = Comp_typedecl of Typedef.type_decl | Comp_structdecl of struct_decl | Comp_uniondecl of union_decl | Comp_enumdecl of enum_decl | Comp_fundecl of Funct.function_decl | Comp_constdecl of Constdecl.constant_decl | Comp_diversion of diversion_type * string | Comp_interface of Intf.interface | Comp_import of string * components and components = component list val eval_constants: components -> unit val gen_mli_file: out_channel -> components -> unit val gen_ml_file: out_channel -> components -> unit val gen_c_stub: out_channel -> components -> unit val gen_c_header: out_channel -> components -> unit camlidl-camlidl109/compiler/fixlabels.ml000066400000000000000000000121351366176261100204500ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: fixlabels.ml,v 1.4 2001-06-17 10:50:24 xleroy Exp $ *) (* Prefix record labels with struct/typedef name if required or requested *) open Printf open Utils open Idltypes open Typedef open Funct open Intf open File (* Determine if an mlname was provided by the user in the IDL file *) let no_ml_name f = f.field_mlname == f.field_name (* We use physical equality instead of string equality so that an explicit [mlname(samename)] can override the prefixing *) (* Collect all label names and those that appear at least twice *) module LabelSet = Set.Make(struct type t = string let compare = compare end) let all_labels = ref LabelSet.empty let repeated_labels = ref LabelSet.empty let add_label s = if LabelSet.mem s !all_labels then repeated_labels := LabelSet.add s !repeated_labels else all_labels := LabelSet.add s !all_labels let rec collect_type = function Type_pointer(_, ty) -> collect_type ty | Type_array(_, ty) -> collect_type ty | Type_bigarray(_, ty) -> collect_type ty | Type_struct sd -> List.iter collect_field sd.sd_fields | Type_union(ud, _) -> List.iter collect_case ud.ud_cases | Type_const ty -> collect_type ty | _ -> () and collect_field f = if no_ml_name f then add_label f.field_name; collect_type f.field_typ and collect_case c = match c.case_field with None -> () | Some f -> collect_field f let collect_component = function Comp_typedecl td -> collect_type td.td_type | Comp_structdecl sd -> List.iter collect_field sd.sd_fields | Comp_uniondecl ud -> List.iter collect_case ud.ud_cases | Comp_fundecl fd -> collect_type fd.fun_res | Comp_interface intf -> List.iter (fun fd -> collect_type fd.fun_res) intf.intf_methods | _ -> () (* A struct definition needs prefixing if some of its labels occur several times in the file *) let need_prefixing sd = List.exists (fun f -> no_ml_name f && LabelSet.mem f.field_name !repeated_labels) sd.sd_fields (* Prefix label names with struct or typedef name, if required or requested *) let choose_prefix oldpref newpref = if newpref <> "" then newpref else oldpref let rec prefix_type pref = function Type_struct sd -> Type_struct(prefix_struct pref sd) | Type_union(ud, attr) -> Type_union(prefix_union pref ud, attr) | Type_pointer(kind, ty) -> Type_pointer(kind, prefix_type pref ty) | Type_array(attr, ty) -> Type_array(attr, prefix_type pref ty) | Type_const ty -> Type_const(prefix_type pref ty) | ty -> ty and prefix_struct pref sd = let prefix = choose_prefix pref sd.sd_name in let add_prefix = if !Clflags.prefix_all_labels || need_prefixing sd then begin if prefix = "" then begin eprintf "Warning: couldn't find prefix for anonymous struct\n"; false end else true end else false in {sd with sd_fields = List.map (prefix_field add_prefix prefix) sd.sd_fields} and prefix_field add_prefix pref f = let new_mlname = if add_prefix && no_ml_name f then pref ^ "_" ^ f.field_name else f.field_mlname in {f with field_mlname = new_mlname; field_typ = prefix_type pref f.field_typ} and prefix_union pref ud = let prefix = choose_prefix pref ud.ud_name in {ud with ud_cases = List.map (prefix_case prefix) ud.ud_cases} and prefix_case pref cs = match cs.case_field with None -> cs | Some ty -> {cs with case_field = Some(prefix_field false pref ty)} let prefix_typedecl td = {td with td_type = prefix_type td.td_name td.td_type} let prefix_fundecl fd = {fd with fun_res = prefix_type "" fd.fun_res} (* no struct decl in function arguments *) let prefix_interface intf = {intf with intf_methods = List.map prefix_fundecl intf.intf_methods} let prefix_component = function Comp_typedecl td -> Comp_typedecl(prefix_typedecl td) | Comp_structdecl sd -> Comp_structdecl(prefix_struct "" sd) | Comp_uniondecl ud -> Comp_uniondecl(prefix_union "" ud) | Comp_fundecl fd -> Comp_fundecl(prefix_fundecl fd) | Comp_interface intf -> Comp_interface(prefix_interface intf) | cmp -> cmp let prefix_file f = if !Clflags.keep_labels then f else begin all_labels := LabelSet.empty; repeated_labels := LabelSet.empty; List.iter collect_component f; let res = List.map prefix_component f in all_labels := LabelSet.empty; repeated_labels := LabelSet.empty; res end camlidl-camlidl109/compiler/fixlabels.mli000066400000000000000000000017311366176261100206210ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: fixlabels.mli,v 1.2 2000-08-19 11:04:56 xleroy Exp $ *) (* Prefix record labels with struct/typedef name *) val prefix_file: File.components -> File.components camlidl-camlidl109/compiler/funct.ml000066400000000000000000000276161366176261100176300ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: funct.ml,v 1.30 2004-07-08 09:50:23 xleroy Exp $ *) (* Generation of stub code for functions *) open Printf open Utils open Variables open Idltypes open Typedef open Cvttyp open Cvtval type in_out = In | Out | InOut type function_decl = { fun_name: string; 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_blocking: bool } (* Remove dependent parameters (parameters that are size_is, length_is, or switch_is of another parameter). Note: an "in" parameter that is size_is of an "out" parameter cannot be removed. Also remove ignored pointers. *) let is_dependent_parameter name mode params = List.exists (fun (_, mode', ty) -> Lexpr.is_dependent name ty && (mode' <> Out || mode = Out)) params let remove_dependent_parameters params = list_filter (fun (name, mode, ty) -> not (is_dependent_parameter name mode params || is_ignored ty)) params (* Split parameters into in parameters and out parameters. In/out get copied to both. Inout (in place) are viewed as in. *) let rec split_in_out = function [] -> ([], []) | (name, inout, ty) :: rem -> let (ins, outs) = split_in_out rem in match inout with In -> ((name, ty) :: ins, outs) | Out -> (ins, (name, ty) :: outs) | InOut -> match ty with Type_array({is_string = true}, _) | Type_bigarray(_, _) -> ((name, ty) :: ins, outs) | _ -> ((name, ty) :: ins, (name, ty) :: outs) (* Determine if a typedef represents an error code *) let rec is_errorcode = function Type_named(modl, name) -> (!Typedef.find name).td_errorcode | Type_pointer(kind, ty) -> is_errorcode ty | Type_const ty -> is_errorcode ty | _ -> false (* Convert the C view of parameters and result into the ML view: - remove dependent parameters - turn out and in/out parameters into extra results - remove void and errorcode return values *) let ml_view fundecl = let true_params = remove_dependent_parameters fundecl.fun_params in let (ins, outs) = split_in_out true_params in (* Add return value as an out if it's not void and not an error code *) let outs2 = if fundecl.fun_res = Type_void || is_errorcode fundecl.fun_res then outs else ("_res", fundecl.fun_res) :: outs in (* Remove out parameters that are error codes *) (ins, outs2) (* 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_ascii (mlname fundecl)); out_ml_types oc "->" ins; fprintf oc " -> "; out_ml_types oc "*" outs; if List.length ins <= 5 then fprintf oc "\n\t= \"camlidl_%s_%s\"\n\n" fundecl.fun_mod fundecl.fun_name else fprintf oc "\n\t= \"camlidl_%s_%s_bytecode\" \"camlidl_%s_%s\"\n\n" fundecl.fun_mod fundecl.fun_name fundecl.fun_mod fundecl.fun_name (* Print a warm fuzzy in/out comment *) let out_inout oc = function In -> fprintf oc "in" | Out -> fprintf oc "out" | InOut -> fprintf oc "in,out" (* Generate the C declaration for a function *) let c_declaration oc fundecl = fprintf oc "_CAMLIDL_EXTERN_C %a(" out_c_decl (fundecl.fun_name, fundecl.fun_res); begin match fundecl.fun_params with [] -> fprintf oc "void" | p1 :: pl -> let out_param (name, inout, ty) = fprintf oc "/*%a*/ %a" out_inout inout out_c_decl (name, ty) in out_param p1; List.iter (fun p -> fprintf oc ", "; out_param p) pl end; fprintf oc ");\n\n" (* If context is needed, set it up (transient allocation, transient interface refs) *) let output_context before after = if !need_context then begin fprintf before " struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL };\n"; fprintf before " camlidl_ctx _ctx = &_ctxs;\n"; iprintf after "camlidl_free(_ctx);\n" end (* If a deallocation sequence is provided, insert it *) let output_dealloc oc dealloc = match dealloc with None -> () | Some s -> iprintf oc "/* begin user-supplied deallocation sequence */\n"; output_string oc s; output_char oc '\n'; iprintf oc "/* end user-supplied deallocation sequence */\n" (* Call an error checking function if needed *) let rec call_error_check oc name ty = match ty with Type_named(modl, ty_name) -> begin match !Typedef.find ty_name with {td_errorcheck = Some fn} -> iprintf oc "%s(%s);\n" fn name | _ -> () end | Type_pointer(kind, ty_elt) -> call_error_check oc ("*" ^ name) ty_elt | Type_const ty' -> call_error_check oc name ty' | _ -> () (* Shared code between emit_wrapper and emit_method_wrapper *) let emit_function oc fundecl ins outs locals emit_call = need_context := false; (* Emit function header *) fprintf oc "value camlidl_%s_%s(" fundecl.fun_mod fundecl.fun_name; begin match ins with [] -> fprintf oc "value _unit)\n" | (name1, ty1) :: rem -> fprintf oc "\n\tvalue _v_%s" name1; List.iter (fun (name, ty) -> fprintf oc ",\n\tvalue _v_%s" name) rem; fprintf oc ")\n" end; fprintf oc "{\n"; (* Declare C local variables to hold parameters and result *) List.iter (fun (name, inout, ty) -> fprintf oc " %a; /*%a*/\n" out_c_decl (name, scrape_const ty) out_inout inout) locals; if fundecl.fun_res <> Type_void then fprintf oc " %a;\n" out_c_decl ("_res", scrape_const fundecl.fun_res); let pc = divert_output() in increase_indent(); (* Initialize dependent parameters that are pointers so that they point to suitable storage *) List.iter (function (name, (In|InOut), (Type_pointer(_, ty_arg) | Type_const(Type_pointer(_, ty_arg)))) when is_dependent_parameter name In fundecl.fun_params -> let c = new_c_variable ty_arg in iprintf pc "%s = &%s;\n" name c | _ -> ()) fundecl.fun_params; (* Convert ins from ML to C *) let pref = Prefix.enter_function fundecl.fun_params in List.iter (fun (name, ty) -> ml_to_c pc true pref ty (sprintf "_v_%s" name) name) ins; (* Initialize outs that are pointers or arrays so that they point to suitable storage *) List.iter (function (name, Out, ty) -> allocate_output_space pc pref name ty | _ -> ()) fundecl.fun_params; (* Generate the call to the C function *) emit_call pc fundecl; (* Call error checking functions on result and out parameters that need it *) call_error_check pc "_res" fundecl.fun_res; List.iter (function (name, (Out|InOut), ty) -> call_error_check pc name ty | _ -> ()) fundecl.fun_params; (* Convert outs from C to ML *) begin match outs with [] -> output_variable_declarations oc; output_context oc pc; output_dealloc pc fundecl.fun_dealloc; iprintf pc "return Val_unit;\n" | [name, ty] -> c_to_ml pc pref ty name "_vres"; output_variable_declarations oc; fprintf oc " value _vres;\n\n"; output_context oc pc; output_dealloc pc fundecl.fun_dealloc; iprintf pc "return _vres;\n"; | _ -> let num_outs = List.length outs in iprintf pc "Begin_roots_block(_vres, %d)\n" num_outs; increase_indent(); let pos = ref 0 in List.iter (fun (name, ty) -> c_to_ml pc pref ty name (sprintf "_vres[%d]" !pos); incr pos) outs; iprintf pc "_vresult = camlidl_alloc_small(%d, 0);\n" num_outs; copy_values_to_block pc "_vres" "_vresult" num_outs; decrease_indent(); iprintf pc "End_roots()\n"; output_context oc pc; output_dealloc pc fundecl.fun_dealloc; iprintf pc "return _vresult;\n"; output_variable_declarations oc; fprintf oc " value _vresult;\n"; fprintf oc " value _vres[%d] = { " num_outs; for i = 1 to num_outs do fprintf oc "0, " done; fprintf oc "};\n\n" end; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; (* If more than 5 arguments, create an extra wrapper for the bytecode interface *) if List.length ins > 5 then begin fprintf oc "value camlidl_%s_%s_bytecode(value * argv, int argn)\n" fundecl.fun_mod fundecl.fun_name; fprintf oc "{\n"; fprintf oc " return camlidl_%s_%s(argv[0]" fundecl.fun_mod fundecl.fun_name; for i = 1 to List.length ins - 1 do fprintf oc ", argv[%d]" i done; fprintf oc ");\n"; fprintf oc "}\n\n" end (* Emit wrapper function for C function *) let emit_standard_call oc fundecl = 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; output_char oc '\n'; iprintf oc "/* end user-supplied calling sequence */\n" | None -> if fundecl.fun_res = Type_void then iprintf oc "" else iprintf oc "_res = "; fprintf oc "%s(" fundecl.fun_name; begin match fundecl.fun_params with [] -> () | (name1, _,_) :: rem -> fprintf oc "%s" name1; 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; let (ins, outs) = ml_view fundecl in emit_function oc fundecl ins outs fundecl.fun_params emit_standard_call; current_function := "" (* Emit wrapper function for COM method *) let emit_method_call intfname methname oc fundecl = (* Extract "this" parameter *) iprintf oc "this = camlidl_unpack_interface(_v_this, NULL);\n"; (* Reset the error mechanism *) iprintf oc "SetErrorInfo(0L, NULL);\n"; (* Emit the call *) 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; iprintf oc "/* end user-supplied calling sequence */\n" | None -> if fundecl.fun_res = Type_void then iprintf oc "" else iprintf oc "_res = "; 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; let fundecl = {meth with fun_name = sprintf "%s_%s" intf_name meth.fun_name} in let (ins1, outs) = ml_view fundecl in (* Add an ML parameter and a C local for "this" *) let intf_type = Type_pointer(Ignore, Type_interface("", intf_name)) in let ins = ("this", intf_type) :: ins1 in let locals = ("this", In, intf_type) :: fundecl.fun_params in emit_function oc fundecl ins outs locals (emit_method_call intf_name meth.fun_name); current_function := "" camlidl-camlidl109/compiler/funct.mli000066400000000000000000000031071366176261100177660ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: funct.mli,v 1.11 2004-07-08 09:50:23 xleroy Exp $ *) (* Generation of stub code for functions *) open Idltypes type in_out = In | Out | InOut type function_decl = { fun_name: string; 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_blocking: bool } val ml_view : function_decl -> (string * idltype) list * (string * idltype) list val ml_declaration : out_channel -> function_decl -> unit val c_declaration : out_channel -> function_decl -> unit val emit_wrapper : out_channel -> function_decl -> unit val emit_method_wrapper : out_channel -> string -> function_decl -> unit val out_inout : out_channel -> in_out -> unit camlidl-camlidl109/compiler/idlarray.ml000066400000000000000000000227651366176261100203200ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: array.ml,v 1.17 2002-01-16 09:42:00 xleroy Exp $ *) (* Handling of arrays and bigarrays *) 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(_, Iunboxed) -> true | Type_float -> true | Type_double -> true | Type_pointer(kind, ty) -> kind = Ref && no_allocation_type ty | Type_enum _ -> true | Type_const ty -> no_allocation_type ty | _ -> false (* Update dependent size variables *) let update_size_variable svar oc pref size = match svar with None -> () | Some re when Lexpr.is_identifier_deref re -> iprintf oc "%a = %s;\n" Lexpr.output (pref, re) size | Some re -> error "Array size expression too complex for ML -> C conversion" (* 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 begin iprintf oc "%s = camlidl_malloc_string(%s, _ctx);\n" c v; need_context := true end | Some n -> iprintf oc "if (caml_string_length(%s) >= %d) caml_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 = caml_string_length(%s);\n" Lexpr.output (pref, re) v end end else begin (* Determine actual size of ML array *) let size = new_c_variable (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) caml_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 (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_size_variable attr.size oc pref size; update_size_variable attr.length oc pref size 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 = caml_copy_string(%s);\n" v c else begin (* Determine size of ML array *) let (nsize, size) = 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 (Type_named("", "mlsize_t")) in iprintf oc "%s = camlidl_ptrarray_size((void **) %s);\n" sz c; (max_int, sz) | _ -> error "Cannot determine array size for C -> ML conversion" 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 (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 "caml_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 (* Determine the output size of an array *) let array_output_size attr = match attr with {length = Some re} -> re | {size = Some re} -> re | {bound = Some le} -> le | _ -> error "Cannot determine array size for C -> ML conversion" (* Allocate room for an out array *) let array_allocate_output_space oc pref attr ty_elt c = if attr.bound = None then begin iprintf oc "%s = camlidl_malloc(%a * sizeof(%a), _ctx);\n" c Lexpr.output (pref, array_output_size attr) out_c_type ty_elt; need_context := true end (* Translation from an ML bigarray [v] to a C array [c] *) let bigarray_ml_to_c oc pref attr ty_elt v c = iprintf oc "%s = Caml_ba_data_val(%s);\n" c v; (* Update dependent size variables, if any *) iter_index (fun i attr -> match attr.size with None -> () | Some re -> iprintf oc "%a = Caml_ba_array_val(%s)->dim[%d];\n" Lexpr.output (pref, re) v i) 0 attr.dims (* Return the flags to alloc_bigarray_dims corresponding to the given big array attributes *) let bigarray_alloc_kind = function Type_int((Char | UChar | Byte), _) -> "CAML_BA_UINT8" | Type_int((SChar | Small), _) -> "CAML_BA_SINT8" | Type_int(Short, _) -> "CAML_BA_SINT16" | Type_int(UShort, _) -> "CAML_BA_UINT16" | Type_int((Int | UInt), _) -> "CAML_BA_INT32" | Type_int((Long | ULong), I64) -> "CAML_BA_INT64" | Type_int((Long | ULong), _) -> "CAML_BA_NATIVE_INT" | Type_int((Hyper | UHyper), _) -> "CAML_BA_INT64" | Type_float -> "CAML_BA_FLOAT32" | Type_double -> "CAML_BA_FLOAT64" | _ -> assert false let bigarray_alloc_layout attr = if attr.fortran_layout then "CAML_BA_FORTRAN_LAYOUT" else "CAML_BA_C_LAYOUT" let bigarray_alloc_managed attr = if attr.malloced then "CAML_BA_MANAGED" else "CAML_BA_EXTERNAL" (* Translation from a C array [c] to an ML bigarray [v] *) let bigarray_c_to_ml oc pref attr ty_elt c v = iprintf oc "%s = caml_ba_alloc_dims(\n" v; iprintf oc " %s | %s | %s,\n" (bigarray_alloc_kind ty_elt) (bigarray_alloc_layout attr) (bigarray_alloc_managed attr); iprintf oc " %d, %s" (List.length attr.dims) c; List.iter (fun attr -> let e = array_output_size attr in fprintf oc ", %a" Lexpr.output (pref, e)) attr.dims; fprintf oc ");\n" (* Allocate room for an out bigarray *) let bigarray_allocate_output_space oc pref attr ty_elt c = (* Since the conversion to ML bigarray does not copy the data, we must allocate permanent space using stat_alloc (instead of transient space using camlidl_alloc), and we set the "malloced" attribute to true so that the ML bigarray will be managed by the Caml GC *) iprintf oc "%s = caml_stat_alloc(" c; List.iter (fun a -> fprintf oc "%a * " Lexpr.output (pref, array_output_size a)) attr.dims; fprintf oc "sizeof(%a));\n" out_c_type ty_elt; attr.malloced <- true camlidl-camlidl109/compiler/idlarray.mli000066400000000000000000000033561366176261100204640ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: array.mli,v 1.7 2002-01-16 09:42:00 xleroy Exp $ *) (* Marshaling for arrays and bigarrays *) open Idltypes val array_ml_to_c : (out_channel -> bool -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> bool -> Prefix.t -> array_attributes -> idltype -> string -> string -> unit val array_c_to_ml : (out_channel -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> Prefix.t -> array_attributes -> idltype -> string -> string -> unit val array_allocate_output_space : out_channel -> Prefix.t -> array_attributes -> idltype -> string -> unit val bigarray_ml_to_c : out_channel -> Prefix.t -> bigarray_attributes -> idltype -> string -> string -> unit val bigarray_c_to_ml : out_channel -> Prefix.t -> bigarray_attributes -> idltype -> string -> string -> unit val bigarray_allocate_output_space : out_channel -> Prefix.t -> bigarray_attributes -> idltype -> string -> unit camlidl-camlidl109/compiler/idltypes.mli000066400000000000000000000071161366176261100205100ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: idltypes.mli,v 1.23 2002-01-16 16:15:31 xleroy Exp $ *) type integer_kind = Int | Long | Hyper | Small | Short | Char | UInt | ULong | UHyper | USmall | UShort | UChar | SChar | Byte | Boolean type integer_repr = Iunboxed | Inative | I32 | I64 type pointer_kind = Ref | Unique | Ptr | Ignore type idltype = Type_int of integer_kind * integer_repr | Type_float | Type_double | Type_void | Type_pointer of pointer_kind * idltype | Type_array of array_attributes * idltype | Type_bigarray of bigarray_attributes * idltype | Type_struct of struct_decl | Type_union of union_decl * union_attributes | Type_enum of enum_decl * enum_attributes | Type_named of string * string (* module name, type name *) | Type_interface of string * string (* module name, interface name *) | Type_const of idltype and array_attributes = { bound: lexpr option; size: lexpr option; length: lexpr option; is_string: bool; maybe_null: bool; null_terminated: bool } and bigarray_attributes = { dims: array_attributes list; fortran_layout: bool; mutable malloced: bool; bigarray_maybe_null: bool } and union_attributes = { discriminant: lexpr } and enum_attributes = { bitset: bool } and field = { field_name: string; field_mlname: string; field_typ: idltype } and union_case = { case_labels: string list; case_field: field option } and enum_const = { const_name: string; const_val: lexpr option } and struct_decl = { sd_name: string; sd_mod: string; mutable sd_stamp: int; mutable sd_fields: field list } and union_decl = { ud_name: string; ud_mod: string; mutable ud_stamp: int; mutable ud_cases: union_case list } and enum_decl = { en_name: string; en_mod: string; mutable en_stamp: int; mutable en_consts: enum_const list } and lexpr = Expr_ident of string | Expr_int of int64 | Expr_string of string | Expr_cond of lexpr * lexpr * lexpr | Expr_sequand of lexpr * lexpr | Expr_sequor of lexpr * lexpr | Expr_logor of lexpr * lexpr | Expr_logxor of lexpr * lexpr | Expr_logand of lexpr * lexpr | Expr_eq of lexpr * lexpr | Expr_ne of lexpr * lexpr | Expr_lt of lexpr * lexpr | Expr_gt of lexpr * lexpr | Expr_le of lexpr * lexpr | Expr_ge of lexpr * lexpr | Expr_lshift of lexpr * lexpr | Expr_rshift of lexpr * lexpr | Expr_rshift_unsigned of lexpr * lexpr | Expr_plus of lexpr * lexpr | Expr_minus of lexpr * lexpr | Expr_times of lexpr * lexpr | Expr_div of lexpr * lexpr | Expr_mod of lexpr * lexpr | Expr_neg of lexpr | Expr_lognot of lexpr | Expr_boolnot of lexpr | Expr_deref of lexpr | Expr_addressof of lexpr | Expr_cast of idltype * lexpr | Expr_sizeof of idltype | Expr_subscript of lexpr * lexpr | Expr_dereffield of lexpr * string | Expr_field of lexpr * string camlidl-camlidl109/compiler/intf.ml000066400000000000000000000354271366176261100174500ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: intf.ml,v 1.23 2004-07-08 09:51:21 xleroy Exp $ *) (* Handling of COM-style interfaces *) open Utils open Printf open Variables open Idltypes open Cvttyp open Cvtval open Funct type interface = { intf_name: string; (* Name of interface *) intf_mod: string; (* Name of defining module *) mutable intf_super: interface; (* Super-interface *) mutable intf_methods: function_decl list; (* Methods *) mutable intf_uid: string } (* Unique interface ID *) (* Print a method type *) let out_method_type oc meth = let (ins, outs) = ml_view meth in begin match ins with [] -> () | _ -> out_ml_types oc "->" ins; fprintf oc " -> " end; out_ml_types oc "*" outs (* Print the ML abstract type identifying the interface *) let ml_declaration oc intf = fprintf oc "%s\n" (String.uncapitalize_ascii intf.intf_name) (* Declare the class *) let ml_class_declaration oc intf = let mlintf = String.uncapitalize_ascii intf.intf_name in let mlsuper = String.uncapitalize_ascii intf.intf_super.intf_name in fprintf oc "class %s_class :\n" mlintf; fprintf oc " %s Com.interface ->\n" mlintf; fprintf oc " object\n"; if intf.intf_super.intf_name <> "IUnknown" && intf.intf_super.intf_name <> "IDispatch" then fprintf oc " inherit %s_class\n" mlsuper; List.iter (fun meth -> fprintf oc " method %s: %a\n" (String.uncapitalize_ascii meth.fun_name) out_method_type meth) intf.intf_methods; fprintf oc " end\n\n"; (* Declare the IID *) if intf.intf_uid <> "" then fprintf oc "val iid_%s : %s Com.iid\n" mlintf mlintf; (* Declare the conversion functions *) fprintf oc "val use_%s : %s Com.interface -> %s_class\n" mlintf mlintf mlintf; fprintf oc "val make_%s : #%s_class -> %s Com.interface\n" mlintf mlintf mlintf; fprintf oc "val %s_of_%s : %s Com.interface -> %a Com.interface\n\n" mlsuper mlintf mlintf out_mltype_name (intf.intf_super.intf_mod, intf.intf_super.intf_name) (* Declare the interface in C *) let rec declare_vtbl oc self intf = if intf.intf_name = "IUnknown" || intf.intf_name = "IDispatch" then begin iprintf oc "DECLARE_VTBL_PADDING\n"; iprintf oc "HRESULT (STDMETHODCALLTYPE *QueryInterface)(struct %s *, IID *, void **);\n" self; iprintf oc "ULONG (STDMETHODCALLTYPE *AddRef)(struct %s *);\n" self; iprintf oc "ULONG (STDMETHODCALLTYPE *Release)(struct %s *);\n" self; if intf.intf_name = "IDispatch" then begin iprintf oc "HRESULT (STDMETHODCALLTYPE *GetTypeInfoCount)(struct %s *, UINT *);\n" self; iprintf oc "HRESULT (STDMETHODCALLTYPE *GetTypeInfo)(struct %s *, UINT, LCID, ITypeInfo **);\n" self; iprintf oc "HRESULT (STDMETHODCALLTYPE *GetIDsOfNames)(struct %s *, REFIID, OLECHAR**, UINT, LCID, DISPID *);\n" self; iprintf oc "HRESULT (STDMETHODCALLTYPE *Invoke)(struct %s *, DISPID, REFIID, LCID, WORD, DISPPARAMS *, VARIANT *, EXCEPINFO *, UINT *);\n" self end end else begin declare_vtbl oc self intf.intf_super; List.iter (fun m -> iprintf oc "%a(struct %s * self" out_c_decl (sprintf "(STDMETHODCALLTYPE *%s)" m.fun_name, m.fun_res) self; List.iter (fun (name, inout, ty) -> fprintf oc ",\n\t\t/*%a*/ %a" out_inout inout out_c_decl (name, ty)) m.fun_params; fprintf oc ");\n") intf.intf_methods end let rec declare_class oc self intf = if intf.intf_name = "IUnknown" || intf.intf_name = "IDispatch" then begin iprintf oc "virtual HRESULT STDMETHODCALLTYPE QueryInterface(IID *, void **);\n"; iprintf oc "virtual ULONG STDMETHODCALLTYPE AddRef();\n"; iprintf oc "virtual ULONG STDMETHODCALLTYPE Release();\n"; if intf.intf_name = "IDispatch" then begin iprintf oc "virtual HRESULT STDMETHODCALLTYPE GetTypeInfoCount(UINT *);\n"; iprintf oc "virtual HRESULT STDMETHODCALLTYPE GetTypeInfo(UINT, LCID, ITypeInfo **);\n"; iprintf oc "virtual HRESULT STDMETHODCALLTYPE GetIDsOfNames(REFIID, OLECHAR**, UINT, LCID, DISPID *);\n"; iprintf oc "virtual HRESULT STDMETHODCALLTYPE Invoke(DISPID, REFIID, LCID, WORD, DISPPARAMS *, VARIANT *, EXCEPINFO *, UINT *);\n" end end else begin declare_class oc self intf.intf_super; List.iter (fun m -> iprintf oc "virtual %a(" out_c_decl (sprintf "STDMETHODCALLTYPE %s" m.fun_name, m.fun_res); let first = ref true in List.iter (fun (name, inout, ty) -> if !first then first := false else fprintf oc ",\n\t\t"; fprintf oc "/*%a*/ %a" out_inout inout out_c_decl (name, ty)) m.fun_params; fprintf oc ");\n") intf.intf_methods end let c_declaration oc intf = if intf.intf_methods = [] then begin fprintf oc "struct %s;\n" intf.intf_name end else begin fprintf oc "#ifdef __cplusplus\n"; fprintf oc "struct %s {\n" intf.intf_name; increase_indent(); declare_class oc intf.intf_name intf; decrease_indent(); fprintf oc "};\n#else\n"; fprintf oc "struct %sVtbl {\n" intf.intf_name; increase_indent(); declare_vtbl oc intf.intf_name intf; decrease_indent(); fprintf oc "};\n"; fprintf oc "struct %s {\n" intf.intf_name; fprintf oc " struct %sVtbl * lpVtbl;\n" intf.intf_name; fprintf oc "};\n"; fprintf oc "#endif\n"; fprintf oc "_CAMLIDL_EXTERN_C IID IID_%s;\n\n" intf.intf_name end (* Define the wrapper classes *) let ml_class_definition oc intf = let intfname = String.uncapitalize_ascii intf.intf_name in let supername = String.uncapitalize_ascii intf.intf_super.intf_name in (* Define the IID *) if intf.intf_uid <> "" then fprintf oc "let iid_%s = Com._parse_iid \"%s\"\n" intfname intf.intf_uid; (* Define the coercion function to the super class *) fprintf oc "let %s_of_%s (intf : %s Com.interface) = (Obj.magic intf : %a Com.interface)\n\n" supername intfname intfname out_mltype_name (intf.intf_super.intf_mod, intf.intf_super.intf_name); (* Declare the C wrappers for invoking the methods from Caml *) let self_type = Type_pointer(Ref, Type_interface(!module_name, intf.intf_name)) in List.iter (fun meth -> let prim = { fun_name = sprintf "%s_%s" intf.intf_name meth.fun_name; 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; fun_blocking = false } in Funct.ml_declaration oc prim) intf.intf_methods; fprintf oc "\n"; (* Define the wrapper class *) fprintf oc "class %s_class (intf : %s Com.interface) =\n" intfname intfname; fprintf oc " object\n"; if intf.intf_super.intf_name <> "IUnknown" && intf.intf_super.intf_name <> "IDispatch" then fprintf oc " inherit (%s_class (%s_of_%s intf))\n" supername supername intfname; List.iter (fun meth -> let methname = String.uncapitalize_ascii meth.fun_name in fprintf oc " method %s = %s_%s intf\n" methname intfname meth.fun_name) intf.intf_methods; fprintf oc " end\n\n"; (* Define the conversion functions *) fprintf oc "let use_%s = new %s_class\n" intfname intfname; fprintf oc "external make_%s : #%s_class -> %s Com.interface = \"camlidl_makeintf_%s_%s\"\n\n" intfname intfname intfname !module_name intf.intf_name (* If context is needed, set it up (indefinite allocation, persistent interface refs) *) let output_context before after = if !need_context then begin fprintf before " struct camlidl_ctx_struct _ctxs = { CAMLIDL_ADDREF, NULL };\n"; fprintf before " camlidl_ctx _ctx = &_ctxs;\n" end (* Generate callback wrapper for calling an ML method from C *) let emit_callback_wrapper oc intf meth = current_function := sprintf "%s::%s" intf.intf_name meth.fun_name; need_context := false; let (ins, outs) = ml_view meth in let pref = Prefix.enter_function meth.fun_params in (* Emit function header *) let fun_name = sprintf "camlidl_%s_%s_%s_callback" !module_name intf.intf_name meth.fun_name in fprintf oc "%a(" out_c_decl ("STDMETHODCALLTYPE " ^ fun_name, meth.fun_res); fprintf oc "\n\tstruct %s * this" intf.intf_name; List.iter (fun (name, inout, ty) -> fprintf oc ",\n\t/* %a */ %a" out_inout inout out_c_decl (name, ty)) meth.fun_params; fprintf oc ")\n{\n"; (* Declare locals to hold ML arguments and result, and C result if any *) let num_ins = List.length ins in fprintf oc " value _varg[%d] = { " (num_ins + 1); for i = 0 to num_ins do fprintf oc "0, " done; fprintf oc "};\n"; fprintf oc " value _vres;\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 *) let pc = divert_output() in increase_indent(); iprintf pc "Begin_roots_block(_varg, %d)\n" (num_ins + 1); increase_indent(); iprintf pc "_varg[0] = ((struct camlidl_intf *) this)->caml_object;\n"; iter_index (fun pos (name, ty) -> c_to_ml pc pref ty name (sprintf "_varg[%d]" pos)) 1 ins; decrease_indent(); iprintf pc "End_roots();\n"; (* The method label *) let label = (Obj.magic (Oo.public_method_label (String.uncapitalize_ascii meth.fun_name)) : int) in (* Do the callback *) iprintf pc "_vres = caml_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") -> iprintf pc "if (Is_exception_result(_vres))\n"; iprintf pc " return camlidl_result_exception(\"%s.%s\", \ Extract_exception(_vres));\n" !module_name !current_function; iprintf pc "_res = S_OK;\n" | Type_named(_, ("HRESULT_int" | "HRESULT_bool")) -> iprintf pc "if (Is_exception_result(_vres))\n"; iprintf pc " return camlidl_result_exception(\"%s.%s\", \ Extract_exception(_vres));\n" !module_name !current_function | _ -> iprintf pc "if (Is_exception_result(_vres))\n"; iprintf pc " camlidl_uncaught_exception(\"%s\", \ Extract_exception(_vres));\n" !current_function end; (* Convert outputs from Caml to C *) let convert_output ty src dst = match (dst, scrape_const ty) with ("_res", _) -> ml_to_c pc false pref ty src dst | (_, Type_pointer(_, ty')) -> ml_to_c pc false pref ty' src ("*" ^ dst) | (_, _) -> error (sprintf "Out parameter `%s' must be a pointer" dst) in begin match outs with [] -> () | [name, ty] -> convert_output ty "_vres" name | _ -> iter_index (fun pos (name, ty) -> convert_output ty (sprintf "Field(_vres, %d)" pos) name) 0 outs end; output_context oc pc; (* Return result if any *) if meth.fun_res <> Type_void then iprintf pc "return _res;\n"; output_variable_declarations oc; decrease_indent(); end_diversion oc; fprintf oc "}\n\n" (* Declare external callback wrapper *) let declare_callback_wrapper oc intf meth = (* Emit function header *) let fun_name = sprintf "camlidl_%s_%s_%s_callback" !module_name intf.intf_name meth.fun_name in fprintf oc "extern %a(" out_c_decl (fun_name, meth.fun_res); fprintf oc "\n\tstruct %s * this" intf.intf_name; List.iter (fun (name, inout, ty) -> fprintf oc ",\n\t/* %a */ %a" out_inout inout out_c_decl (name, ty)) meth.fun_params; fprintf oc ");\n\n" (* Generate the vtable for an interface (for the make_ conversion) *) let rec emit_vtbl oc intf = if intf.intf_name = "IUnknown" || intf.intf_name = "IDispatch" then begin fprintf oc " (void *) camlidl_QueryInterface,\n"; fprintf oc " (void *) camlidl_AddRef,\n"; fprintf oc " (void *) camlidl_Release,\n"; if intf.intf_name = "IDispatch" then begin fprintf oc " (void *) camlidl_GetTypeInfoCount,\n"; fprintf oc " (void *) camlidl_GetTypeInfo,\n"; fprintf oc " (void *) camlidl_GetIDsOfNames,\n"; fprintf oc " (void *) camlidl_Invoke,\n" end end else begin emit_vtbl oc intf.intf_super; List.iter (fun m -> fprintf oc " /* %s */ (void *) camlidl_%s_%s_%s_callback,\n" m.fun_name !module_name intf.intf_name m.fun_name) intf.intf_methods end let emit_vtable oc intf = fprintf oc "struct %sVtbl camlidl_%s_%s_vtbl = {\n" intf.intf_name !module_name intf.intf_name; fprintf oc " VTBL_PADDING\n"; emit_vtbl oc intf; fprintf oc "};\n\n" (* Generate the make_ conversion (takes an ML object, wraps it into a COM interface) *) let rec is_dispinterface intf = if intf.intf_name = "IDispatch" then true else if intf.intf_name = "IUnknown" then false else is_dispinterface intf.intf_super let emit_make_interface oc intf = let disp = if is_dispinterface intf then 1 else 0 in fprintf oc "value camlidl_makeintf_%s_%s(value vobj)\n" !module_name intf.intf_name; fprintf oc "{\n"; if intf.intf_uid = "" then fprintf oc " return camlidl_make_interface(&camlidl_%s_%s_vtbl, vobj, NULL, %d);\n" !module_name intf.intf_name disp else fprintf oc " return camlidl_make_interface(&camlidl_%s_%s_vtbl, vobj, &IID_%s, %d);\n" !module_name intf.intf_name intf.intf_name disp; fprintf oc "}\n\n" (* Definition of the translation functions *) let emit_transl oc intf = List.iter (Funct.emit_method_wrapper oc intf.intf_name) intf.intf_methods; List.iter (emit_callback_wrapper oc intf) intf.intf_methods; emit_vtable oc intf; emit_make_interface oc intf (* Declare the translation functions *) let declare_transl oc intf = List.iter (declare_callback_wrapper oc intf) intf.intf_methods camlidl-camlidl109/compiler/intf.mli000066400000000000000000000030761366176261100176140ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: intf.mli,v 1.9 2000-08-19 11:04:57 xleroy Exp $ *) (* Handling of COM-style interfaces *) open Idltypes open Funct type interface = { intf_name: string; (* Name of interface *) intf_mod: string; (* Source module *) mutable intf_super: interface; (* Super-interface *) mutable intf_methods: function_decl list; (* Methods *) mutable intf_uid: string } (* Unique interface ID *) val ml_declaration: out_channel -> interface -> unit val ml_class_declaration: out_channel -> interface -> unit val c_declaration: out_channel -> interface -> unit val ml_class_definition: out_channel -> interface -> unit val emit_transl: out_channel -> interface -> unit val declare_transl: out_channel -> interface -> unit camlidl-camlidl109/compiler/lexer_midl.mli000066400000000000000000000016761366176261100210040ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: lexer_midl.mli,v 1.2 2000-08-19 11:04:57 xleroy Exp $ *) val token: Lexing.lexbuf -> Parser_midl.token exception Lex_error of string camlidl-camlidl109/compiler/lexer_midl.mll000066400000000000000000000131001366176261100207700ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0 *) (* *) (***********************************************************************) (* $Id: lexer_midl.mll,v 1.13 2004-05-12 12:40:40 xleroy Exp $ *) (* Lexer for IDL interface files *) { open Utils open Parse_aux open Parser_midl let keywords = Hashtbl.create 29 let _ = List.iter (fun (txt, kwd) -> Hashtbl.add keywords txt kwd) [ "boolean", BOOLEAN; "byte", BYTE; "case", CASE; "char", CHAR; "const", CONST; "cpp_quote", CPP_QUOTE; "default", DEFAULT; "double", DOUBLE; "enum", ENUM; "false", FALSE; "float", FLOAT; "handle_t", HANDLE_T; "hyper", HYPER; "import", IMPORT; "int", INT; "__int64", INT64_COMPAT; "int8", INT8; "int16", INT16; "int32", INT32; "int64", INT64; "interface", INTERFACE; "long", LONG; "NULL", NULL; "quote", QUOTE; "short", SHORT; "signed", SIGNED; "sizeof", SIZEOF; "small", SMALL; "struct", STRUCT; "switch", SWITCH; "true", TRUE; "typedef", TYPEDEF; "union", UNION; "unsigned", UNSIGNED; "uint8", UINT8; "uint16", UINT16; "uint32", UINT32; "uint64", UINT64; "void", VOID; "wchar_t", WCHAR_T ] let string_buffer = Buffer.create 80 (* To translate escape sequences *) let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let char_for_code lexbuf i j = let s = Lexing.lexeme lexbuf in let s' = String.sub s i (String.length s - i - j) in Char.chr(int_of_string("0o" ^ s')) (* To report lexical errors *) exception Lex_error of string } let blank = [' ' '\010' '\013' '\009' '\012'] let eol = ('\n' | '\r' | "\r\n") let identstart = ['A'-'Z' 'a'-'z' '_'] let identchar = identstart | ['0'-'9'] let decimal_literal = ['0'-'9']+ let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ let octal_literal = '0' ['0'-'7']+ let hex = ['0'-'9' 'a'-'f' 'A'-'F'] let hex4 = hex hex hex hex let hex8 = hex4 hex4 let hex12 = hex4 hex4 hex4 rule token = parse blank + { token lexbuf } | "/*" { comment lexbuf } | "//" [ ^ '\n' ] * eol { token lexbuf } | "#" ("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 Hashtbl.find keywords s with Not_found -> if StringSet.mem s !type_names then TYPEIDENT s else IDENT s } | octal_literal { INTEGER(Int64.of_string("0o" ^ Lexing.lexeme lexbuf)) } | decimal_literal | hex_literal { INTEGER(Int64.of_string(Lexing.lexeme lexbuf)) } | "\"" { Buffer.reset string_buffer; string lexbuf; let s = Buffer.contents string_buffer in Buffer.reset string_buffer; STRING s } | "'" [^ '\\' '\''] "'" { CHARACTER(Lexing.lexeme_char lexbuf 1) } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { CHARACTER(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } | "'" '\\' ['0'-'3'] ['0'-'7']? ['0'-'7']? "'" { CHARACTER(char_for_code lexbuf 2 1) } | "&" { AMPER } | "&&" { AMPERAMPER } | "!" { BANG } | "!=" { BANGEQUAL } | "|" { BAR } | "||" { BARBAR } | "^" { CARET } | ":" { COLON } | "," { COMMA } | "." { DOT } | "=" { EQUAL } | "==" { EQUALEQUAL } | ">" { GREATER } | ">=" { GREATEREQUAL } | ">>" { GREATERGREATER } | "{" { LBRACE } | "[" { LBRACKET } | "<" { LESS } | "<=" { LESSEQUAL } | "<<" { LESSLESS } | "(" { LPAREN } | "%" { PERCENT } | "+" { PLUS } | "}" { RBRACE } | "]" { RBRACKET } | ")" { RPAREN } | ";" { SEMI } | "/" { SLASH } | "*" { STAR } | "~" { TILDE } | "-" { MINUS } | "?" { QUESTIONMARK } | '(' hex8 '-' hex4 '-' hex4 '-' hex4 '-' hex12 ')' { let s = Lexing.lexeme lexbuf in UUID(String.sub s 1 (String.length s - 2)) } | eof { EOF } | _ { raise (Lex_error ("Illegal character " ^ Char.escaped(Lexing.lexeme_char lexbuf 0))) } and comment = parse "*/" { token lexbuf } | _ { comment lexbuf } | eof { raise (Lex_error "Unterminated comment") } and string = parse '"' { () } | '\\' eol [' ' '\009'] * { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { Buffer.add_char string_buffer (char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'3'] ['0'-'7']? ['0'-'7']? { Buffer.add_char string_buffer (char_for_code lexbuf 1 0); string lexbuf } | eof { raise (Lex_error "Unterminated string") } | _ { Buffer.add_char string_buffer (Lexing.lexeme_char lexbuf 0); string lexbuf } camlidl-camlidl109/compiler/lexer_simple.mli000066400000000000000000000016431366176261100213420ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: lexer_simple.mli,v 1.3 2000-08-19 11:04:57 xleroy Exp $ *) val token: Lexing.lexbuf -> Parser_simple.token camlidl-camlidl109/compiler/lexpr.ml000066400000000000000000000375701366176261100176430ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: lexpr.ml,v 1.11 2002-01-16 16:15:32 xleroy Exp $ *) (* Evaluation and pretty-printing of limited expressions *) open Printf open Idltypes open Utils type constant_value = Cst_int of int32 | Cst_long of nativeint | Cst_longlong of int64 | Cst_string of string (* Bind values to constant names *) let const_val = (Hashtbl.create 29 : (string, constant_value) Hashtbl.t) let bind_const name v = Hashtbl.add const_val name v (* Evaluate a limited expression to a constant *) let is_true = function Cst_int n -> n <> Int32.zero | Cst_long n -> n <> Nativeint.zero | Cst_longlong n -> n <> Int64.zero | Cst_string s -> true (*hmph*) let cst_true = Cst_int Int32.one let cst_false = Cst_int Int32.zero let compare rel (v1, v2) = match (v1, v2) with (Cst_int n1, Cst_int n2) -> if rel v1 v2 then cst_true else cst_false | (Cst_long n1, Cst_long n2) -> if rel v1 v2 then cst_true else cst_false | (Cst_longlong n1, Cst_longlong n2) -> if rel v1 v2 then cst_true else cst_false | (_, _) -> error("illegal comparison") let int_val = function Cst_int n -> Int32.to_int n | Cst_long n -> Nativeint.to_int n | Cst_longlong n -> Int64.to_int n | _ -> error "string value in integer context" let int32_val = function Cst_int n -> n | Cst_long n -> Nativeint.to_int32 n | Cst_longlong n -> Int64.to_int32 n | _ -> error "string value in integer context" let nativeint_val = function Cst_int n -> Nativeint.of_int32 n | Cst_long n -> n | Cst_longlong n -> Int64.to_nativeint n | _ -> error "string value in integer context" let int64_val = function Cst_int n -> Int64.of_int32 n | Cst_long n -> Int64.of_nativeint n | Cst_longlong n -> n | _ -> error "string value in integer context" let string_val = function Cst_string s -> s | _ -> error "integer value in string context" (* Expand a typedef name, returning its definition *) let expand_typedef = ref ((fun _ -> assert false) : string -> idltype) let rec cast_value ty v = match ty with Type_int(kind, _) -> begin match kind with Int | UInt -> Cst_int(int32_val v) | Long | ULong -> Cst_long(nativeint_val v) | Hyper | UHyper -> Cst_longlong(int64_val v) | USmall | Char | UChar | Byte | Boolean -> Cst_int(Int32.logand (int32_val v) (Int32.of_int 0xFF)) | Small | SChar -> Cst_int(Int32.shift_right (Int32.shift_left (int32_val v) 24) 24) | Short -> Cst_int(Int32.shift_right (Int32.shift_left (int32_val v) 16) 16) | UShort -> Cst_int(Int32.logand (int32_val v) (Int32.of_int 0xFFFF)) end | Type_pointer(_, Type_int((Char|UChar|SChar), _)) | Type_array({is_string = true}, _) -> Cst_string(string_val v) | Type_named(modname, tyname) -> let ty' = try !expand_typedef tyname with Not_found -> error (sprintf "unknown type name %s" tyname) in cast_value ty' v | Type_const ty' -> cast_value ty' v | _ -> error "unsupported type for constant expression" (* Evaluate a limited expression *) let rec eval = function Expr_ident v -> (try Hashtbl.find const_val v with Not_found -> error (sprintf "%s is not a constant" v)) | Expr_int n -> if n < Int64.of_int32 Int32.max_int && n >= Int64.of_int32 Int32.min_int then Cst_int(Int64.to_int32 n) else if n < Int64.of_nativeint Nativeint.max_int && n >= Int64.of_nativeint Nativeint.min_int then Cst_long(Int64.to_nativeint n) else Cst_longlong n | Expr_string s -> Cst_string s | Expr_cond (e1, e2, e3) -> if is_true(eval e1) then eval e2 else eval e3 | Expr_sequand (e1, e2) -> let v1 = eval e1 in if is_true v1 then eval e2 else v1 | Expr_sequor (e1, e2) -> let v1 = eval e1 in if is_true v1 then v1 else eval e2 | Expr_logor (e1, e2) -> eval_binary Int32.logor Nativeint.logor Int64.logor e1 e2 | Expr_logxor (e1, e2) -> eval_binary Int32.logxor Nativeint.logxor Int64.logxor e1 e2 | Expr_logand (e1, e2) -> eval_binary Int32.logand Nativeint.logand Int64.logand e1 e2 | Expr_eq (e1, e2) -> compare (=) (eval_promote e1 e2) | Expr_ne (e1, e2) -> compare (<>) (eval_promote e1 e2) | Expr_lt (e1, e2) -> compare (<) (eval_promote e1 e2) | Expr_gt (e1, e2) -> compare (>) (eval_promote e1 e2) | Expr_le (e1, e2) -> compare (<=) (eval_promote e1 e2) | Expr_ge (e1, e2) -> compare (>=) (eval_promote e1 e2) | Expr_lshift (e1, e2) -> eval_shift Int32.shift_left Nativeint.shift_left Int64.shift_left e1 e2 | Expr_rshift (e1, e2) -> eval_shift Int32.shift_right Nativeint.shift_right Int64.shift_right e1 e2 | Expr_rshift_unsigned (e1, e2) -> eval_shift Int32.shift_right_logical Nativeint.shift_right_logical Int64.shift_right_logical e1 e2 | Expr_plus (e1, e2) -> eval_binary Int32.add Nativeint.add Int64.add e1 e2 | Expr_minus (e1, e2) -> eval_binary Int32.sub Nativeint.sub Int64.sub e1 e2 | Expr_times (e1, e2) -> eval_binary Int32.mul Nativeint.mul Int64.mul e1 e2 | Expr_div (e1, e2) -> begin try eval_binary Int32.div Nativeint.div Int64.div e1 e2 with Division_by_zero -> error "division by zero" end | Expr_mod (e1, e2) -> begin try eval_binary Int32.rem Nativeint.rem Int64.rem e1 e2 with Division_by_zero -> error "division by zero" end | Expr_neg e1 -> eval_unary Int32.neg Nativeint.neg Int64.neg e1 | Expr_lognot e1 -> eval_unary Int32.lognot Nativeint.lognot Int64.lognot e1 | Expr_boolnot e1 -> if is_true(eval e1) then cst_false else cst_true | Expr_cast(ty, e1) -> cast_value ty (eval e1) | Expr_sizeof ty -> Cst_int(Int32.of_int(match ty with Type_int((Int|UInt), _) -> 4 | Type_int((Long|ULong), _) -> Sys.word_size / 4 | Type_int((Hyper|UHyper), _) -> 8 | Type_int((Small|USmall|Char|UChar|SChar|Byte|Boolean), _) -> 1 | Type_int((Short|UShort), _) -> 2 | Type_float -> 4 | Type_double -> 8 | Type_pointer(_, _) -> Sys.word_size / 4 | _ -> error "cannot compute sizeof")) | _ -> error("illegal operation in constant expression") and eval_promote e1 e2 = let v1 = eval e1 and v2 = eval e2 in match (v1, v2) with | (Cst_int n1, Cst_long n2) -> (Cst_long (Nativeint.of_int32 n1), v2) | (Cst_long n1, Cst_int n2) -> (v1, Cst_long(Nativeint.of_int32 n2)) | (Cst_int n1, Cst_longlong n2) -> (Cst_longlong(Int64.of_int32 n1), v2) | (Cst_longlong n1, Cst_int n2) -> (v1, Cst_longlong(Int64.of_int32 n2)) | (Cst_long n1, Cst_longlong n2) -> (Cst_longlong(Int64.of_nativeint n1), v2) | (Cst_longlong n1, Cst_long n2) -> (v1, Cst_longlong(Int64.of_nativeint n2)) | (_, _) -> (v1, v2) and eval_binary op32 opnative op64 e1 e2 = match eval_promote e1 e2 with (Cst_int n1, Cst_int n2) -> Cst_int(op32 n1 n2) | (Cst_long n1, Cst_long n2) -> Cst_long(opnative n1 n2) | (Cst_longlong n1, Cst_longlong n2) -> Cst_longlong(op64 n1 n2) | (_, _) -> error("non-integer arguments to integer operation") and eval_unary op32 opnative op64 e1 = match eval e1 with Cst_int n1 -> Cst_int(op32 n1) | Cst_long n1 -> Cst_long(opnative n1) | Cst_longlong n1 -> Cst_longlong(op64 n1) | _ -> error("non-integer argument to integer operation") and eval_shift op32 opnative op64 e1 e2 = let n2 = int_val(eval e2) in match eval e1 with Cst_int n1 -> Cst_int(op32 n1 n2) | Cst_long n1 -> Cst_long(opnative n1 n2) | Cst_longlong n1 -> Cst_longlong(op64 n1 n2) | _ -> error("non-integer arguments to integer operation") (* Evaluate a limited expression to an integer *) let eval_int e = int_val(eval e) (* Test if this expression is just an identifier, possibly by reference [*x] *) let is_identifier_deref = function | Expr_ident _ -> true | Expr_deref (Expr_ident _) -> true | _ -> false (* Pretty-print a limited expression *) open Buffer let b = create 80 let rec tstype trail = function Type_int(kind,_) -> add_string b (integer_type kind); add_string b trail | Type_float -> add_string b "float"; add_string b trail | Type_double -> add_string b "double"; add_string b trail | Type_void -> add_string b "void"; add_string b trail | Type_struct sd -> assert (sd.sd_name <> ""); add_string b "struct "; add_string b sd.sd_name; add_string b trail | Type_union(ud, discr) -> assert (ud.ud_name <> ""); add_string b "union "; add_string b ud.ud_name; add_string b trail | Type_enum (en, attr) -> add_string b "int"; add_string b trail | Type_named(modl, ty_name) -> add_string b ty_name; add_string b trail | Type_pointer(attr, (Type_array(_,_) as ty)) -> tstype (sprintf "(*%s)" trail) ty | Type_pointer(attr, ty) -> tstype (sprintf "*%s" trail) ty | Type_array(attr, ty) -> let trail' = match attr.bound with Some n -> sprintf "%s[]" trail | None -> sprintf "*%s" trail in tstype trail' ty | Type_bigarray(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 | Type_const ty -> tstype (sprintf " const %s" trail) ty and integer_type = function Int -> "int" | Long -> "long" | Hyper -> Config.int64_type | Small -> "signed char" | Short -> "short" | Char -> "char" | UInt -> "unsigned int" | ULong -> "unsigned long" | UHyper -> Config.uint64_type | USmall -> "unsigned char" | UShort -> "unsigned short" | UChar -> "unsigned char" | SChar -> "signed char" | Byte -> "unsigned char" | Boolean -> "int" let add_escaped_string s = add_char b '"'; for i = 0 to String.length s - 1 do let c = s.[i] in if c >= ' ' && c <= '~' then add_char b c else add_string b (sprintf "\\%03o" (Char.code c)) done; add_char b '"' let tostr pref e = let rec ts = function Expr_cond(e1, e2, e3) -> ts1 e1; add_string b " ? "; ts1 e2; add_string b " : "; ts1 e3 | e -> ts1 e and ts1 = function Expr_sequor(e1, e2) -> ts2 e1; add_string b " || "; ts2 e2 | Expr_sequand(e1, e2) -> ts2 e1; add_string b " && "; ts2 e2 | e -> ts2 e and ts2 = function Expr_logand(e1, e2) -> ts3 e1; add_string b " & "; ts3 e2 | Expr_logor(e1, e2) -> ts3 e1; add_string b " | "; ts3 e2 | Expr_logxor(e1, e2) -> ts3 e1; add_string b " ^ "; ts3 e2 | e -> ts3 e and ts3 = function Expr_eq(e1, e2) -> ts4 e1; add_string b " == "; ts4 e2 | Expr_ne(e1, e2) -> ts4 e1; add_string b " != "; ts4 e2 | Expr_lt(e1, e2) -> ts4 e1; add_string b " < "; ts4 e2 | Expr_gt(e1, e2) -> ts4 e1; add_string b " > "; ts4 e2 | Expr_le(e1, e2) -> ts4 e1; add_string b " <= "; ts4 e2 | Expr_ge(e1, e2) -> ts4 e1; add_string b " >= "; ts4 e2 | e -> ts4 e and ts4 = function Expr_lshift(e1, e2) -> ts5 e1; add_string b " << "; ts5 e2 | Expr_rshift(e1, e2) -> ts5 e1; add_string b " >> "; ts5 e2 | Expr_rshift_unsigned(e1, e2) -> (*revise!*) ts5 e1; add_string b " >> "; ts5 e2 | e -> ts5 e and ts5 = function Expr_plus(e1, e2) -> ts5 e1; add_string b " + "; ts5 e2 | Expr_minus(e1, e2) -> ts5 e1; add_string b " - "; ts6 e2 | e -> ts6 e and ts6 = function Expr_times(e1, e2) -> ts6 e1; add_string b " * "; ts6 e2 | Expr_div(e1, e2) -> ts6 e1; add_string b " / "; ts7 e2 | Expr_mod(e1, e2) -> ts6 e1; add_string b " % "; ts7 e2 | e -> ts7 e and ts7 = function Expr_neg e -> add_string b "-"; ts7 e | Expr_lognot e -> add_string b "~"; ts7 e | Expr_boolnot e -> add_string b "!"; ts7 e | Expr_deref e -> add_string b "*"; ts7 e | Expr_addressof e -> add_string b "&"; ts7 e | Expr_cast(ty, e) -> add_string b "("; tstype "" ty; add_string b ") "; ts7 e | Expr_sizeof(ty) -> add_string b "sizeof("; tstype "" ty; add_string b ")" | e -> ts8 e and ts8 = function Expr_subscript(e1, e2) -> ts8 e1; add_string b "["; ts e2; add_string b "]" | Expr_dereffield(e1, s) -> ts8 e1; add_string b "->"; add_string b s | Expr_field(e1, s) -> ts8 e1; add_string b "."; add_string b s | e -> ts9 e and ts9 = function Expr_ident s -> begin try match Hashtbl.find const_val s with Cst_int n -> add_string b (Int32.to_string n) | Cst_long n -> add_string b (Nativeint.to_string n); add_char b 'L' | Cst_longlong n -> add_string b (Int64.to_string n); add_string b "LL" | Cst_string s -> add_escaped_string s with Not_found -> add_string b (Prefix.for_ident pref s); add_string b s end | Expr_int n -> add_string b (Int64.to_string n) | Expr_string s -> add_escaped_string s | e -> add_char b '('; ts e; add_char b ')' in ts7 e let tostring pref e = Buffer.clear b; tostr pref e; let res = Buffer.contents b in Buffer.reset b; res let output oc (pref, e) = Buffer.clear b; tostr pref e; Buffer.output_buffer oc b; Buffer.reset b (* Check if a variable is free in a limited expression *) let is_free v e = let rec free = function Expr_ident s -> s = v | Expr_int n -> false | Expr_string s -> false | Expr_cond (e1, e2, e3) -> free e1 || free e2 || free e3 | Expr_sequand (e1, e2) -> free e1 || free e2 | Expr_sequor (e1, e2) -> free e1 || free e2 | Expr_logor (e1, e2) -> free e1 || free e2 | Expr_logxor (e1, e2) -> free e1 || free e2 | Expr_logand (e1, e2) -> free e1 || free e2 | Expr_eq (e1, e2) -> free e1 || free e2 | Expr_ne (e1, e2) -> free e1 || free e2 | Expr_lt (e1, e2) -> free e1 || free e2 | Expr_gt (e1, e2) -> free e1 || free e2 | Expr_le (e1, e2) -> free e1 || free e2 | Expr_ge (e1, e2) -> free e1 || free e2 | Expr_lshift (e1, e2) -> free e1 || free e2 | Expr_rshift (e1, e2) -> free e1 || free e2 | Expr_rshift_unsigned (e1, e2) -> free e1 || free e2 | Expr_plus (e1, e2) -> free e1 || free e2 | Expr_minus (e1, e2) -> free e1 || free e2 | Expr_times (e1, e2) -> free e1 || free e2 | Expr_div (e1, e2) -> free e1 || free e2 | Expr_mod (e1, e2) -> free e1 || free e2 | Expr_neg (e1) -> free e1 | Expr_lognot (e1) -> free e1 | Expr_boolnot (e1) -> free e1 | Expr_deref (e1) -> free e1 | Expr_addressof (e1) -> free e1 | Expr_cast (ty, e1) -> free e1 | Expr_sizeof ty -> false | Expr_subscript (e1, e2) -> free e1 || free e2 | Expr_dereffield (e1, s) -> free e1 | Expr_field (e1, s) -> free e1 in free e let is_free_opt v opte = match opte with None -> false | Some e -> is_free v e (* Check if a variable appears in a dependent type *) 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_bigarray(attr, ty) -> List.exists (fun a -> is_free_opt v a.size || is_free_opt v a.length) attr.dims || is_dependent v ty | Type_union(name, attr) -> is_free v attr.discriminant | Type_pointer(_, ty) -> is_dependent v ty | Type_const ty -> is_dependent v ty | _ -> false camlidl-camlidl109/compiler/lexpr.mli000066400000000000000000000034101366176261100177760ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: lexpr.mli,v 1.5 2002-01-16 16:15:32 xleroy Exp $ *) (* Evaluation and pretty-printing of limited expressions *) open Idltypes type constant_value = Cst_int of int32 | Cst_long of nativeint | Cst_longlong of int64 | Cst_string of string val bind_const: string -> constant_value -> unit val is_true: constant_value -> bool val int_val: constant_value -> int val int32_val: constant_value -> int32 val nativeint_val: constant_value -> nativeint val int64_val: constant_value -> int64 val string_val: constant_value -> string val cast_value: idltype -> constant_value -> constant_value val eval_int: lexpr -> int val eval: lexpr -> constant_value val is_identifier_deref: lexpr -> bool val tostring: Prefix.t -> lexpr -> string val output: out_channel -> Prefix.t * lexpr -> unit val is_free: string -> lexpr -> bool val is_dependent: string -> idltype -> bool (* Expand a typedef name, returning its definition *) val expand_typedef: (string -> idltype) ref camlidl-camlidl109/compiler/linenum.mli000066400000000000000000000031331366176261100203150ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: linenum.mli,v 1.4 2001-06-29 13:30:00 xleroy Exp $ *) (* An auxiliary lexer for determining the line number corresponding to a file position, honoring the directives # linenum "filename" *) val for_position: string -> int -> string * int * int (* [Linenum.for_position file loc] returns a triple describing the location [loc] in the file named [file]. First result is name of actual source file. Second result is line number in that source file. Third result is position of beginning of that line in [file]. *) val print_location: out_channel -> unit (* Print the current location as determined by [for_position]. *) val current_file: string ref val current_lexbuf: Lexing.lexbuf ref (* Name and lexbuf on file currently read *) camlidl-camlidl109/compiler/linenum.mll000066400000000000000000000056121366176261100203240ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0 *) (* *) (***********************************************************************) (* $Id: linenum.mll,v 1.6 2001-06-29 13:30:00 xleroy Exp $ *) (* An auxiliary lexer for determining the line number corresponding to a file position, honoring the directives # linenum "filename" *) { open Printf let filename = ref "" let linenum = ref 0 let linebeg = ref 0 let parse_sharp_line s = try (* Update the line number and file name *) let l1 = ref 0 in while let c = s.[!l1] in c < '0' || c > '9' do incr l1 done; let l2 = ref (!l1 + 1) in while let c = s.[!l2] in c >= '0' && c <= '9' do incr l2 done; linenum := int_of_string(String.sub s !l1 (!l2 - !l1)); let f1 = ref (!l2 + 1) in while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done; let f2 = ref (!f1 + 1) in while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done; if !f1 < String.length s then filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1) with Failure _ | Invalid_argument _ -> assert false } rule skip_line = parse "#" ("line")? [' ' '\t']* ['0'-'9']+ [' ' '\t']* ("\"" [^ '\n' '\r' '"' (* '"' *) ] * "\"")? [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") { parse_sharp_line(Lexing.lexeme lexbuf); linebeg := Lexing.lexeme_start lexbuf; Lexing.lexeme_end lexbuf } | [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") { incr linenum; linebeg := Lexing.lexeme_start lexbuf; Lexing.lexeme_end lexbuf } | [^ '\n' '\r'] * eof { incr linenum; linebeg := Lexing.lexeme_start lexbuf; raise End_of_file } { let for_position file loc = let ic = open_in_bin file in let lb = Lexing.from_channel ic in filename := file; linenum := 1; linebeg := 0; begin try while skip_line lb <= loc do () done with End_of_file -> () end; close_in ic; (!filename, !linenum - 1, !linebeg) let current_file = ref "" let current_lexbuf = ref (Lexing.from_channel stdin) let print_location oc = let pos = Lexing.lexeme_start !current_lexbuf in let (sourcename, lineno, startline) = for_position !current_file pos in fprintf oc "File %s, line %d, column %d" sourcename lineno (pos - startline) } camlidl-camlidl109/compiler/main.ml000066400000000000000000000060251366176261100174240ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: main.ml,v 1.16 2002-04-19 13:24:29 xleroy Exp $ *) open Printf open Clflags open Utils open Idltypes open File let process_file name = let pref = if Filename.check_suffix name ".idl" then Filename.chop_suffix name ".idl" else name in let intf = Normalize.normalize_file name in eval_constants intf; let oc = open_out (pref ^ ".mli") in begin try gen_mli_file oc intf; close_out oc with x -> close_out oc; remove_file (pref ^ ".mli"); raise x end; let oc = open_out (pref ^ ".ml") in begin try gen_ml_file oc intf; close_out oc with x -> close_out oc; remove_file (pref ^ ".ml"); raise x end; 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 ^ "_stubs.c"); raise x end; if !Clflags.gen_header then begin let oc = open_out (pref ^ ".h") in begin try gen_c_header oc intf; close_out oc with x -> close_out oc; remove_file (pref ^ ".h"); raise x end end let _ = try Arg.parse ["-I", Arg.String(fun s -> search_path := !search_path @ [s]), " Add directory to search path"; "-D", Arg.String(fun s -> prepro_defines := !prepro_defines @ [s]), " Pass -D to the C preprocessor"; "-cpp", Arg.Set use_cpp, " Pass the .idl files through the C preprocessor (default)"; "-nocpp", Arg.Clear use_cpp, " Do not pass the .idl files through the C preprocessor"; "-prepro", Arg.String(fun s -> preprocessor := s), " Use as the preprocessor instead of the C preprocessor"; "-header", Arg.Set gen_header, " Generate a .h file containing all type definitions"; "-no-include", Arg.Clear include_header, " Do not #include the .h file in the generated .c file"; "-prefix-all-labels", Arg.Set prefix_all_labels, " Prefix all ML name of record labels with name of enclosing struct"; "-keep-labels", Arg.Set keep_labels, " Do not prefix ML names of record labels, even if ambiguous" ] process_file "Usage: camlidl [options]<.idl file> ... <.idl file>\nOptions are:\n" with Error -> exit 2 camlidl-camlidl109/compiler/normalize.ml000066400000000000000000000217621366176261100205050ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: normalize.ml,v 1.22 2002-01-16 16:15:32 xleroy Exp $ *) (* Normalization of IDL types after parsing *) open Printf open Utils open Idltypes open Typedef open Funct open Constdecl open Intf open File let structs = (Hashtbl.create 13 : (string, struct_decl) Hashtbl.t) let unions = (Hashtbl.create 13 : (string, union_decl) Hashtbl.t) let enums = (Hashtbl.create 13 : (string, enum_decl) Hashtbl.t) let intfs = (Hashtbl.create 13 : (string, interface) Hashtbl.t) let typedefs =(Hashtbl.create 13 : (string, type_decl) Hashtbl.t) let find_typedef s = try Hashtbl.find typedefs s with Not_found -> error("unknown type name " ^ s) let expand_typedef s = (find_typedef s).td_type let _ = Typedef.find := find_typedef; Lexpr.expand_typedef := expand_typedef let all_comps = ref ([] : component list) let currstamp = ref 0 let newstamp () = incr currstamp; !currstamp let in_fundecl = ref false let error_if_fundecl kind = if !in_fundecl then error (sprintf "anonymous %s in function parameters or result type" kind) let make_module_name filename = Filename.chop_extension (Filename.basename filename) type char_class = Narrow | Wide let rec classify_char = function Type_int((Char | UChar | Byte), _) -> Some Narrow | Type_int(UShort, _) -> Some Wide | Type_named(modname, tyname) -> classify_char (expand_typedef tyname) | Type_const ty -> classify_char ty | _ -> None (* Generic function to handle declarations and definitions of struct, unions, enums and interfaces *) let process_declarator kind tbl name sourcedecl proj_contents make_decl update_decl record_decl = if name = "" then begin (* Unnamed definition *) if !in_fundecl then error (sprintf "anonymous %s in function parameters or result type" kind); let newdecl = make_decl() in update_decl newdecl sourcedecl; record_decl newdecl; newdecl end else if proj_contents sourcedecl = [] then begin (* Reference to previous definition, or forward declaration *) try Hashtbl.find tbl name with Not_found -> let newdecl = make_decl() in Hashtbl.add tbl name newdecl; record_decl (make_decl()); (* record with contents still empty *) newdecl end else begin (* Named definition *) let decl = try Hashtbl.find tbl name with Not_found -> let newdecl = make_decl() in Hashtbl.add tbl name newdecl; newdecl in (* Check we're not redefining *) if proj_contents decl <> [] then error (sprintf "redefinition of %s %s" kind name); (* Process the components *) update_decl decl sourcedecl; (* Record the full declaration *) record_decl decl; decl end (* Normalize types and declarators *) let rec normalize_type = function Type_pointer(kind, ty_elt) -> Type_pointer(kind, normalize_type ty_elt) | Type_array(attr, ty_elt) -> begin let norm_ty_elt = normalize_type ty_elt in if not attr.is_string then Type_array(attr, norm_ty_elt) else match classify_char norm_ty_elt with | None -> error "[string] argument applies only to \ char array or pointer to char" | Some Narrow -> Type_array(attr, norm_ty_elt) | Some Wide -> let attr' = {attr with is_string = false; null_terminated = true} in Type_array(attr', norm_ty_elt) end | Type_struct sd -> Type_struct(enter_struct sd) | Type_union(ud, discr) -> Type_union(enter_union ud, discr) | Type_enum (en, attr) -> Type_enum(enter_enum en, attr) | Type_named(_, s) -> begin try let itf = Hashtbl.find intfs s in Type_interface(itf.intf_mod, itf.intf_name) with Not_found -> try let td = Hashtbl.find typedefs s in Type_named(td.td_mod, td.td_name) with Not_found -> error("Unknown type name " ^ s) end | Type_const ty -> Type_const(normalize_type ty) | ty -> ty and normalize_field f = {f with field_typ = normalize_type f.field_typ} and normalize_case c = match c.case_field with None -> c | Some f -> {c with case_field = Some(normalize_field f)} and enter_struct sd = process_declarator "struct" structs sd.sd_name sd (fun sd -> sd.sd_fields) (fun () -> { sd_name = sd.sd_name; sd_mod = !module_name; sd_stamp = 0; sd_fields = [] }) (fun sd' sd -> sd'.sd_stamp <- newstamp(); sd'.sd_fields <- List.map normalize_field sd.sd_fields) (fun sd -> all_comps := Comp_structdecl sd :: !all_comps) and enter_union ud = process_declarator "union" unions ud.ud_name ud (fun ud -> ud.ud_cases) (fun () -> { ud_name = ud.ud_name; ud_mod = !module_name; ud_stamp = 0; ud_cases = [] }) (fun ud' ud -> ud'.ud_stamp <- newstamp(); ud'.ud_cases <- List.map normalize_case ud.ud_cases) (fun ud -> all_comps := Comp_uniondecl ud :: !all_comps) and enter_enum en = process_declarator "enum" enums en.en_name en (fun en -> en.en_consts) (fun () -> { en_name = en.en_name; en_mod = !module_name; en_stamp = 0; en_consts = [] }) (fun en' en -> en'.en_stamp <- newstamp(); en'.en_consts <- en.en_consts) (fun en -> all_comps := Comp_enumdecl en :: !all_comps) let normalize_fundecl fd = current_function := fd.fun_name; in_fundecl := true; let res = { fd with 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 } in in_fundecl := false; current_function := ""; res let normalize_constdecl cd = { cd with cd_type = normalize_type cd.cd_type } let enter_typedecl td = let td' = { td with td_mod = !module_name; td_type = if td.td_abstract then td.td_type else normalize_type td.td_type } in all_comps := Comp_typedecl td' :: !all_comps; Hashtbl.add typedefs td'.td_name td' let enter_interface i = process_declarator "interface" intfs i.intf_name i (fun i -> i.intf_methods) (fun () -> { intf_name = i.intf_name; intf_mod = !module_name; intf_super = i.intf_super; intf_methods = []; intf_uid = "" }) (fun i' i -> let super = try Hashtbl.find intfs i.intf_super.intf_name with Not_found -> error (sprintf "unknown interface %s as super-interface of %s" i.intf_super.intf_name i.intf_name) in i'.intf_uid <- i.intf_uid; i'.intf_super <- super; i'.intf_methods <- List.map normalize_fundecl i.intf_methods) (fun i -> all_comps := Comp_interface i :: !all_comps) let rec normalize_component = function Comp_typedecl td -> enter_typedecl td | Comp_structdecl sd -> ignore(enter_struct sd) | Comp_uniondecl ud -> ignore(enter_union ud) | Comp_enumdecl en -> ignore(enter_enum en) | Comp_fundecl fd -> all_comps := Comp_fundecl(normalize_fundecl fd) :: !all_comps | Comp_constdecl cd -> all_comps := Comp_constdecl(normalize_constdecl cd) :: !all_comps | Comp_diversion(ty, s) -> all_comps := Comp_diversion(ty, s) :: !all_comps | Comp_interface intf -> ignore(enter_interface intf) | Comp_import(filename, comps) -> let name = make_module_name filename in let saved_name = !module_name in module_name := name; let comps' = normalize_components comps in module_name := saved_name; all_comps := Comp_import(name, comps') :: !all_comps and normalize_components comps = let saved_all_comps = !all_comps in all_comps := []; List.iter normalize_component comps; let ac = List.rev !all_comps in all_comps := saved_all_comps; ac (* Main entry point *) let normalize_file filename = Hashtbl.clear structs; Hashtbl.clear unions; Hashtbl.clear enums; Hashtbl.clear intfs; Hashtbl.clear typedefs; List.iter (fun td -> Hashtbl.add typedefs td.td_name td) Predef.typedefs; List.iter (fun i -> Hashtbl.add intfs i.intf_name i) Predef.interfaces; module_name := make_module_name filename; let res = normalize_components (Fixlabels.prefix_file (Parse.read_file filename)) in Hashtbl.clear structs; Hashtbl.clear unions; Hashtbl.clear enums; Hashtbl.clear intfs; res camlidl-camlidl109/compiler/normalize.mli000066400000000000000000000017161366176261100206530ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: normalize.mli,v 1.9 2000-08-19 11:04:57 xleroy Exp $ *) (* Normalization of IDL types after parsing *) val normalize_file: string -> File.components camlidl-camlidl109/compiler/parse.ml000066400000000000000000000046751366176261100176230ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: parse.ml,v 1.7 2002-04-19 14:42:20 xleroy Exp $ *) (* Source parsing *) open Printf open Utils open Linenum let read_source_file sourcename filename = let ic = open_in_bin filename in let lb = Lexing.from_channel ic in let saved_current_file = !Linenum.current_file and saved_current_lexbuf = !Linenum.current_lexbuf in Linenum.current_file := filename; Linenum.current_lexbuf := lb; try let res = Parser_midl.file Lexer_midl.token lb in close_in ic; Linenum.current_file := saved_current_file; Linenum.current_lexbuf := saved_current_lexbuf; res with Parsing.Parse_error -> close_in ic; eprintf "%t: syntax error\n" print_location; raise Error | Lexer_midl.Lex_error msg -> close_in ic; eprintf "%t: %s\n" print_location msg; raise Error let read_file filename = if not !Clflags.use_cpp then read_source_file filename filename else begin let tempfile = Filename.temp_file "camlidl" ".idl" in try if Sys.command (sprintf "%s %s %s %s > %s" !Clflags.preprocessor (String.concat " " (List.map (fun s -> "-I" ^ s) !Clflags.search_path)) (String.concat " " (List.map (fun s -> "-D" ^ s) !Clflags.prepro_defines)) filename tempfile) <> 0 then error "error during preprocessing"; let r = read_source_file filename tempfile in remove_file tempfile; r with x -> remove_file tempfile; raise x end let _ = Parse_aux.read_file := read_file camlidl-camlidl109/compiler/parse.mli000066400000000000000000000016531366176261100177650ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: parse.mli,v 1.4 2000-08-19 11:04:57 xleroy Exp $ *) (* Source parsing *) val read_file: string -> File.components camlidl-camlidl109/compiler/parse_aux.ml000066400000000000000000000500021366176261100204610ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: parse_aux.ml,v 1.20 2004-07-08 09:50:40 xleroy Exp $ *) (* Auxiliary functions for parsing *) open Printf open Cvttyp open Idltypes open Funct open Typedef open Constdecl open Intf open File open Linenum module StringSet = Set.Make(struct type t = string let compare = compare end) let null_attr_var = Expr_string "" let no_bounds = { bound = None; size = None; length = None; is_string = false; maybe_null = false; null_terminated = false } let one_bound n = { no_bounds with bound = Some n } let no_switch = { discriminant = null_attr_var } let no_enum_attr = { bitset = false } let default_ptrkind = Unique (* as per the MIDL specs *) let default_intkind = Iunboxed (* backward compatibility with CamlIDL 1.0 *) let default_longkind = Iunboxed (* backward compatibility with CamlIDL 1.0 *) let pointer_default = ref default_ptrkind let int_default = ref default_intkind let long_default = ref default_longkind (* Apply a size_is or length_is attribute to an array or pointer type *) let rec merge_array_attr merge_fun rexps ty = match (rexps, ty) with ([], _) -> ty | (re :: rem, Type_array(attr, ty_elt)) -> let attr' = if re == null_attr_var then attr else merge_fun attr re in Type_array(attr', merge_array_attr merge_fun rem ty_elt) | (re :: rem, Type_pointer(kind, ty_elt)) -> if re == null_attr_var then Type_pointer(kind, merge_array_attr merge_fun rem ty_elt) else Type_array(merge_fun no_bounds re, merge_array_attr merge_fun rem ty_elt) | (_, Type_bigarray(attr, ty_elt)) -> let dims' = merge_bigarray_dims merge_fun rexps attr.dims in Type_bigarray({attr with dims = dims'}, ty_elt) | (_, Type_const ty') -> Type_const (merge_array_attr merge_fun rexps ty') | (_, _) -> eprintf "%t: Warning: size_is or length_is attribute applied to \ type `%a', ignored.\n" print_location out_c_type ty; ty and merge_bigarray_dims merge_fun rexps dims = match (rexps, dims) with ([], _) -> dims | (_, []) -> eprintf "%t: Warning: too many dimensions in size_is or \ length_is attribute, extra dimensions ignored\n" print_location; [] | (re::res, d::ds) -> merge_fun d re :: merge_bigarray_dims merge_fun res ds (* Convert an array or pointer type to a bigarray type *) let make_bigarray ty = (* Extract "spine" of array / pointer types, with dimensions and type of elements *) let rec extract_spine dims = function Type_pointer(kind, ty) -> extract_spine (no_bounds :: dims) ty | Type_array(attr, ty) -> extract_spine (attr :: dims) ty | Type_const((Type_pointer(_,_) | Type_array(_,_)) as ty') -> extract_spine dims ty' | ty -> (List.rev dims, ty) in let (dims, ty_tail) = extract_spine [] ty in match ty_tail with Type_int(_,_) | Type_float | Type_double | Type_const(Type_int(_,_) | Type_float | Type_double) -> Type_bigarray({dims = dims; fortran_layout = false; malloced = false; bigarray_maybe_null = false}, ty_tail) | _ -> eprintf "%t: Warning: bigarray attribute applied to type `%a', ignored\n" print_location out_c_type ty; ty (* Apply a type-related attribute to a type *) let is_star_attribute name = String.length name >= 1 && name.[0] = '*' let star_attribute name = String.sub name 1 (String.length name - 1) let [@ocaml.warning "-23"] rec apply_type_attribute ty attr = match (attr, ty) with | (("nativeint", _), Type_int((Int|UInt|Long|ULong as kind), _)) -> Type_int(kind, Inative) | (("int32", _), Type_int((Int|UInt|Long|ULong as kind), _)) -> Type_int(kind, I32) | (("int64", _), Type_int((Int|UInt|Long|ULong as kind), _)) -> Type_int(kind, I64) | (("camlint", _), Type_int((Int|UInt|Long|ULong as kind), _)) -> Type_int(kind, Iunboxed) | (("ref", _), Type_pointer(attr, ty_elt)) -> Type_pointer(Ref, ty_elt) | (("unique", _), Type_pointer(attr, ty_elt)) -> Type_pointer(Unique, ty_elt) | (("unique", _), Type_array(attr, ty_elt)) -> begin match attr.bound with None -> Type_array({attr with maybe_null = true}, ty_elt) | Some _ -> eprintf "%t: Warning: `unique' attribute not applicable to array \ of fixed size, ignored\n" print_location; Type_array(attr, ty_elt) end | (("unique", _), Type_bigarray(attr, ty_elt)) -> Type_bigarray({attr with bigarray_maybe_null = true}, ty_elt) | (("ptr", _), Type_pointer(attr, ty_elt)) -> Type_pointer(Ptr, ty_elt) | (("ignore", _), Type_pointer(attr, ty_elt)) -> Type_pointer(Ignore, ty_elt) | (("string", _), Type_array(attr, ty_elt)) -> Type_array({attr with is_string = true}, ty_elt) | (("string", _), Type_pointer(attr, 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) | (("null_terminated", _), Type_pointer(attr, ty_elt)) -> Type_array({no_bounds with null_terminated = true}, ty_elt) | (("size_is", rexps), (Type_array(_, _) | Type_pointer(_, _) | Type_bigarray(_, _))) -> merge_array_attr (fun attr re -> {attr with size = Some re}) rexps ty | (("length_is", rexps), (Type_array(_, _) | Type_pointer(_, _) | Type_bigarray(_, _))) -> merge_array_attr (fun attr re -> {attr with length = Some re}) rexps ty | (("bigarray", _), (Type_array(_, _) | Type_pointer(_, _))) -> make_bigarray ty | (("fortran", _), Type_bigarray(attrs, ty_elt)) -> Type_bigarray({attrs with fortran_layout = true}, ty_elt) | (("managed", _), Type_bigarray(attrs, ty_elt)) -> Type_bigarray({attrs with malloced = true}, ty_elt) | (("switch_is", [rexp]), Type_union(name, attr)) -> Type_union(name, {attr with discriminant = rexp}) | (("switch_is", [rexp]), Type_pointer(attr, Type_union(name, attr'))) -> Type_pointer(attr, Type_union(name, {attr' with discriminant = rexp})) | (("set", _), Type_enum(name, attr)) -> Type_enum(name, {attr with bitset = true}) | ((("context_handle" | "switch_type"), _), _) -> ty (*ignored*) | ((name, rexps), Type_pointer(attr, ty_elt)) when is_star_attribute name -> Type_pointer(attr, apply_type_attribute ty_elt (star_attribute name, rexps)) | ((name, rexps), Type_array(attr, ty_elt)) when is_star_attribute name -> Type_array(attr, apply_type_attribute ty_elt (star_attribute name, rexps)) | (_, Type_const ty') -> Type_const(apply_type_attribute ty' attr) | ((name, _), _) -> eprintf "%t: Warning: attribute `%s' unknown, malformed or not \ applicable here, ignored.\n" print_location name; ty let apply_type_attributes = List.fold_left apply_type_attribute let rec ref_pointer = function Type_pointer(_, ty_elt) -> Type_pointer(Ref, ty_elt) | Type_array(attr, ty_elt) -> Type_array({attr with maybe_null = false}, ty_elt) | Type_const ty -> Type_const(ref_pointer ty) | ty -> ty let make_param attrs tybase decl = let (name, ty) = decl tybase in let rec merge_attributes mode ty = function [] -> let real_mode = match mode with None -> In | Some m -> m in (name, real_mode, ty) | ("in", _) :: rem -> let mode' = match mode with Some InOut -> mode | Some Out -> Some InOut | _ -> Some In in merge_attributes mode' ty rem | ("out", _) :: rem -> let mode' = match mode with Some InOut -> mode | Some In -> Some InOut | _ -> Some Out in let ty' = ref_pointer ty in merge_attributes mode' ty' rem | attr :: rem -> merge_attributes mode (apply_type_attribute ty attr) rem in merge_attributes None ty attrs let make_fun_declaration attrs ty_res name params quotes = 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_ascii label with "call" -> call := Some text | "dealloc" | "free" -> dealloc := Some text | _ -> eprintf "%t: Warning: quote type `%s' unknown, ignoring the quote.\n" print_location label in List.iter parse_quote quotes; 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 -> truename := "get_" ^ name; merge_attributes ty rem | ("propput", _) :: rem -> truename := "put_" ^ name; merge_attributes ty rem | ("propputref", _) :: rem -> 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 = ty_res'; fun_params = params; fun_mlname = !mlname; fun_call = !call; fun_dealloc = !dealloc; fun_blocking = !blocking } let make_field attrs tybase decl = let rec merge_attributes name ty = function [] -> (name, ty) | ("mlname", [Expr_ident s]) :: rem -> merge_attributes s ty rem | attr :: rem -> merge_attributes name (apply_type_attribute ty attr) rem in let (name, raw_ty) = decl tybase in let (mlname, ty) = merge_attributes name raw_ty attrs in { field_name = name; field_mlname = mlname; field_typ = ty } let make_fields attrs tybase decls = List.map (make_field attrs tybase) decls let make_discriminated_union name union_name switch_name switch_type body = let ty_union = Type_union({ud_name = ""; ud_mod = ""; ud_stamp = 0; ud_cases = body}, {discriminant = Expr_ident switch_name}) in { sd_name = name; sd_mod = ""; sd_stamp = 0; sd_fields = [ {field_name = switch_name; field_mlname = switch_name; field_typ = switch_type}; {field_name = union_name; field_mlname = union_name; field_typ = ty_union} ] } let type_names = ref (List.fold_right (fun itf s -> StringSet.add itf.intf_name s) Predef.interfaces (List.fold_right (fun td s -> StringSet.add td.td_name s) Predef.typedefs StringSet.empty)) let make_typedef attrs tybase decls = let rec merge_attributes ty td = function [] -> (ty, td) | ("abstract", _) :: rem -> merge_attributes ty {td with td_abstract = true} rem | ("c2ml", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_c2ml = Some f} rem | ("ml2c", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_ml2c = Some f} rem | ("finalize", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_finalize = Some f} rem | ("compare", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_compare = Some f} rem | ("hash", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_hash = Some f} rem | ("mltype", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_mltype = Some f} rem | ("mltype", [Expr_string f]) :: rem -> merge_attributes ty {td with td_mltype = Some f} rem | ("errorcode", _) :: rem -> merge_attributes ty {td with td_errorcode = true} rem | ("errorcheck", [Expr_ident f]) :: rem -> merge_attributes ty {td with td_errorcheck = Some f} rem | (("handle" | "transmit_as" | "context_handle"), _) :: rem -> merge_attributes ty td rem | attr :: rem -> merge_attributes (apply_type_attribute ty attr) td rem in let merge_definition tybase decl = let (name, ty) = decl tybase in type_names := StringSet.add name !type_names; let td = {td_name = name; td_mod = ""; td_type = Type_void; (* dummy *) td_abstract = false; td_mltype = None; td_c2ml = None; td_ml2c = None; td_finalize = None; td_compare = None; td_hash = None; 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, then use it as the tybase for the others decls. This helps for typedef struct {...} t, *p, ... *) let rec split_decls past = function [] -> (* didn't find a name, use original decls *) List.map (merge_definition tybase) (List.rev past) | decl :: rem -> match decl (Type_named("%", "%")) with (name, Type_named("%", "%")) -> (* Found a name, define it first, and define the others in terms of this name *) merge_definition tybase decl :: List.map (merge_definition (Type_named("", name))) (List.rev past @ rem) | (_, _) -> split_decls (decl :: past) rem in split_decls [] decls let make_const_decl attr ty name v = { cd_name = name; cd_type = apply_type_attributes ty attr; cd_value = v } let update_int_default dfl arg = match arg with [Expr_ident "camlint"] -> dfl := Iunboxed | [Expr_ident "nativeint"] -> dfl := Inative | [Expr_ident "int32"] -> dfl := I32 | [Expr_ident "int64"] -> dfl := I64 | _ -> () let update_defaults attrs = List.iter (function ("pointer_default", [Expr_ident "ref"]) -> pointer_default := Ref | ("pointer_default", [Expr_ident "unique"]) -> pointer_default := Unique | ("pointer_default", [Expr_ident "ptr"]) -> pointer_default := Ptr | ("int_default", arg) -> update_int_default int_default arg | ("long_default", arg) -> update_int_default long_default arg | _ -> ()) attrs let default_stack = ref ([] : (pointer_kind * integer_repr * integer_repr) list) let save_defaults () = default_stack := (!pointer_default, !int_default, !long_default) :: !default_stack let restore_defaults () = match !default_stack with [] -> assert false | (pd, id, ld) :: rem -> pointer_default := pd; int_default := id; long_default := ld; default_stack := rem let make_interface name attrs superintf comps = let obj = ref false in let uid = ref "" in let parse_attr = function ("object", _) -> obj := true | ("uuid", [Expr_string u]) -> uid := u | ("pointer_default", _) -> () (*treated elsewhere*) | ("int_default", _) -> () (*treated elsewhere*) | ("long_default", _) -> () (*treated elsewhere*) | ("local", _) -> () (*ignored*) | ("endpoint", _) -> () (*ignored*) | ("version", _) -> () (*ignored*) | ("implicit_handle", _) -> () (*ignored*) | ("auto_handle", _) -> () (*ignored*) | (name, _) -> eprintf "%t: Warning: attribute `%s' unknown, malformed or not \ applicable here, ignored.\n" print_location name in List.iter parse_attr attrs; let supername = match superintf with None -> if not !obj then "" else begin eprintf "%t: Warning: no super-interface for interface `%s', \ assuming IUnknown.\n" print_location name; "IUnknown" end | Some s -> if !obj then s else begin eprintf "%t: Warning: interface `%s' is not an object interface, \ ignoring super-interface `%s'.\n" print_location name s; "" end in if not !obj then List.rev comps else begin (* This is an object interface: split into methods and other definitions, lift the definitions out, build an interface from the methods *) let rec split_comps = function [] -> ([], []) | Comp_fundecl fd :: rem -> let (m, o) = split_comps rem in (fd :: m, o) | comp :: rem -> let (m, o) = split_comps rem in (m, comp :: o) in let (methods, others) = split_comps comps in let rec super = (* dummy super interface, only intf_name is used *) { intf_name = supername; intf_mod = ""; intf_super = super; intf_methods = []; intf_uid = "" } in let intf_forward = { intf_name = name; intf_mod = ""; intf_super = super; intf_methods = []; intf_uid = "" } in let intf = { intf_name = name; intf_mod = ""; intf_super = super; intf_methods = methods; intf_uid = !uid } in type_names := StringSet.add name !type_names; Comp_interface intf :: others @ [Comp_interface intf_forward] end let make_forward_interface name = let rec intf = { intf_name = name; intf_mod = ""; intf_super = intf; intf_methods = []; intf_uid = "" } in Comp_interface intf let make_diversion (id, txt) = let kind = match String.lowercase_ascii id with "" | "c" -> Div_c | "h" -> Div_h | "ml" -> Div_ml | "mli" -> Div_mli | "mlmli" -> Div_ml_mli | _ -> eprintf "%t: Warning: diversion kind `%s' unknown, assuming C kind.\n" print_location id; Div_c in (kind, txt) (* Build an integer type *) let make_int kind = match kind with Int | UInt -> Type_int(kind, !int_default) | Long | ULong -> Type_int(kind, !long_default) | Hyper | UHyper -> Type_int(kind, I64) | k -> Type_int(kind, Iunboxed) (* small int types always unboxed *) (* Apply an "unsigned" or "signed" modifier to an integer type *) let make_unsigned kind = make_int (match kind with Int -> UInt | Long -> ULong | Hyper -> UHyper | Small -> USmall | Short -> UShort | Char -> UChar | SChar -> UChar | k -> k) let make_signed kind = make_int (match kind with UInt -> Int | ULong -> Long | UHyper -> Hyper | USmall -> Small | UShort -> Short | Char -> SChar | UChar -> SChar | k -> k) (* Warn about the handle_t type *) let handle_t_type() = eprintf "%t: Warning: type `handle_t' unsupported, \ treating as an opaque pointer.\n" print_location; Type_pointer(Ptr, Type_int(Int, Iunboxed)) (* Warn about the wchar_t type *) let wchar_t_type() = eprintf "%t: Warning: type `wchar_t' unsupported, treating as `char'.\n" print_location; Type_int(Char, Iunboxed) (* Apply a "star" modifier to an attribute *) let make_star_attribute (name, args) = ("*" ^ name, args) (* Add a "const" modifier to a type *) let make_type_const ty = match ty with Type_const _ -> eprintf "%t: Warning: multiple `const' modifiers on a type.\n" print_location; ty | _ -> Type_const ty let make_noncaps_labels lbls fld = let lbls' = List.fold_right (fun lbl acc -> match lbl with Expr_ident s -> s :: acc | i -> Utils.error "Numeric union case not implemented.\n") lbls [] in {case_labels = lbls'; case_field = fld} (* Forward declaration for Parse.read_file *) let read_file = ref ((fun _ -> assert false) : string -> File.components) (* Read an import if not already done *) let imports = ref StringSet.empty let read_imports names = List.fold_right (fun name acc -> if StringSet.mem name !imports then acc else begin imports := StringSet.add name !imports; Comp_import(name, !read_file name) :: acc end) names [] camlidl-camlidl109/compiler/parse_aux.mli000066400000000000000000000106121366176261100206350ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: parse_aux.mli,v 1.10 2002-01-16 16:15:33 xleroy Exp $ *) (* Auxiliary functions for parsing *) open Idltypes open Funct open Typedef open File module StringSet : Set.S with type elt = string val null_attr_var : lexpr (* Represents missing attr var in attributes such as size_is(,f) *) val no_bounds : array_attributes (* Array type without bounds *) val one_bound : lexpr -> array_attributes (* Array type with upper bound *) val no_switch : union_attributes (* Represents an unknown switch for an union *) val no_enum_attr : enum_attributes (* Default attributes for enums *) val pointer_default : pointer_kind ref (* Default pointer kind *) val int_default : integer_repr ref val long_default : integer_repr ref (* Default integer representation for "int" and "long" types *) val make_param : (string * lexpr list) list -> idltype -> (idltype -> string * idltype) -> string * in_out * idltype (* Build a function parameter *) val make_fun_declaration : (string * lexpr list) list -> idltype -> string -> (string * in_out * idltype) list -> (string * string) list -> function_decl (* Build a function declaration *) val make_field : (string * lexpr list) list -> idltype -> (idltype -> string * idltype) -> field (* Build a field declaration *) val make_fields : (string * lexpr list) list -> idltype -> (idltype -> string * idltype) list -> field list (* Build a list of field declarations *) val make_discriminated_union : string -> string -> string -> idltype -> union_case list -> struct_decl (* Convert a union switch(...) into a struct encapsulating an union *) val type_names : StringSet.t ref (* The set of type names (defined by typedef or interface) seen so far *) val make_typedef : (string * lexpr list) list -> idltype -> (idltype -> string * idltype) list -> type_decl list (* Build a typedef declaration *) val make_const_decl : (string * lexpr list) list -> idltype -> string -> lexpr -> Constdecl.constant_decl (* Build a constant declaration *) val update_defaults : (string * lexpr list) list -> unit (* Update [!pointer_default], [!int_default] and [!long_default] according to the given attr list *) val save_defaults : unit -> unit val restore_defaults : unit -> unit (* Save or restore the current defaults on a stack *) val make_interface : string -> (string * lexpr list) list -> string option -> components -> components (* Build an interface declaration *) val make_forward_interface : string -> component (* Build a forward declaration for an interface *) val make_diversion : string * string -> diversion_type * string (* Represent a diversion *) val make_int : integer_kind -> idltype (* Build an integer type (without [signed] or [unsigned] modifier) *) val make_unsigned : integer_kind -> idltype (* Build an integer type (with explicit [unsigned] modifier) *) val make_signed : integer_kind -> idltype (* Build an integer type (with explicit [signed] modifier) *) val handle_t_type : unit -> idltype val wchar_t_type : unit -> idltype (* Warn about unsupported types [handle_t] and [wchar_t] *) val make_star_attribute : string * 'a -> string * 'a (* Apply a [*] modifier to an attribute *) val make_type_const : idltype -> idltype (* Add a "const" modifier to a type *) val make_noncaps_labels : lexpr list -> field option -> union_case (* Represent labels of nonencapsulated unions *) val read_file : (string -> components) ref (* Forward declaration of [Parse.read_file] *) val read_imports : string list -> components (* Read import files *) camlidl-camlidl109/compiler/parser_midl.mly000066400000000000000000000430431366176261100211730ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0 */ /* */ /***********************************************************************/ /* $Id: parser_midl.mly,v 1.19 2002-04-19 14:42:35 xleroy Exp $ */ /* Parser for Microsoft IDL */ %{ open Printf open Cvttyp open Idltypes open Funct open Typedef open Constdecl open Intf open File open Parse_aux %} /* Tokens */ %token AMPER %token AMPERAMPER %token BANG %token BANGEQUAL %token BAR %token BARBAR %token BOOLEAN %token BYTE %token CARET %token CASE %token CHAR %token CHARACTER %token COLON %token COMMA %token CONST %token CPP_QUOTE %token DEFAULT %token DOT %token DOUBLE %token ENUM %token EOF %token EQUAL %token EQUALEQUAL %token FALSE %token FLOAT %token GREATER %token GREATEREQUAL %token GREATERGREATER %token GREATERGREATERGREATER %token HANDLE_T %token HYPER %token IDENT %token IMPORT %token INT %token INT8 %token INT16 %token INT32 %token INT64 %token INT64_COMPAT %token INTERFACE %token INTEGER %token LBRACE %token LBRACKET %token LESS %token LESSEQUAL %token LESSLESS %token LONG %token LPAREN %token MINUS %token NULL %token PERCENT %token PLUS %token QUESTIONMARK %token QUOTE %token RBRACE %token RBRACKET %token RPAREN %token SEMI %token SHORT %token SIGNED %token SIZEOF %token SLASH %token SMALL %token STAR %token STRING %token STRUCT %token SWITCH %token TILDE %token TRUE %token TYPEDEF %token TYPEIDENT %token UINT8 %token UINT16 %token UINT32 %token UINT64 %token UNION %token UNSIGNED %token UUID %token VOID %token WCHAR_T /* Precedences and associativities. Lower precedences come first. */ %right QUESTIONMARK prec_conditional %left BARBAR %left AMPERAMPER %left BAR %left CARET %left AMPER %left EQUALEQUAL BANGEQUAL %left LESS LESSEQUAL GREATER GREATEREQUAL %left LESSLESS GREATERGREATER GREATERGREATERGREATER %left PLUS MINUS %left STAR SLASH PERCENT %right prec_uminus BANG TILDE prec_deref prec_addressof prec_cast %left DOT prec_dot MINUSGREATER LBRACKET prec_subscript /* Start symbol */ %start file %type file %% /* Main entry point */ file: component_list EOF { List.rev $1 } ; /* Components */ component_list: /*empty*/ { [] } | component_list component { $2 @ $1 } ; component: const_decl SEMI { [Comp_constdecl $1] } | type_decl SEMI { List.map (fun td -> Comp_typedecl td) (List.rev $1) } | attributes struct_declarator SEMI /* Attributes are ignored, they are allowed just to avoid a parsing ambiguity with fun_decl */ { [Comp_structdecl $2] } | attributes union_declarator SEMI { [Comp_uniondecl $2] } | attributes enum_declarator SEMI { [Comp_enumdecl $2] } | attributes STRUCT opt_ident SEMI { [Comp_structdecl {sd_name = $3; sd_mod = ""; sd_stamp = 0; sd_fields = []}] } | attributes UNION opt_ident SWITCH LPAREN simple_type_spec ident RPAREN SEMI { [Comp_structdecl {sd_name = $3; sd_mod = ""; sd_stamp = 0; sd_fields = []}] } | attributes UNION opt_ident SEMI { [Comp_uniondecl {ud_name = $3; ud_mod = ""; ud_stamp = 0; ud_cases = []}] } | fun_decl SEMI { [Comp_fundecl $1] } | interface_attributes INTERFACE tydef_ident opt_superinterface LBRACE component_list RBRACE opt_semi /* Valid MIDL attributes: object uuid local endpoint version pointer_default implicit_handle auto_handle */ { let i = make_interface $3 $1 $4 (List.rev $6) in restore_defaults(); i } | interface_attributes INTERFACE tydef_ident SEMI { let i = [make_forward_interface $3] in restore_defaults(); i } | IMPORT imports SEMI { read_imports $2 } | quote opt_semi { let (kind, txt) = make_diversion $1 in [Comp_diversion(kind, txt)] } ; /* Import directive */ imports: STRING { [$1] } | imports COMMA STRING { $3 :: $1 } /* Constant declaration */ const_decl: CONST attributes type_spec pointer_opt IDENT EQUAL lexpr { make_const_decl $2 ($4 $3) $5 $7 } ; /* Typedef */ type_decl: /* Valid MIDL attributes: handle, switch_type, switch_is, transmit_as, ref, unique, ptr, context_handle, ignore, string */ TYPEDEF attributes type_spec declarators { make_typedef $2 $3 (List.rev $4) } ; /* Function declaration */ fun_decl: /* Valid MIDL attributes: callback, local, ref, unique, ptr, string, ignore, context_handle */ attributes type_spec pointer_opt IDENT LPAREN param_list_declarator RPAREN opt_quotes { make_fun_declaration $1 ($3 $2) $4 $6 $8 } ; opt_quotes: opt_quotes QUOTE LPAREN STRING RPAREN { ("call", $4) :: $1 } | opt_quotes QUOTE LPAREN ident COMMA STRING RPAREN { ($4, $6) :: $1 } | /* empty */ { [] } ; /* Parameter lists */ param_list_declarator: /*empty*/ { [] } | VOID { [] } | param_declarators { List.rev $1 } ; param_declarators: param_declarator { [$1] } | param_declarators COMMA param_declarator { $3 :: $1 } ; 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 */ attributes type_spec declarator { make_param $1 $2 $3 } ; /* Type specifications */ type_spec: simple_type_spec { $1 } | STRUCT opt_ident { Type_struct {sd_name=$2; sd_mod = ""; sd_stamp=0; sd_fields=[]} } | struct_declarator { Type_struct $1 } | UNION opt_ident { Type_union({ud_name=$2; ud_mod = ""; ud_stamp=0; ud_cases=[]}, no_switch) } | union_declarator { Type_union($1, no_switch) } | ENUM opt_ident { Type_enum({en_name=$2; en_mod = ""; en_stamp=0; en_consts=[]}, no_enum_attr) } | enum_declarator { Type_enum($1, no_enum_attr) } | CONST type_spec { make_type_const $2 } | type_spec CONST { make_type_const $1 } ; simple_type_spec: FLOAT { Type_float } | DOUBLE { Type_double } | INT { make_int Int } | UNSIGNED INT { make_int UInt } | SIGNED INT { make_int Int } | integer_size opt_int { make_int $1 } | UNSIGNED integer_size opt_int { make_unsigned $2 } | integer_size UNSIGNED opt_int { make_unsigned $1 } | SIGNED integer_size opt_int { make_signed $2 } | integer_size SIGNED opt_int { make_signed $1 } | CHAR { make_int Char } | UNSIGNED CHAR { make_int UChar } | SIGNED CHAR { make_int SChar } | BOOLEAN { make_int Boolean } | BYTE { make_int Byte } | INT64_COMPAT { make_int Hyper } | UNSIGNED INT64_COMPAT { make_int UHyper } | SIGNED INT64_COMPAT { make_int Hyper } | VOID { Type_void } | TYPEIDENT { Type_named("", $1) } | WCHAR_T { wchar_t_type() } | HANDLE_T { handle_t_type() } | integer_fixed { make_int $1 } ; integer_size: LONG { Long } | SMALL { Small } | SHORT { Short } | HYPER { Hyper } | LONG LONG { Hyper } ; integer_fixed: INT8 { Small } | INT16 { Short } | INT32 { Long } | INT64 { Hyper } | UINT8 { USmall } | UINT16 { UShort } | UINT32 { ULong } | UINT64 { UHyper } ; opt_int: /* nothing */ { () } | INT { () } ; /* Declarators */ declarators: declarator { [$1] } | declarators COMMA declarator { $3 :: $1 } ; declarator: pointer_opt direct_declarator { fun ty -> $2($1(ty)) } ; pointer_opt: /* empty */ { fun ty -> ty } | pointer_opt STAR { fun ty -> $1(Type_pointer(!pointer_default, ty)) } | pointer_opt STAR CONST { fun ty -> $1(Type_const(Type_pointer(!pointer_default, ty))) } ; direct_declarator: ident { fun ty -> ($1, ty) } | LPAREN declarator RPAREN { $2 } | direct_declarator array_bounds_declarator { fun ty -> let (id, ty1) = $1 ty in (id, Type_array($2, ty1)) } ; array_bounds_declarator: LBRACKET RBRACKET { no_bounds } | LBRACKET STAR RBRACKET { no_bounds } | LBRACKET lexpr RBRACKET { one_bound $2 } ; /* Struct declaration and discriminated unions */ union_name: ident { $1 } | /* empty */ { "u" } ; struct_declarator: STRUCT opt_ident LBRACE field_declarators RBRACE { {sd_name = $2; sd_mod = ""; sd_stamp = 0; sd_fields = $4} } | UNION opt_ident SWITCH LPAREN simple_type_spec ident RPAREN union_name LBRACE union_body RBRACE { make_discriminated_union $2 $8 $6 $5 (List.rev $10) } ; field_declarators: field_declarator { $1 } | field_declarators field_declarator { $1 @ $2 } ; field_declarator: /* Valid MIDL attributes: first_is, last_is, length_is, max_is, size_is, string, ignore, context_handle, ref, unique, ptr, switch_type */ attributes type_spec declarators SEMI { make_fields $1 $2 (List.rev $3) } ; /* Union declaration */ union_declarator: | UNION opt_ident LBRACE union_body RBRACE { {ud_name = $2; ud_mod = ""; ud_stamp = 0; ud_cases = List.rev $4} } ; union_body: union_encaps_body { $1 } | union_noncaps_body { $1 } ; union_encaps_body: union_encaps_case { [$1] } | union_encaps_body union_encaps_case { $2 :: $1 } ; union_encaps_case: case_list opt_field_declarator SEMI { {case_labels = List.rev $1; case_field = $2} } | DEFAULT COLON opt_field_declarator SEMI { {case_labels = []; case_field = $3} } ; case_list: case_label { [$1] } | case_list case_label { $2 :: $1 } ; case_label: CASE ident COLON { $2 } ; union_noncaps_body: union_noncaps_case { [$1] } | union_noncaps_body union_noncaps_case { $2 :: $1 } ; union_noncaps_case: LBRACKET CASE LPAREN attr_vars RPAREN RBRACKET opt_field_declarator SEMI { make_noncaps_labels $4 $7 } | LBRACKET DEFAULT RBRACKET opt_field_declarator SEMI { {case_labels = []; case_field = $4} } ; opt_field_declarator: /* empty */ { None } | attributes type_spec declarator /* Valid MIDL attributes: first_is, last_is, length_is, max_is, size_is, string, ignore, context_handle, ref, unique, ptr, switch_type, switch_is */ { Some(make_field $1 $2 $3) } ; /* Enumerated types */ enum_declarator: ENUM opt_ident LBRACE enum_cases opt_comma RBRACE { {en_name = $2; en_mod = ""; en_stamp = 0; en_consts = List.rev $4} } ; enum_cases: enum_case { [$1] } | enum_cases COMMA enum_case { $3 :: $1 } ; enum_case: ident { {const_name = $1; const_val = None} } | ident EQUAL lexpr { {const_name = $1; const_val = Some $3} } ; opt_comma: COMMA { () } | /* empty */ { () } ; /* Attributes */ interface_attributes: attributes { let a = $1 in save_defaults(); update_defaults a; a } ; attributes: /* empty */ { [] } | LBRACKET attribute_list RBRACKET { List.rev $2 } ; attribute_list: attribute { [$1] } | /*empty*/ { [] } | attribute_list COMMA attribute { $3 :: $1 } | attribute_list COMMA { $1 } ; attribute: ident { ($1, []) } | compat_int32_64 { ($1, []) } | ident LPAREN attr_vars RPAREN { ($1, List.rev $3) } | STAR attribute { make_star_attribute $2 } | attribute STAR { make_star_attribute $1 } | ident UUID { ($1, [Expr_string $2]) } ; attr_vars: attr_var { [$1] } | attr_vars COMMA attr_var { $3 :: $1 } ; attr_var: lexpr { $1 } | /*nothing*/ { null_attr_var } ; /* Limited expressions */ lexpr: IDENT { Expr_ident $1 } | compat_int32_64 { Expr_ident $1 } | INTEGER { Expr_int $1 } | CHARACTER { Expr_int(Int64.of_int(Char.code $1)) } | TRUE { Expr_int Int64.one } | FALSE { Expr_int Int64.zero } | STRING { Expr_string $1 } | lexpr QUESTIONMARK lexpr COLON lexpr %prec prec_conditional { Expr_cond($1, $3, $5) } | lexpr BARBAR lexpr { Expr_sequor($1, $3) } | lexpr AMPERAMPER lexpr { Expr_sequand($1, $3) } | lexpr BAR lexpr { Expr_logor($1, $3) } | lexpr CARET lexpr { Expr_logxor($1, $3) } | lexpr AMPER lexpr { Expr_logand($1, $3) } | lexpr EQUALEQUAL lexpr { Expr_eq($1, $3) } | lexpr BANGEQUAL lexpr { Expr_ne($1, $3) } | lexpr LESS lexpr { Expr_lt($1, $3) } | lexpr GREATER lexpr { Expr_gt($1, $3) } | lexpr LESSEQUAL lexpr { Expr_le($1, $3) } | lexpr GREATEREQUAL lexpr { Expr_ge($1, $3) } | lexpr LESSLESS lexpr { Expr_lshift($1, $3) } | lexpr GREATERGREATER lexpr { Expr_rshift($1, $3) } | lexpr GREATERGREATERGREATER lexpr { Expr_rshift_unsigned($1, $3) } | lexpr PLUS lexpr { Expr_plus($1, $3) } | lexpr MINUS lexpr { Expr_minus($1, $3) } | lexpr STAR lexpr { Expr_times($1, $3) } | lexpr SLASH lexpr { Expr_div($1, $3) } | lexpr PERCENT lexpr { Expr_mod($1, $3) } | PLUS lexpr %prec prec_uminus { $2 } | MINUS lexpr %prec prec_uminus { Expr_neg($2) } | TILDE lexpr { Expr_lognot($2) } | BANG lexpr { Expr_boolnot($2) } | STAR lexpr %prec prec_deref { Expr_deref($2) } | AMPER lexpr %prec prec_addressof { Expr_addressof($2) } | LPAREN type_expr RPAREN lexpr %prec prec_cast { Expr_cast($2, $4) } | SIZEOF LPAREN type_expr RPAREN { Expr_sizeof($3) } | lexpr LBRACKET lexpr RBRACKET %prec prec_subscript { Expr_subscript($1, $3) } | lexpr MINUSGREATER ident { Expr_dereffield($1, $3) } | lexpr DOT ident %prec prec_dot { Expr_field($1, $3) } | lexpr DOT INTEGER %prec prec_dot /* This is a hack for parsing version attributes, e.g. version(0.1) */ { Expr_field($1, Int64.to_string $3) } | LPAREN lexpr RPAREN { $2 } ; type_expr: type_spec { $1 } | type_spec abstract_declarator { $2($1) } ; abstract_declarator: STAR { fun ty -> Type_pointer(!pointer_default, ty) } | STAR direct_abstract_declarator { fun ty -> $2(Type_pointer(!pointer_default, ty)) } | direct_abstract_declarator { $1 } ; direct_abstract_declarator: LPAREN abstract_declarator RPAREN { $2 } | direct_abstract_declarator array_bounds_declarator { fun ty -> Type_array($2, ty) } ; /* Optional names for struct, union, enums */ opt_ident: /*empty*/ { "" } | ident { $1 } ; /* Optional name of superinterface for interfaces */ opt_superinterface: /*empty*/ { None } | COLON ident { Some $2 } ; /* Optional semicolon */ opt_semi: SEMI { () } | /*empty*/ { () } ; /* Any ident (type or not) */ ident: IDENT { $1 } | TYPEIDENT { $1 } ; compat_int32_64: | INT32 { "int32" } | INT64 { "int64" } ; /* An ident that becomes a type name */ tydef_ident: ident { type_names := StringSet.add $1 !type_names; $1 } ; /* Quotes (diversions) */ quote: QUOTE LPAREN STRING RPAREN { ("", $3) } | QUOTE LPAREN ident COMMA STRING RPAREN { ($3, $5) } | CPP_QUOTE LPAREN STRING RPAREN { ("h", $3) } ; camlidl-camlidl109/compiler/predef.ml000066400000000000000000000051451366176261100177470ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: predef.ml,v 1.6 2002-04-19 13:24:29 xleroy Exp $ *) (* Predefined types and interfaces *) open Idltypes open Typedef open Intf let hresult = { td_name = "HRESULT"; td_mod = "Com"; td_type = Type_int(Long, Iunboxed); td_abstract = false; td_c2ml = None; td_ml2c = None; td_finalize = None; td_compare = None; td_hash = None; td_errorcode = true; td_errorcheck = Some "camlidl_check_hresult"; td_mltype = None } let hresult_bool = { td_name = "HRESULT_bool"; td_mod = "Com"; td_type = Type_int(Long, Iunboxed); td_abstract = false; td_c2ml = None; td_ml2c = None; td_finalize = None; td_compare = None; td_hash = None; td_errorcode = false; td_errorcheck = Some "camlidl_check_hresult"; td_mltype = Some "bool" } let hresult_int = { td_name = "HRESULT_int"; td_mod = "Com"; td_type = Type_int(Long, Iunboxed); td_abstract = false; td_c2ml = None; td_ml2c = None; td_finalize = None; td_compare = None; td_hash = None; td_errorcode = false; td_errorcheck = Some "camlidl_check_hresult"; td_mltype = Some "int" } let bstr = { td_name = "BSTR"; td_mod = "Com"; td_type = Type_int(Long, Iunboxed); td_abstract = false; td_c2ml = None; td_ml2c = None; td_finalize = None; td_compare = None; td_hash = None; td_errorcode = false; td_errorcheck = None; td_mltype = Some "string" } let rec iunknown = { intf_name = "IUnknown"; intf_mod = "Com"; intf_super = iunknown; intf_methods = []; intf_uid = "00000000-0000-0000-C000-000000000046" } let idispatch = { intf_name = "IDispatch"; intf_mod = "Com"; intf_super = iunknown; intf_methods = []; intf_uid = "00020400-0000-0000-C000-000000000046" } let typedefs = [hresult; hresult_bool; hresult_int; bstr] let interfaces = [iunknown; idispatch] camlidl-camlidl109/compiler/predef.mli000066400000000000000000000017351366176261100201210ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: predef.mli,v 1.3 2000-08-19 11:04:58 xleroy Exp $ *) (* Predefined types and interfaces *) val typedefs: Typedef.type_decl list val interfaces: Intf.interface list camlidl-camlidl109/compiler/prefix.ml000066400000000000000000000027611366176261100200000ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: prefix.ml,v 1.1 2002-01-16 09:42:03 xleroy Exp $ *) open Idltypes open Utils module StringMap = Map.Make(struct type t = string let compare = compare end) type t = string StringMap.t let empty = StringMap.empty let enter_function params = List.fold_left (fun e (name, _, _) -> StringMap.add name "" e) StringMap.empty params let enter_struct pref sd base = let base' = base ^ "." in List.fold_left (fun e f -> StringMap.add f.field_name base' e) StringMap.empty sd.sd_fields let for_ident pref id = try StringMap.find id pref with Not_found -> error (Printf.sprintf "Illegal reference to dependent variable %s. This variable is not in scope." id) camlidl-camlidl109/compiler/prefix.mli000066400000000000000000000020311366176261100201370ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: prefix.mli,v 1.1 2002-01-16 09:42:03 xleroy Exp $ *) open Idltypes type t val empty: t val enter_function: (string * 'a * 'b) list -> t val enter_struct: t -> struct_decl -> string -> t val for_ident: t -> string -> string camlidl-camlidl109/compiler/struct.ml000066400000000000000000000113771366176261100200320ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: struct.ml,v 1.15 2004-07-08 09:55:09 xleroy Exp $ *) (* Handling of structures *) open Printf open Utils open Variables open Idltypes open Cvttyp (* Remove dependent fields (fields that are size_is, length_is, or switch_is of another field). Also remove ignored pointers. *) let is_dependent_field name fields = List.exists (fun f -> Lexpr.is_dependent name f.field_typ) fields let remove_dependent_fields fields = list_filter (fun f -> not (is_dependent_field f.field_name fields || is_ignored f.field_typ)) fields (* Determine if all fields of a struct are floats *) let rec is_float_field f = match scrape_type f.field_typ with Type_float -> true | Type_double -> true | _ -> false let all_float_fields fl = List.for_all is_float_field fl (* Translation from an ML record [v] to a C struct [c] *) (* [sd] is the IDL declaration for the record type. *) let struct_ml_to_c ml_to_c oc onstack pref sd v c = let pref' = Prefix.enter_struct pref sd c in match remove_dependent_fields sd.sd_fields with [f] -> ml_to_c oc onstack pref' f.field_typ v (sprintf "%s.%s" c f.field_name); List.iter (fun f -> if is_ignored f.field_typ then iprintf oc "%s.%s = NULL;\n" c f.field_name) sd.sd_fields | _ -> if all_float_fields sd.sd_fields then begin let rec convert_fields pos = function [] -> () | f :: rem -> iprintf oc "%s.%s = Double_field(%s, %d);\n" c f.field_name v pos; convert_fields (pos + 1) rem in convert_fields 0 sd.sd_fields end else begin let rec convert_fields pos = function [] -> () | {field_typ = ty; field_name = n} :: rem -> if is_ignored ty then begin iprintf oc "%s.%s = NULL;\n" c n; convert_fields pos rem end else if is_dependent_field n sd.sd_fields then convert_fields pos rem else begin let v' = new_ml_variable() in iprintf oc "%s = Field(%s, %d);\n" v' v pos; ml_to_c oc onstack pref' ty v' (sprintf "%s.%s" c n); convert_fields (pos + 1) rem end in convert_fields 0 sd.sd_fields end (* Translation from a C pointer struct [c] to an ML record [v]. [sd] is the IDL declaration for the record type. *) let struct_c_to_ml c_to_ml oc pref sd c v = let pref' = Prefix.enter_struct pref sd c in match remove_dependent_fields sd.sd_fields with [f] -> c_to_ml oc pref' f.field_typ (sprintf "%s.%s" c f.field_name) v | fields -> let nfields = List.length fields in if all_float_fields sd.sd_fields then begin iprintf oc "%s = camlidl_alloc_small(%d * Double_wosize, Double_tag);\n" v nfields; let rec convert_fields pos = function [] -> () | f :: rem -> 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 let v' = new_ml_variable_block nfields in init_value_block oc v' nfields; iprintf oc "Begin_roots_block(%s, %d)\n" v' nfields; increase_indent(); let rec convert_fields pos = function [] -> () | {field_typ = ty; field_name = n} :: rem -> if is_ignored ty then convert_fields pos rem else if is_dependent_field n sd.sd_fields then convert_fields pos rem else begin c_to_ml oc pref' ty (sprintf "%s.%s" c n) (sprintf "%s[%d]" v' pos); convert_fields (pos + 1) rem end in convert_fields 0 sd.sd_fields; iprintf oc "%s = camlidl_alloc_small(%d, 0);\n" v nfields; copy_values_to_block oc v' v nfields; decrease_indent(); iprintf oc "End_roots()\n" end camlidl-camlidl109/compiler/struct.mli000066400000000000000000000024471366176261100202010ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: struct.mli,v 1.7 2002-01-16 09:42:03 xleroy Exp $ *) (* Marshaling for structs *) open Idltypes val struct_ml_to_c : (out_channel -> bool -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> bool -> Prefix.t -> struct_decl -> string -> string -> unit val struct_c_to_ml : (out_channel -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> Prefix.t -> struct_decl -> string -> string -> unit val remove_dependent_fields: field list -> field list camlidl-camlidl109/compiler/structdecl.ml000066400000000000000000000066771366176261100206710ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: structdecl.ml,v 1.15 2002-01-16 09:42:03 xleroy Exp $ *) (* Handling of structure declarations *) open Printf open Utils open Variables open Idltypes open Cvttyp open Cvtval open Struct (* Convert an IDL struct declaration to an ML record declaration *) let ml_declaration oc sd = if sd.sd_name = "" then fprintf oc "struct_%d = " sd.sd_stamp else fprintf oc "%s = " (String.uncapitalize_ascii sd.sd_name); match remove_dependent_fields sd.sd_fields with [f] -> fprintf oc "%a\n" out_ml_type f.field_typ | fields -> fprintf oc "{\n"; List.iter (fun f -> fprintf oc " %s: %a;\n" (String.uncapitalize_ascii f.field_mlname) out_ml_type f.field_typ) fields; fprintf oc "}\n" (* Convert an IDL struct declaration to a C struct declaration *) let c_declaration oc sd = if sd.sd_fields = [] then fprintf oc "struct %s;\n" sd.sd_name else begin out_struct oc sd; fprintf oc ";\n\n" end (* External (forward) declaration of the translation functions *) let declare_transl oc sd = fprintf oc "extern void camlidl_ml2c_%s_struct_%s(value, struct %s *, camlidl_ctx _ctx);\n" sd.sd_mod sd.sd_name sd.sd_name; fprintf oc "extern value camlidl_c2ml_%s_struct_%s(struct %s *, camlidl_ctx _ctx);\n\n" sd.sd_mod sd.sd_name sd.sd_name (* Translation function from an ML record to a C struct *) let transl_ml_to_c oc sd = current_function := sprintf "struct %s" sd.sd_name; let v = new_var "_v" in let c = new_var "_c" in fprintf oc "void camlidl_ml2c_%s_struct_%s(value %s, struct %s * %s, camlidl_ctx _ctx)\n" sd.sd_mod sd.sd_name v sd.sd_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); struct_ml_to_c ml_to_c pc false Prefix.empty sd v (sprintf "(*%s)" c); output_variable_declarations oc; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; current_function := "" (* Translation function from a C struct to an ML record *) let transl_c_to_ml oc sd = current_function := sprintf "struct %s" sd.sd_name; let c = new_var "_c" in fprintf oc "value camlidl_c2ml_%s_struct_%s(struct %s * %s, camlidl_ctx _ctx)\n" sd.sd_mod sd.sd_name sd.sd_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); let v = new_ml_variable() in struct_c_to_ml c_to_ml pc Prefix.empty sd (sprintf "(*%s)" c) v; iprintf pc "return %s;\n" v; output_variable_declarations oc; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; current_function := "" (* Emit the translation functions *) let emit_transl oc sd = transl_ml_to_c oc sd; transl_c_to_ml oc sd camlidl-camlidl109/compiler/structdecl.mli000066400000000000000000000022071366176261100210230ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: structdecl.mli,v 1.5 2000-08-19 11:04:58 xleroy Exp $ *) (* Generation of converters for structs *) open Idltypes val ml_declaration : out_channel -> struct_decl -> unit val c_declaration : out_channel -> struct_decl -> unit val declare_transl: out_channel -> struct_decl -> unit val emit_transl : out_channel -> struct_decl -> unit camlidl-camlidl109/compiler/typedef.ml000066400000000000000000000166321366176261100201450ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: typedef.ml,v 1.17 2002-05-01 15:23:15 xleroy Exp $ *) (* Handling of typedefs *) open Printf open Utils open Variables open Idltypes open Cvttyp open Cvtval type type_decl = { td_name: string; td_mod: string; td_type: idltype; td_abstract: bool; td_c2ml: string option; td_ml2c: string option; td_finalize: string option; td_compare: string option; td_hash: string option; td_errorcode: bool; td_errorcheck: string option; td_mltype: string option } (* Record typedefs by name *) let find = ref ((fun _ -> invalid_arg "Typedef.find") : string -> type_decl) (* Generate the ML type definition corresponding to the typedef *) let ml_declaration oc td = match td with {td_mltype = Some s} -> fprintf oc "%s = %s\n" (String.uncapitalize_ascii td.td_name) s | {td_abstract = true} -> fprintf oc "%s\n" (String.uncapitalize_ascii td.td_name) | _ -> fprintf oc "%s = %a\n" (String.uncapitalize_ascii td.td_name) out_ml_type td.td_type (* Generate the C typedef corresponding to the typedef *) let c_declaration oc td = fprintf oc "typedef %a;\n" out_c_decl (td.td_name, td.td_type); begin match td.td_ml2c with None -> () | Some s -> fprintf oc "extern void %s(value, %s *);\n" s td.td_name end; begin match td.td_c2ml with None -> () | Some s -> fprintf oc "extern value %s(%s *);\n" s td.td_name end; begin match td.td_finalize with None -> () | Some s -> fprintf oc "extern void %s(%s *);\n" s td.td_name end; begin match td.td_compare with None -> () | Some s -> fprintf oc "extern int %s(%s *, %s *);\n" s td.td_name td.td_name end; begin match td.td_hash with None -> () | Some s -> fprintf oc "extern long %s(%s *);\n" s td.td_name end; fprintf oc "\n" (* External (forward) declaration of the translation functions *) let declare_transl oc td = begin match td.td_ml2c with Some s -> fprintf oc "extern void %s(value, %s *);\n" s td.td_name; fprintf oc "#define camlidl_ml2c_%s_%s(v,c,ctx) %s(v,c)\n\n" td.td_mod td.td_name s | None -> fprintf oc "extern void camlidl_ml2c_%s_%s(value, %s *, camlidl_ctx _ctx);\n" td.td_mod td.td_name td.td_name end; begin match td.td_c2ml with Some s -> fprintf oc "extern value %s(%s *);\n" s td.td_name; fprintf oc "#define camlidl_c2ml_%s_%s(c,ctx) %s(c)\n\n" td.td_mod td.td_name s | None -> fprintf oc "extern value camlidl_c2ml_%s_%s(%s *, camlidl_ctx _ctx);\n" td.td_mod td.td_name td.td_name end; fprintf oc "\n" (* Translation function from the ML type to the C type *) let is_custom_block td = td.td_abstract && not (td.td_finalize = None && td.td_compare = None && td.td_hash = None) let transl_ml_to_c oc td = current_function := sprintf "typedef %s" td.td_name; let v = new_var "_v" in let c = new_var "_c" in fprintf oc "void camlidl_ml2c_%s_%s(value %s, %s * %s, camlidl_ctx _ctx)\n" td.td_mod td.td_name v td.td_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); if td.td_abstract then if is_custom_block td then begin iprintf pc "*%s = *((%s *) Data_custom_val(%s));\n" c td.td_name v end else begin iprintf pc "*%s = *((%s *) Bp_val(%s));\n" c td.td_name v end else begin ml_to_c pc false Prefix.empty td.td_type v (sprintf "(*%s)" c); end; decrease_indent(); output_variable_declarations oc; end_diversion oc; fprintf oc "}\n\n"; current_function := "" (* Translation function from the C type to the ML type *) let transl_c_to_ml oc td = begin match td.td_finalize with None -> () | Some f -> fprintf oc "\ static void camlidl_finalize_%s_%s(value v) { %s((%s *) Data_custom_val(v)); } " td.td_mod td.td_name f td.td_name end; begin match td.td_compare with None -> () | Some f -> fprintf oc "\ static int camlidl_compare_%s_%s(value v1, value v2) { return %s((%s *) Data_custom_val(v1), (%s *) Data_custom_val(v2)); } " td.td_mod td.td_name f td.td_name td.td_name end; begin match td.td_hash with None -> () | Some f -> fprintf oc "\ static long camlidl_hash_%s_%s(value v) { return %s((%s *) Data_custom_val(v)); } " td.td_mod td.td_name f td.td_name end; if is_custom_block td then begin fprintf oc "struct custom_operations camlidl_cops_%s_%s = {\n" td.td_mod td.td_name; fprintf oc " NULL,\n"; begin match td.td_finalize with None -> iprintf oc " custom_finalize_default,\n" | Some f -> iprintf oc " camlidl_finalize_%s_%s,\n" td.td_mod td.td_name end; begin match td.td_compare with None -> iprintf oc " custom_compare_default,\n" | Some f -> iprintf oc " camlidl_compare_%s_%s,\n" td.td_mod td.td_name end; begin match td.td_hash with None -> iprintf oc " custom_hash_default,\n" | Some f -> iprintf oc " camlidl_hash_%s_%s,\n" td.td_mod td.td_name end; iprintf oc " custom_serialize_default,\n"; iprintf oc " custom_deserialize_default\n"; fprintf oc "};\n\n" end; current_function := sprintf "typedef %s" td.td_name; let v = new_ml_variable() in let c = new_var "_c" in fprintf oc "value camlidl_c2ml_%s_%s(%s * %s, camlidl_ctx _ctx)\n" td.td_mod td.td_name td.td_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); if td.td_abstract then if is_custom_block td then begin iprintf pc "%s = caml_alloc_custom(&camlidl_cops_%s_%s, sizeof(%s), 0, 1);\n" v td.td_mod td.td_name td.td_name; iprintf pc "*((%s *) Data_custom_val(%s)) = *%s;\n" td.td_name v c end else begin iprintf pc "%s = camlidl_alloc((sizeof(%s) + sizeof(value) - 1) / sizeof(value), Abstract_tag);\n" v td.td_name; iprintf pc "*((%s *) Bp_val(%s)) = *%s;\n" td.td_name v c end else begin c_to_ml pc Prefix.empty td.td_type (sprintf "(*%s)" c) v end; iprintf pc "return %s;\n" v; decrease_indent(); output_variable_declarations oc; end_diversion oc; fprintf oc "}\n\n"; current_function := "" (* Emit the translation functions *) let emit_transl oc td = begin match td.td_ml2c with Some s -> fprintf oc "#define camlidl_ml2c_%s_%s(v,c,ctx) %s(v,c)\n\n" td.td_mod td.td_name s | None -> transl_ml_to_c oc td end; begin match td.td_c2ml with Some s -> fprintf oc "#define camlidl_c2ml_%s_%s(c,ctx) %s(c)\n\n" td.td_mod td.td_name s | None -> transl_c_to_ml oc td end camlidl-camlidl109/compiler/typedef.mli000066400000000000000000000027421366176261100203130ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: typedef.mli,v 1.9 2002-04-19 13:24:30 xleroy Exp $ *) (* Handling of typedefs *) open Idltypes type type_decl = { td_name: string; td_mod: string; td_type: idltype; td_abstract: bool; td_c2ml: string option; td_ml2c: string option; td_finalize: string option; td_compare: string option; td_hash: string option; td_errorcode: bool; td_errorcheck: string option; td_mltype: string option } val ml_declaration: out_channel -> type_decl -> unit val c_declaration: out_channel -> type_decl -> unit val emit_transl: out_channel -> type_decl -> unit val declare_transl: out_channel -> type_decl -> unit val find: (string -> type_decl) ref camlidl-camlidl109/compiler/union.ml000066400000000000000000000137401366176261100176320ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: union.ml,v 1.8 2002-01-16 09:42:04 xleroy Exp $ *) (* Handling of unions *) open Printf open Utils open Variables open Idltypes open Cvttyp (* Translate an ML datatype [v] and store its argument in the C union [c] and its discriminant in the C integer [discr]. *) let union_ml_to_c ml_to_c oc onstack pref ud v c discr = let tag_constant = ref 0 and tag_constr = ref 0 in let emit_case = function {case_field = None; case_labels = []} -> (* default case, no arg *) iprintf oc "case %d: /* default */\n" !tag_constr; incr tag_constr; iprintf oc " %s = Int_val(Field(%s, 0));\n" discr v; iprintf oc " break;\n" | {case_field = Some{field_name = n; field_typ = ty}; case_labels = []} -> (* default case, one arg *) iprintf oc "case %d: /* default */\n" !tag_constr; incr tag_constr; increase_indent(); iprintf oc "%s = Int_val(Field(%s, 0));\n" discr v; let v' = new_ml_variable() in iprintf oc "%s = Field(%s, 1);\n" v' v; ml_to_c oc onstack pref ty v' (sprintf "%s.%s" c n); iprintf oc "break;\n"; decrease_indent() | {case_field = None; case_labels = lbls} -> (* named case, no args *) List.iter (fun lbl -> iprintf oc "case %d: /* %s */\n" !tag_constant lbl; incr tag_constant; iprintf oc " %s = %s;\n" discr lbl; iprintf oc " break;\n") lbls | {case_field = Some{field_name = n; field_typ = ty}; case_labels = lbls} -> (* named case, one arg *) List.iter (fun lbl -> iprintf oc "case %d: /* %s */\n" !tag_constr lbl; incr tag_constr; increase_indent(); iprintf oc "%s = %s;\n" discr lbl; let v' = new_ml_variable() in iprintf oc "%s = Field(%s, 0);\n" v' v; ml_to_c oc onstack pref ty v' (sprintf "%s.%s" c n); iprintf oc "break;\n"; decrease_indent()) lbls in let (constant_cases, constr_cases) = list_partition (fun c -> c.case_field = None && c.case_labels <> []) ud.ud_cases in if constant_cases <> [] && constr_cases <> [] then begin iprintf oc "if (Is_long(%s)) {\n" v; increase_indent() end; if constant_cases <> [] then begin iprintf oc "switch (Int_val(%s)) {\n" v; List.iter emit_case constant_cases; iprintf oc "}\n" end; if constant_cases <> [] && constr_cases <> [] then begin decrease_indent(); iprintf oc "} else {\n"; increase_indent() end; if constr_cases <> [] then begin iprintf oc "switch (Tag_val(%s)) {\n" v; List.iter emit_case constr_cases; iprintf oc "}\n" end; if constant_cases <> [] && constr_cases <> [] then begin decrease_indent(); iprintf oc "}\n" end (* Translate a C union [c] with its discriminant [discr] to an ML datatype [v]. *) let union_c_to_ml c_to_ml oc pref ud c v discr = let tag_constant = ref 0 and tag_constr = ref 0 in let have_default = ref false in let emit_case = function {case_field = None; case_labels = []} -> (* default case, no arg *) iprintf oc "default:\n"; increase_indent(); iprintf oc "%s = camlidl_alloc_small(1, %d);\n" v !tag_constr; incr tag_constr; iprintf oc "Field(%s, 0) = Val_int(%s);\n" v discr; iprintf oc "break;\n"; decrease_indent(); have_default := true | {case_field = Some{field_name = n; field_typ = ty}; case_labels = []} -> (* default case, one arg *) iprintf oc "default:\n"; increase_indent(); let v' = new_ml_variable() in c_to_ml oc pref ty (sprintf "%s.%s" c n) v'; iprintf oc "Begin_root(%s)\n" v'; increase_indent(); iprintf oc "%s = camlidl_alloc_small(2, %d);\n" v !tag_constr; incr tag_constr; iprintf oc "Field(%s, 0) = Val_int(%s);\n" v discr; iprintf oc "Field(%s, 1) = %s;\n" v v'; decrease_indent(); iprintf oc "End_roots()\n"; iprintf oc "break;\n"; decrease_indent(); have_default := true | {case_field = None; case_labels = lbls} -> (* named cases, no arg *) List.iter (fun lbl -> iprintf oc "case %s:\n" lbl; iprintf oc " %s = Val_int(%d);\n" v !tag_constant; incr tag_constant; iprintf oc " break;\n") lbls; | {case_field = Some{field_name = n; field_typ = ty}; case_labels = lbls} -> (* named cases, one arg *) List.iter (fun lbl -> iprintf oc "case %s:\n" lbl; increase_indent(); let v' = new_ml_variable() in c_to_ml oc pref ty (sprintf "%s.%s" c n) v'; iprintf oc "Begin_root(%s)\n" v'; increase_indent(); iprintf oc "%s = camlidl_alloc_small(1, %d);\n" v !tag_constr; incr tag_constr; iprintf oc "Field(%s, 0) = %s;\n" v v'; decrease_indent(); iprintf oc "End_roots()\n"; iprintf oc "break;\n"; decrease_indent()) lbls in iprintf oc "switch (%s) {\n" discr; List.iter emit_case ud.ud_cases; if not !have_default then begin iprintf oc "default:\n"; iprintf oc " caml_invalid_argument(\"%s: bad discriminant for union %s\");\n" !current_function ud.ud_name end; iprintf oc "}\n" camlidl-camlidl109/compiler/union.mli000066400000000000000000000023771366176261100200070ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: union.mli,v 1.6 2002-01-16 09:42:04 xleroy Exp $ *) (* Marshalling for unions *) open Idltypes val union_ml_to_c : (out_channel -> bool -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> bool -> Prefix.t -> union_decl -> string -> string -> string -> unit val union_c_to_ml : (out_channel -> Prefix.t -> idltype -> string -> string -> unit) -> out_channel -> Prefix.t -> union_decl -> string -> string -> string -> unit camlidl-camlidl109/compiler/uniondecl.ml000066400000000000000000000103351366176261100204570ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: uniondecl.ml,v 1.16 2002-01-16 09:42:04 xleroy Exp $ *) (* Handling of union declarations *) open Printf open Utils open Variables open Idltypes open Cvttyp open Cvtval open Union (* Convert an IDL union declaration to an ML datatype declaration *) let ml_declaration oc ud = if ud.ud_name = "" then fprintf oc "union_%d =\n" ud.ud_stamp else fprintf oc "%s =\n" (String.uncapitalize_ascii ud.ud_name); let out_constr oc c = if c = "default" then if ud.ud_name <> "" then fprintf oc "Default_%s" ud.ud_name else fprintf oc "Default_%d" ud.ud_stamp else output_string oc (String.capitalize_ascii c) in let emit_case = function {case_labels = []; case_field = None} -> (* default case, no arg *) fprintf oc " | %a of int\n" out_constr "default" | {case_labels = []; case_field = Some f} -> (* default case, one arg *) fprintf oc " | %a of int * %a\n" out_constr "default" out_ml_type f.field_typ | {case_labels = lbls; case_field = None} -> (* named cases, no args *) List.iter (fun lbl -> fprintf oc " | %a\n" out_constr lbl) lbls | {case_labels = lbls; case_field = Some f} -> (* named cases, one arg *) List.iter (fun lbl -> fprintf oc " | %a of %a\n" out_constr lbl out_ml_type f.field_typ) lbls in List.iter emit_case ud.ud_cases (* Convert an IDL union declaration to a C union declaration *) let c_declaration oc ud = if ud.ud_cases = [] then fprintf oc "union %s;\n" ud.ud_name else begin out_union oc ud; fprintf oc ";\n\n" end (* External (forward) declaration of the translation functions *) let declare_transl oc ud = fprintf oc "extern int camlidl_ml2c_%s_union_%s(value, union %s *, camlidl_ctx _ctx);\n" ud.ud_mod ud.ud_name ud.ud_name; fprintf oc "extern value camlidl_c2ml_%s_union_%s(int, union %s *, camlidl_ctx _ctx);\n\n" ud.ud_mod ud.ud_name ud.ud_name (* Translation function from an ML datatype to a C union *) let transl_ml_to_c oc ud = current_function := sprintf "union %s" ud.ud_name; let v = new_var "_v" in let c = new_var "_c" in fprintf oc "int camlidl_ml2c_%s_union_%s(value %s, union %s * %s, camlidl_ctx _ctx)\n" ud.ud_mod ud.ud_name v ud.ud_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); let discr = new_c_variable (Type_int(Int, Iunboxed)) in iprintf pc "%s = -1;\n" discr; (* keeps gcc happy *) union_ml_to_c ml_to_c pc false Prefix.empty ud v (sprintf "(*%s)" c) discr; iprintf pc "return %s;\n" discr; output_variable_declarations oc; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; current_function := "" (* Translation function from a C union to an ML datatype *) let transl_c_to_ml oc ud = current_function := sprintf "union %s" ud.ud_name; let discr = new_var "_discr" in let c = new_var "_c" in fprintf oc "value camlidl_c2ml_%s_union_%s(int %s, union %s * %s, camlidl_ctx _ctx)\n" ud.ud_mod ud.ud_name discr ud.ud_name c; fprintf oc "{\n"; let pc = divert_output() in increase_indent(); let v = new_ml_variable() in union_c_to_ml c_to_ml pc Prefix.empty ud (sprintf "(*%s)" c) v discr; iprintf pc "return %s;\n" v; output_variable_declarations oc; end_diversion oc; decrease_indent(); fprintf oc "}\n\n"; current_function := "" (* Emit the translation functions *) let emit_transl oc ud = transl_ml_to_c oc ud; transl_c_to_ml oc ud camlidl-camlidl109/compiler/uniondecl.mli000066400000000000000000000022011366176261100206210ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: uniondecl.mli,v 1.5 2000-08-19 11:04:58 xleroy Exp $ *) (* Generation of converters for unions *) open Idltypes val ml_declaration : out_channel -> union_decl -> unit val c_declaration : out_channel -> union_decl -> unit val declare_transl: out_channel -> union_decl -> unit val emit_transl : out_channel -> union_decl -> unit camlidl-camlidl109/compiler/utils.ml000066400000000000000000000061201366176261100176340ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: utils.ml,v 1.11 2002-01-16 16:15:34 xleroy Exp $ *) (* Utility functions *) open Printf (* Indented printf *) let current_indentation = ref 0 let iprintf oc fmt = for i = 1 to !current_indentation do output_char oc ' ' done; fprintf oc fmt let increase_indent() = current_indentation := !current_indentation + 2 let decrease_indent() = current_indentation := !current_indentation - 2 (* Remove a file, ignoring errors *) let remove_file name = try Sys.remove name with Sys_error _ -> () (* Divert output to a temp file *) let temp_file = ref "" let temp_out = ref stdout let divert_output() = let f = Filename.temp_file "camlidl" ".c" in let oc = open_out f in temp_file := f; temp_out := oc; oc let end_diversion oc = close_out !temp_out; let ic = open_in !temp_file in let buffer = Bytes.create 256 in let rec copy() = 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 (* Remember current module name and current function name *) let module_name = ref "Mod" let current_function = ref "" (* Emit error messages *) exception Error let error msg = eprintf "%s.idl" !module_name; if !current_function <> "" then eprintf ", function %s" !current_function; eprintf ": %s\n" msg; raise Error (* List hacking *) let rec list_filter pred = function [] -> [] | hd :: tl -> if pred hd then hd :: list_filter pred tl else list_filter pred tl let rec list_partition pred = function [] -> ([], []) | hd :: tl -> let (p1, p2) = list_partition pred tl in if pred hd then (hd :: p1, p2) else (p1, hd :: p2) let rec map_index f i = function [] -> [] | hd :: tl -> f i hd :: map_index f (i + 1) tl let rec iter_index f i = function [] -> () | hd :: tl -> f i hd; iter_index f (i + 1) tl (* Path searching *) let find_in_path path name = if not (Filename.is_implicit name) then if Sys.file_exists name then name else raise Not_found else begin let rec try_dir = function [] -> raise Not_found | dir::rem -> let fullname = Filename.concat dir name in if Sys.file_exists fullname then fullname else try_dir rem in try_dir path end (* Discard result *) (*external ignore: 'a -> unit = "%identity" (* not quite *)*) camlidl-camlidl109/compiler/utils.mli000066400000000000000000000031051366176261100200050ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: utils.mli,v 1.12 2004-01-09 21:12:12 doligez Exp $ *) (* Utility functions *) val iprintf : out_channel -> ('a, out_channel, unit) format -> 'a val increase_indent : unit -> unit val decrease_indent : unit -> unit val divert_output : unit -> out_channel val end_diversion : out_channel -> unit val module_name : string ref val current_function : string ref val error : string -> 'a exception Error val list_filter : ('a -> bool) -> 'a list -> 'a list val list_partition : ('a -> bool) -> 'a list -> 'a list * 'a list val map_index : (int -> 'a -> 'b) -> int -> 'a list -> 'b list val iter_index : (int -> 'a -> unit) -> int -> 'a list -> unit val find_in_path : string list -> string -> string (*external ignore: 'a -> unit = "%identity"*) val remove_file : string -> unit camlidl-camlidl109/compiler/variables.ml000066400000000000000000000053711366176261100204530ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: variables.ml,v 1.12 2002-04-22 09:02:17 xleroy Exp $ *) open Printf open Utils open Idltypes open Cvttyp (* Generate temporaries *) let var_counter = ref 0 let temp_variables = ref([] : (string * idltype) list) let new_var prefix = incr var_counter; prefix ^ string_of_int !var_counter let new_c_variable ty = let name = new_var "_c" in temp_variables := (name, scrape_const ty) :: !temp_variables; name let new_ml_variable () = let name = new_var "_v" in temp_variables := (name, Type_named("", "value")) :: !temp_variables; name let new_ml_variable_block n = let name = new_var "_v" in let ty = Type_array({bound = Some(Expr_int(Int64.of_int n)); size=None; length=None; is_string=false; maybe_null=false; null_terminated=false}, Type_named("", "value")) in temp_variables := (name, ty) :: !temp_variables; name let output_variable_declarations oc = List.iter (fun name_ty -> iprintf oc "%a;\n" out_c_decl name_ty) (List.rev !temp_variables); temp_variables := []; var_counter := 0 (* Zero an array of values *) let init_value_block oc blk numvals = if numvals <= 4 then begin iprintf oc ""; for i = 0 to numvals - 1 do fprintf oc "%s[%d] = " blk i done; fprintf oc "0;\n" end else begin iprintf oc "memset(%s, 0, %d * sizeof(value));\n" blk numvals end (* Copy an array of values into the fields of a newly-allocated block *) let copy_values_to_block oc src dst numvals = if numvals <= 4 then for i = 0 to numvals - 1 do iprintf oc "Field(%s, %d) = %s[%d];\n" dst i src i done else begin let idx = new_var "_c" in iprintf oc "{ mlsize_t %s;\n" idx; increase_indent(); iprintf oc "for (%s = 0; %s < %d; %s++) Field(%s, %s) = %s[%s];\n" idx idx numvals idx dst idx src idx; decrease_indent(); iprintf oc "}\n" end (* Record if we need the context parameter *) let need_context = ref false camlidl-camlidl109/compiler/variables.mli000066400000000000000000000024031366176261100206150ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License LGPL v2.1 *) (* *) (***********************************************************************) (* $Id: variables.mli,v 1.7 2000-08-19 11:04:58 xleroy Exp $ *) (* Generate temporaries *) val new_var : string -> string val new_c_variable : 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 need_context : bool ref camlidl-camlidl109/config/000077500000000000000000000000001366176261100155765ustar00rootroot00000000000000camlidl-camlidl109/config/.cvsignore000066400000000000000000000000111366176261100175660ustar00rootroot00000000000000Makefile camlidl-camlidl109/config/Makefile.unix000066400000000000000000000031431366176261100202210ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile.unix,v 1.4 2002-04-22 11:50:46 xleroy Exp $ ## Configuration section # Type of system -- do not change OSTYPE=unix # How to invoke the C preprocessor # Works on most Unix systems: CPP=cpp # Alternatives: # CPP=/lib/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=$(shell $(OCAMLC) -where) # 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=-Wall -g # Suffixes for executables and libraries (do not change) EXE= LIBEXT=a OBJEXT=o camlidl-camlidl109/config/Makefile.win32000066400000000000000000000026621366176261100202050ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile.win32,v 1.6 2004-07-08 12:21:58 xleroy Exp $ ## Configuration section # Type of system OSTYPE=win32 # How to invoke the C preprocessor CPP=cl /nologo /E # Suffixes for executables and libraries EXE=.exe LIBEXT=lib OBJEXT=obj # We don't need ranlib RANLIB=echo # Location of the Objective Caml library in your installation OCAMLLIB=$(shell $(OCAMLC) -where) # Where to install the binaries BINDIR=C:/ocaml/bin # The Objective Caml compilers (the defaults below should be OK) OCAMLC=ocamlc -g OCAMLOPT=ocamlopt OCAMLDEP=ocamldep OCAMLYACC=ocamlyacc -v OCAMLLEX=ocamllex # C/C++ compiler and its flags CC=cl CFLAGS=/nologo /MT /Zi camlidl-camlidl109/doc/000077500000000000000000000000001366176261100150765ustar00rootroot00000000000000camlidl-camlidl109/doc/Makefile000066400000000000000000000015111366176261100165340ustar00rootroot00000000000000CAMLDOC=$${HOME}/csldoc TEXINPUTS=.:$(CAMLDOC)/styles:$(CAMLDOC)/manual:/usr/local/lib/hevea: HEVEAINPUTS=-I $(CAMLDOC)/manual -I .. TRANSF=$(CAMLDOC)/tools/transf TEXQUOTE=texquote3 HTMLGEN=$(CAMLDOC)/tools/htmlgen HTMLCUT=$(CAMLDOC)/tools/htmlcut HTMLTHREAD=$(CAMLDOC)/tools/htmlthread TEXEXPAND=$(CAMLDOC)/tools/texexpand FORMATINTF=$(CAMLDOC)/tools/format-intf all: main.dvi main.pdf htmlman/index.html main.dvi: main.tex manual.tex com.tex TEXINPUTS=$(TEXINPUTS) latex main.tex main.pdf: main.tex manual.tex com.tex TEXINPUTS=$(TEXINPUTS) pdflatex main.tex htmlman/index.html: main.tex manual.tex com.tex cd htmlman; \ hevea $(HEVEAINPUTS) -fix ../main.tex && \ hacha main.html manual.tex: manual.etex $(TRANSF) < manual.etex | $(TEXQUOTE) > manual.tex com.tex: ../lib/com.mli $(FORMATINTF) ../lib/com.mli > com.tex camlidl-camlidl109/doc/htmlman/000077500000000000000000000000001366176261100165365ustar00rootroot00000000000000camlidl-camlidl109/doc/htmlman/contents_motif.gif000066400000000000000000000004741366176261100222650ustar00rootroot00000000000000GIF89añp€ÿÿ!þ" Imported from XPM image: toc.xpm!ù,@çÜ6313Æc „BÃ0 Ã0‚ A0 Ã0 Ã0 €Á0 ƒÁ`0€@`0 ƒÁ`  ƒÁ`0€@`0 ƒÁ`0€@`0000000000 0000000000 00000000 000000 0000 000000000 00000000000 00000000000000`À€ ;camlidl-camlidl109/doc/htmlman/next_motif.gif000066400000000000000000000004751366176261100214070ustar00rootroot00000000000000GIF89añp€ÿÿp€!þ# Imported from XPM image: next.xpm!ù,@çÜ63333ÆB! Ã0 A0 Ã0 Ã0  0 ƒÁ`0 ƒÁ`0 ƒA @ ƒÁ`0 ƒÁ`00000000000000000000000000000000000000000000  000000 0000000000000000000000000000`À€ ;camlidl-camlidl109/doc/htmlman/previous_motif.gif000066400000000000000000000004751366176261100223050ustar00rootroot00000000000000GIF89añp€ÿÿp€!þ# Imported from XPM image: prev.xpm!ù,@çÜ63333Æ# „B Ã0 AÀ0 Ã0 Ã0 À0 ƒÁ`0 ƒÁ`0 ƒA  ƒ €Á`0 ƒ`00000000000000000000000000000000000000000000  000 0000000000000000000000000000000`À€ ;camlidl-camlidl109/doc/main.tex000066400000000000000000000006731366176261100165520ustar00rootroot00000000000000\documentclass[11pt]{article} \usepackage{isolatin1} \usepackage{alltt} \usepackage{fullpage} \usepackage{syntaxdef} \usepackage{hevea} \newif\ifpdf\pdffalse \newif\ifplaintext\plaintextfalse \ifhevea \input{macros.hva} \else \input{macros.tex} \fi \renewcommand{\index}[1]{} \title{Camlidl user's manual \\ Version 1.04} \author{Xavier Leroy \\ INRIA Rocquencourt} \begin{document} \maketitle \input{manual.tex} \end{document} camlidl-camlidl109/doc/manual.etex000066400000000000000000001566571366176261100172660ustar00rootroot00000000000000\section{Overview} Camlidl generates stub code for interfacing Caml with C (as described in chapter ``Interfacing with C'' of the \footahref{http://caml.inria.fr/ocaml/htmlman/index.html}{Objective Caml reference manual}) from an IDL description of the C functions to be made available in Caml. 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. 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. \subsection{What is IDL?} IDL stands for Interface Description Language. This is a generic term for a family of small languages that have been developed to provide type specifications for libraries written in C and C++. Those languages resembles C declarations (as found in C header files), with extra annotations to provide more precise types for the arguments and results of the functions. The particular IDL used by Camlidl is inspired by Microsoft's IDL, which itself is an extension of the IDL found in DCE (The Open Group's Distributed Common Environment). The initial motivation for those IDLs was to automate the generation of stub code for remote procedure calls and network objects, where the arguments to the function are marshaled at the calling site, then sent across the network or through interprocess communications to a server process, which unmarshals the arguments, compute the function application, marshal the results, sends them back to the calling site, where they are unmarshaled and returned to the caller. IDLs were also found to be very useful for inter-language communications, since the same type information that guides the generation of marshaling stubs can be used to generate stubs to convert between the data representations of several languages. \subsection{What is COM?} COM is Microsoft's Common Object Model. It provides a set of programming conventions as well as system support for packaging C++ objects as executable components that can be used in other programs, either by dynamic linking of the component inside the program, or through interprocess or internetwork communications between the program and a remote server. COM components implement one or several interfaces, (similar to Caml object types or Java interfaces) identified by unique 128-bit interface identifiers (IIDs). COM specifies a standard protocol for reference counting of components, and for asking a component which interfaces it implements. While the full range of COM services and third-party components is available only on Microsoft's Windows operating systems, the basic COM conventions can also be used on Unix and other operating systems to exchange objects between Caml and C or C++. Of particular interest is the encapsulation of Caml objects as COM components, which can then be used inside larger C or C++ applications; those applications do not need to know anything about Caml: they just call the component methods as if they were C++ methods or C functions, without knowing that they are actually implemented in Caml. For more information about COM, see for instance {\em Inside COM} by Dale Rogerson (Microsoft Press), or the \footahref{http://msdn.microsoft.com}{Microsoft developer Web site}. \section{IDL syntax} This section describes the syntax of IDL files. IDL syntax is very close to that of C declarations, with extra attributes between brackets adding information to the C types. The following example should give the flavor of the syntax: \begin{verbatim} int f([in,string] char * msg); \end{verbatim} This reads: ``"f" is a function taking a character string as input and returning an "int"''. \subsection{Lexical conventions} \paragraph{Blanks.} Space, newline, horizontal tabulation, carriage return, line feed and form feed are considered as blanks. Blanks are ignored, but they separate adjacent tokens. \paragraph{Comments.} Both C-style comments "/* ... */" and Java-style comments "// ..." are supported. C-style comments are introduced by "/*" and terminated by "*/". Java-style comments are introduced by "//" and extend to the end of the line. Comments are treated as blank characters. Comments do not occur inside string or character literals. Nested C-style comments are not supported. \paragraph{Identifiers.} Identifiers have the same syntax as in C. \begin{syntax} ident: ("A" \ldots "Z" || "a" \ldots "z" || "_") {"A" \ldots "Z" || "a" \ldots "z" || "0" \ldots "9" || "_"}; \end{syntax} \paragraph{Literals.} Integer literals, character literals and string literals have the same syntax as in C. \begin{syntax} integer: ['-'] {'0' \ldots '9'} ['-'] '0x' {'0' \ldots '9' || 'a' \ldots 'f' || 'A' \ldots 'F'} ['-'] '0' {'0' \ldots '7'}; character: "'" (regular-char || escape-char) "'"; string: '"' {regular-char || escape-char} '"'; escape-char: '\' ('b'||'n'||'r'||'t') | '\' ('0'\ldots'7') ['0'\ldots'7'] ['0'\ldots'7']; \end{syntax} \paragraph{UUID.} Unique identifiers are composed of 16 hexadecimal digits, in groups of 8, 4, 4, 4 and 12, separated by dashes. \begin{syntax} uuid: hex^8 '-' hex^4 '-' hex^4 '-' hex^4 '-' hex^4 hex^4 hex^4; hex: '0' \ldots '9' || 'a' \ldots 'f' || 'A' \ldots 'F'; \end{syntax} \subsection{Limited expressions} Limited expressions are similar to C expressions, with the omission of assignment operators ("=", "+=", etc), and the addition of the unsigned (logical) right shift operator ">>>". Operators have the same precedences and associativities as in C. They are listed below in decreasing priority order. \begin{syntax} lexpr: ident | integer | character | 'true' | 'false' | string | sizeof '(' type-expr ')' | '(' lexpr ')' | lexpr ('.' || '->') ident | '(' type-expr ')' lexpr | ('&'||'*'||'!'||'~'||'-'||'+') lexpr | lexpr ('*'||'/'||'%') lexpr | lexpr ('+'||'-') lexpr | lexpr ('<<'||'>>'|'>>>') lexpr | lexpr ('=='||'!='||'>='||'<='||'>'||'<') | lexpr ('&'||'^'||'|') lexpr | lexpr ('&&'||'||') lexpr | lexpr '?' lexpr ':' lexpr ; \end{syntax} Constant limited expressions, written @const-lexpr@ below, can only reference identifiers that are bound by the IDL "const" declaration. \subsection{Attributes} \begin{syntax} attributes: '[' attribute { ',' attribute } ']' ; attribute: ident | ident '(' [lexpr] { ',' [lexpr] } ')' | ident '(' uuid ')' | attribute '*' | '*' attribute ; \end{syntax} Attribute lists are written in brackets "[...]", and are always optional. Each attribute is identified by a name, and may carry optional arguments. Starred attributes apply to the element type of a pointer or array type, rather than to the pointer or array type itself. The following table summarizes the recognized attributes and their arguments. \begin{tableau}{|l|l|}{Attribute}{Context where it can appear} \entree{@"abstract"@ } {"typedef" } \entree{@"bigarray"@ } {array type} \entree{@"blocking"@ } {function declaration } \entree{@"camlint"@ } {"int" or "long" integer type} \entree{@"compare"'('fun-name')'@ } {"typedef" } \entree{@"c2ml"'('fun-name')'@ } {"typedef" } \entree{@"errorcheck"'('fun-name')'@ } {"typedef" } \entree{@"errorcode"@ } {"typedef" } \entree{@"finalize"'('fun-name')'@ } {"typedef" } \entree{@"fortran"@ } {array type with "bigarray" attribute} \entree{@"hash"'('fun-name')'@ } {"typedef" } \entree{@"ignore"@ } {any pointer type } \entree{@"in"@ } {function parameter } \entree{@"int_default"'(' 'camlint'||'nativeint'||'int32'||'int64'')'@ } {interface } \entree{@"int32"@ } {"int" or "long" integer type} \entree{@"int64"@ } {"int" or "long" integer type} \entree{@"length_is"'('le_1','le_2','\ldots')'@ } {array type } \entree{@"long_default"'(' 'camlint'||'nativeint'||'int32'||'int64'')'@ } {interface } \entree{@"managed"@ } {array type with "bigarray" attribute} \entree{@"ml2c"'('fun-name')'@ } {"typedef" } \entree{@'mlname(' fun-or-field-name ')' @ } {function declaration, "struct" field } \entree{@'mltype("' caml-type-expr '")' @ } {"typedef" } \entree{@"nativeint"@ } {"int" or "long" integer type} \entree{@"null_terminated"@ } {array of pointers } \entree{@"object"@} {interface} \entree{@"out"@ } {function parameter } \entree{@"pointer_default"'(' 'ref'||'unique'||'ptr'')'@ } {interface } \entree{@"propget"@}{function declaration} \entree{@"propput"@}{function declaration} \entree{@"propputref"@}{function declaration} \entree{@"ptr"@ } {any pointer type } \entree{@"ref"@ } {any pointer type } \entree{@"set"@ } {enum type } \entree{@"size_is"'('le_1','le_2','\ldots')'@ } {array type } \entree{@"string"@ } {character array or pointer } \entree{@"switch_is"'('le')'@ } {union type or pointer to union } \entree{@"switch_type"'('ty')'@ } {union or pointer to union } \entree{@"unique"@ } {any pointer, array, or bigarray type } \entree{@"uuid"'(' uuid ')'@ } {interface } \end{tableau} \subsection{Types and declarators} The declaration of an identifier along with its type is as in C: a type specification comes first, followed by the identifier possibly decorated with "*" and "[...]" to denote pointers and array types. For instance, "int x" declares an identifier "x" of type "int", while "int (*x)[]" declares an identifier "x" that is a pointer to an array of integers. \begin{syntax} type-spec: ['unsigned'||'signed'] ('int'||'short'||'long'||'char'||'hyper'||'long' 'long'||'__int64') | 'byte' | 'float' | 'double' | 'boolean' | 'void' | ident | 'wchar_t' | 'handle_t' | 'struct' ident | 'union' ident | 'enum' ident | struct-decl | union-decl | enum-decl ; declarator: {'*'} direct-declarator ; direct-declarator: ident | '(' declarator ')' | direct-declarator '[' [const-lexpr] ']' ; \end{syntax} \subsection{Structures, unions and enumerations} \begin{syntax} struct-decl: 'struct' [ident] '{' {field-decl} '}' ; field-decl: attributes type-spec declarator { ',' declarator } ';' ; union-decl: 'union' [ident] '{' {union-case} '}' | 'union' [ident] 'switch' '(' type-spec ident ')' '{' {union-case} '}' ; union-case: {{'case' ident ':'}} [field-decl] ';' 'default' ':' [field-decl] ';' ; enum-decl: 'enum' [ident] '{' enum-case {',' enum-case} [','] '}' ; enum-case: ident ['=' const-lexpr] ; \end{syntax} IDL "struct" declarations are like those of C, with the addition of optional attributes on each field. "union" declarations are also as in C, except that each case of an union must be labeled by one or several @'case' ident ':'@. The first form of union declaration assumes that the discriminant of the union is provided separately via a "switch_is" annotation on the union type, while the second form encapsulates the discriminant along with the union itself (like in Pascal's "record case of" construct). \subsection{Function declarations} \begin{syntax} function-decl: attributes type-spec {'*'} ident '(' params ')' {'quote''('ident','string')'} ; params: epsilon | 'void' | param { ',' param } ; param: attributes type-spec declarator ; \end{syntax} Function declarations are like in ANSI C, with the addition of attributes on each parameter and on the function itself. Parameters must be named. The optional @quote@ statements following the declaration are user-provided calling sequences and deallocation sequences that replaces the default sequences in the "camlidl"-generated stub code for the function. \subsection{Constant definitions} \begin{syntax} constant-decl: 'const' attributes type-spec {'*'} ident '=' const-lexpr ';' \end{syntax} A constant declaration associates a name to a limited expression. The limited expression can refer to constant names declared earlier, but cannot refer to other kinds of identifiers. The optional attributes influence the interpretation of the type specification, e.g. "const int x = 3" defines "x" with Caml type "int", but "const [int64] long x = 5" defines "x" with Caml type "int64". \subsection{IDL files} \begin{syntax} file: {decl} ; decl: function-decl ';' | constant-decl ';' | struct-decl ';' | union-decl ';' | enum-decl ';' | 'typedef' attributes type-spec declarator { ',' declarator } ';' | attributes 'interface' ident [ ':' ident ] '{' {decl} '}' | 'struct' ident ';' | 'union' ident ';' | 'union' 'switch' '(' type-spec ident ')' ';' | attributes 'interface' ident ';' | 'import' string ';' | 'quote' '(' [ident ','] string ')' | 'cpp_quote' '(' string ')' \end{syntax} An IDL file is a sequence of IDL declarations. Declarations include function declarations, constant declarations, type declarations (structs, unions, enums, as well as a C-style "typedef" declaration to name a type expression), and interfaces. An interface declaration gives a name and attributes to a collection of declarations. For interfaces with the "object" attribute, an optional super-interface can be provided, as in @'interface' intf ':' super-intf@. The name of the interface can be used as a type name in the remainder of the file. Forward declarations of structs, unions and interfaces are supported in the usual C manner, by just giving the name of the struct, union or interface, but not its actual contents. The "import" statement reads another IDL file and makes available its type and constant declarations in the remainder of the file. No code is generated for the functions and interfaces declared in the imported file. The same file can be imported several times, but is read in only the first time. The @"quote" "(" ident ',' str ')'@ diversion copies the string @str@ verbatim to one of the files generated by the "camlidl" compiler. The @ident@ determines the file where @str@ is copied: it can be "ml" for the Caml implementation file (".ml"), "mli" for the Caml interface file (".mli"), "mlmli" for both Caml files, "h" for the C header file (".h"), and "c" for the C source file containing the generated stub code (".c" file). For backward compatibility, @"cpp_quote" "(" str ")"@ is recognized as synonymous for @"quote" "(" "h" "," str ")"@. \section{The Caml-IDL mapping} This section describes how IDL types, function declarations, and interfaces are mapped to Caml types, functions and classes. \subsection{Base types} \begin{tableau}{|l|l|}{IDL type \var{ty}}{Caml type \transl{\var{ty}}} \entree{"byte", "short"}{"int"} \entree{"int", "long" with "[camlint]" attribute}{"int"} \entree{"int", "long" with "[nativeint]" attribute}{"nativeint"} \entree{"int", "long" with "[int32]" attribute}{"int32"} \entree{"int", "long" with "[int64]" attribute}{"int64"} \entree{"hyper", "long long", "__int64"}{"int64"} \entree{"char"}{"char"} \entree{"float", "double"}{"float"} \entree{"boolean"}{"bool"} \end{tableau} (For integer types, "signed" and "unsigned" variants of the same IDL integer type translate to the same Caml type.) Depending on the attributes, the "int" and "long" integer types are converted to one of the Caml integer types "int", "nativeint", "int32", or "int64". Values of Caml type "int32" are exactly 32-bit wide and values of type "int64" are exactly 64-bit wide on all platforms. Values of type "nativeint" have the natural word size of the platform, and are large enough to accommodate any C "int" or "long int" without loss of precision. Values of Caml type "int" have the natural word size of the platform minus one bit of tag, hence the conversion from IDL types "int" and "long" loses the most significant bit on 32-bit platforms. On 64-bit platforms, the conversion from "int" is exact, but the conversion from "long" loses the most significant bit. If no explicit integer attribute is given for an "int" or "long" type, the "int_default" or "long_default" attribute of the enclosing interface, if any, determines the kind of the integer. If no "int_default" or "long_default" attribute is in scope, the kind "camlint" is assumed, which maps IDL "int" and "long" types to the Caml "int" type. \subsection{Pointers} The mapping of IDL pointer types depends on their kinds. Writing \transl{\var{ty}} for the Caml type corresponding to the IDL type $ty$, we have: \begin{alltt} [ref] \var{ty} * \(\Rightarrow\) \transl{\var{ty}} [unique] \var{ty} * \(\Rightarrow\) \transl{\var{ty}} option [ptr] \var{ty} * \(\Rightarrow\) \transl{\var{ty}} Com.opaque \end{alltt} In other terms, IDL pointers of kind "ref" are ignored during the mapping: "[ref] "\var{ty}" *" is mapped to the same Caml type as \var{ty}. A pointer \var{p} to a C value \var{c}" = *"\var{p} is translated to the Caml value corresponding to \var{c}. IDL pointers of kind "unique" are mapped to an "option" type. The option value is "None" for a null pointer, and "Some("\var{v}")" for a non-null pointer to a C value \var{c} that translates to the ML value \var{v}. IDL pointers of kind "ptr" are mapped to a "Com.opaque" type. This is an abstract type that encapsulates the C pointer without attempting to convert it to an ML data structure. IDL pointers of kind "ignore" denote struct fields and function parameters that need not be exposed in the Caml code. Those pointers are simply set to null when converting from Caml to C, and ignored when converting from C to Caml. They cannot occur elsewhere. If no explicit pointer kind is given, the "pointer_default" attribute of the enclosing interface, if any, determines the kind of the pointer. If no "pointer_default" attribute is in scope, the kind "unique" is assumed. \subsection{Arrays} IDL arrays of characters that carry the "[string]" attribute are mapped to the Caml "string" type: \begin{tableau}{|l|l|}{IDL type \var{ty}}{Caml type \transl{\var{ty}}} \entree{"[string] char []"}{"string"} \entree{"[string] unsigned char []"}{"string"} \entree{"[string] signed char []"}{"string"} \entree{"[string] byte []"}{"string"} \end{tableau} Caml string values are translated to standard null-terminated C strings. Be careful about embedded null characters in the Caml string, which will be recognized as end of string by C functions. IDL arrays carrying the "[bigarray]" attribute are translated to Caml ``big arrays'', as described in the next section. All other IDL arrays are translated to ML arrays: \begin{alltt} \var{ty} [] \(\Rightarrow\) \transl{\var{ty}} array \end{alltt} For instance, "double []" becomes "float array". Consequently, multi-dimensional arrays are translated to Caml arrays of arrays. For instance, "int [][]" becomes "int array array". If the "unique" attribute is given, the IDL array is translated to an ML option type: \begin{alltt} [string,unique] char [] \(\Rightarrow\) string option [unique] \var{ty} [] \(\Rightarrow\) \transl{\var{ty}} array option \end{alltt} As in the case of pointers of kind "unique", the option value is "None" for a null C pointer, and "Some("\var{v}")" for a non-null C pointer to a C array that translates to the ML string or array \var{v}. Conversion between a C array and an ML array proceed element by element. For the conversion from C to ML, the number of elements of the ML array is determined as follows (in the order presented): \begin{itemize} \item By the "length_is" attribute, if present. \item By the "size_is" attribute, if present. \item By the bound written in the array type, if any. \item By searching the first null element of the C array, if the "null_terminated" attribute is present. \end{itemize} For instance, C values of IDL type "[length_is(n)] double[]" are mapped to Caml "float array" of "n" elements. C values of IDL type "double[10]" are mapped to Caml "float array" of 10 elements. The "length_is" and "size_is" attributes take as argument one or several limited expressions. Each expression applies to one dimension of the array. For instance, "[size_is(*dimx, *dimy)] double d[][]" specifies a matrix of "double" whose first dimension has size "*dimx" and the second has size "*dimy". \subsection{Big arrays} IDL arrays of integers or floats that carry the "[bigarray]" attribute are mapped to one of the Caml "Bigarray" types: "Array1.t" for one-dimensional arrays, "Array2.t" for 2-dimensional arrays, "Array3.t" for 3-dimensional arrays, and "Genarray.t" for arrays of 4 dimensions or more. If the "[fortran]" attribute is given, the big array is accessed from Caml using the Fortran conventions (array indices start at 1; column-major memory layout). By default, the big array is accessed from Caml using the C conventions (array indices start at 0; row-major memory layout). If the "[managed]" attribute is given on a big array type that is result type or out parameter type of a function, Caml assumes that the corresponding C array was allocated using "malloc()", and is not referenced anywhere else; then, the Caml garbage collector will free the C array when the corresponding Caml big array becomes unreachable. By default, Caml assumes that result or out C arrays are statically or permanently allocated, and keeps a pointer to them during conversion to Caml big arrays, and does not free them when the Caml bigarrays become unreachable. Finally, the "[unique]" attribute applies to bigarrays as to arrays, that is, it maps a null C pointer to "None", and a non-null C pointer \var{p} to "Some("\var{v}")" where \var{v} is the ML bigarray resulting from the translation of \var{p}. \subsection{Structs} IDL structs are mapped to Caml record types. The names and types of the IDL struct fields determine the names and types of the Caml record type: \begin{alltt} struct \var{s} \{ ... ; \nth{ty}{i} \nth{id}{i} ; ... \} {\rm becomes} type \var{s} = \{ ... ; \nth{id}{i} : \transl{\nth{ty}{i}} ; ... \} \end{alltt} Example: "struct s { int n; double d[4]; }" becomes "type s = {n: int; d: float array}". Exceptions to this rule are as follows: \begin{itemize} \item Fields of the IDL struct that are pointers with the "[ignore]" attribute do not appear in the Caml record type. Example: "struct s { double x,y; [ignore] void * data; }" becomes "type struct_s = {x : float; y: float}". Those ignored pointer fields are set to "NULL" when converting from a Caml record to a C struct. \item Integer fields of the IDL struct that appear in a "length_is", "size_is" or "switch_is" attribute of another field also do not appear in the Caml record type. (We call those fields {\em dependent} fields.) Example: "struct s { int idx; int len; [size_is(len)] double d[]; }" is translated to the Caml record type "type struct_s = {idx: int; d: float array}". The value of "len" is recovered from the size of the Caml array "d", and thus doesn't need to be represented explicitly in the Caml record. \item If, after elimination of ignored pointer fields and dependent fields as described above, the IDL struct has only one field $ty~id$, we avoid creating a one-field Caml record type and translate the IDL struct type directly to the Caml type \transl{\var{ty}}. Example: "struct s { int len; [size_is(len)] double d[]; }" is translated to the Caml type abbreviation "type struct_s = double array". \item The names of labels in the Caml record type can be changed by using the @"mlname"@ attribute on struct field declarations. For instance, \begin{alltt} struct s \{ int n; [mlname(p)] int q; \} {\rm becomes} type s = \{ n : int; p : int \} \end{alltt} \item The Caml type system makes it difficult to use two record types defined in the same module and having some label names in common. Thus, if CamlIDL encounters two or more structs having identically-named fields, it prefixes the Caml label names by the names of the structs in order to distinguish them. For instance: \begin{alltt} struct s1 \{ int x; int y; \} struct s2 \{ double x; double t; \} struct s3 \{ int z; \} {\rm becomes} type s1 = \{ s1_x: int; s1_y: int \} and s2 = \{ s2_x: float; s2_t: float \} and s3 = \{ z: int \} \end{alltt} The labels for "s1" and "s2" have been prefixed by "s1_" and "s2_" respectively, to avoid ambiguity on the "x" label. However, the label "z" for "s3" is not prefixed, since it is not used elsewhere. The prefix added in front of multiply-defined labels is taken from the struct name, if any, and otherwise from the name of the nearest enclosing struct, union or typedef. For instance: \begin{alltt} typedef struct \{ int x; \} t; struct s4 \{ struct \{ int x; \} z; \}; {\rm becomes} type t = \{ t_x: int \} and s4 = \{ z: struct_1 \} and struct_1 = \{ s4_x: int \} \end{alltt} The ``minimal prefixing'' strategy described above is the default behavior of "camlidl". If the "-prefix-all-labels" option is given, all record labels are prefixed, whether they occur several times or not. If the "-keep-labels" option is given, no automatic prefixing takes place; the naming of record labels is left entirely under the user's control, via @"mlname"@ annotations. \end{itemize} \subsection{Unions} IDL discriminated unions are translated to Caml sum types. Each case of the union corresponds to a constructor of the sum type. The constructor is constant if the union case has no associated field, otherwise has one argument corresponding to the union case field. If the union has a "default" case, an extra constructor "Default_"\var{unionname} is added to the Caml sum type, carrying an "int" argument (the value of the discriminating field), and possibly another argument corresponding to the default field. Examples: \begin{alltt} union u1 \{ case A: int x; case B: case C: double d; case D: ; \} {\rm becomes} type u1 = A of int | B of float | C of float | D union u2 \{ case A: int x; case B: double d; default: ; \} {\rm becomes} type u2 = A of int | B of float | Default_u of int union u3 \{ case A: int x; default: double d; \} {\rm becomes} type u3 = A of int | Default_v of int * double \end{alltt} All IDL unions must be discriminated, either via the special syntax "union "\var{name}" switch(int "\var{discr}")"\ldots, or via the attribute "switch_is("\var{discr}")", where \var{discr} is a C l-value built from other parameters of the current function, or other fields of the current "struct". Both the discriminant and the case labels must be of an integer type. Unless a "default" case is given, the value of the discriminant must be one of the cases of the union. \subsection{Enums} IDL enums are translated to Caml enumerated types (sum types with only constant constructors). The names of the constructors are determined by the names of the enum labels. The values attached to the enum labels are ignored. Example: "enum e { A, B = 2, C = 4 }" becomes "type enum_e = A | B | C". The @"set"@ attribute can be applied to a named enum to denote a bitfield obtained by logical ``or'' of zero, one or several labels of the enum. The corresponding ML value is a list of zero, one or several constructors of the Caml enumerated type. Consider for instance: \begin{verbatim} enum e { A = 1, B = 2, C = 4 }; typedef [set] enum e eset; \end{verbatim} The Caml type "eset" is equal to "enum_e list". The C integer 6 (= "B | C") is translated to the ML list "[B; C]". The ML list "[A; C]" is translated to the C integer "A | C", that is "5". \subsection{Type definitions} An IDL "typedef" statement is normally translated to a Caml type abbreviation. For instance, "typedef [string] char * str" becomes "type str = string". If the @"abstract"@ attribute is given, a Caml abstract type is generated instead of a type abbreviation, thus hinding from Caml the representation of the type in question. For instance, "typedef [abstract] void * handle" becomes "type handle". In this case, the IDL type in the "typedef" is ignored. If the @"mltype" "(" '"' caml-type-expr '"' ")"@ attribute is given, the Caml type is made equal to @caml-type-expr@. This is often used in conjunction with the @"ml2c"@ and @"c2ml"@ attributes to implement custom translation of data structures between C and ML. For instance, "typedef [mltype(\"int list\")] struct mylist_struct * mylist" becomes "type mylist = int list". If the @"c2ml("funct-name")" and @"ml2c("funct-name")" attributes are given, the user-provided C functions given as attributes will be called to perform Caml to C and C to Caml conversions for values of the typedef-ed type, instead of using the "camlidl"-generated conversion functions. This allows user-controlled translation of data structures. The prototypes of the conversion functions must be \begin{alltt} value c2ml(\var{ty} * input); void ml2c(value input, \var{ty} * output); \end{alltt} where \var{ty} is the name of the type defined by "typedef". In other terms, the "c2ml" function is passed a reference to a \var{ty} and returns the corresponding Caml value, while the "ml2c" function is passed a Caml value as first argument and stores the corresponding C value in the \var{ty} reference passed as second argument. If the @"finalize("final-fn")"@ attribute is given in combination with the @"abstract"@ attribute, the function @final-fn@ is called when the Caml block representing a value of this typedef becomes unreachable from Caml and is reclaimed by the Caml garbage collector. Similarly, @"compare("compare-fn")"@ and @"hash("hash-fn")"@ attach a comparison function and a hashing function (respectively) to Caml values for this typedef. The comparison function is called when two Caml values of this typedef are compared using the generic comparisons "compare", "=", "<", etc. The hashing function is called when "Hashtbl.hash" is applied to a Caml value of this typedef. The prototype of the finalization, comparison and hashing functions are: \begin{alltt} value \var{final-fn}(\var{ty} * x); int \var{compare-fn}(\var{ty} * x, \var{ty} * y); long \var{hash-fn}(\var{ty} * x); \end{alltt} That is, their arguments are passed by reference. The comparison function must return an integer that is negative, zero, or positive depending on whether its first argument is smaller, equal or greater than its second argument. The hashing function returns a suitable hash value for its argument. If the @"errorcheck("fn")"@ attribute is provided for the "typedef" \var{ty}, the error checking function @fn@ is called each time a function result of type \var{ty} is converted from C to Caml. The function can then check the \var{ty} value for values indicating an error condition, and raise the appropriate exception. If in addition the @"errorcode"@ attribute is provided, the conversion from C to Caml is suppressed: values of type \var{ty} are only passed to @fn@ for error checking, then discarded. \subsection{Functions} IDL function declarations are translated to Caml functions. The parameters and results of the Caml function are determined from those of the IDL function according to the following rules: \begin{itemize} \item First, dependent parameters (parameters that are "size_is", "length_is" or "switch_is" of other parameters) as well as parameters that are ignored pointers are removed. \item The remaining parameters are split into Caml function inputs and Caml function outputs. Parameters with the "[in]" attribute are added to the inputs of the function. Parameters with the "[out]" attribute are added to the outputs of the function. Parameters with the "[in,out]" attribute are added both to the inputs and to the outputs of the function, unless they are of type string or big array, in which case they are added to the inputs of the function only. (The reason for this exception is that strings and big arrays are shared between Caml and C, thus allowing true "in,out" behavior on the Caml function parameter, while other data types are copied during Caml/C conversion, thus turning a C "in,out" parameter into a Caml "copy in, copy out" parameter, that is, one parameter and one result.) \item The return value of the IDL function is added to the outputs of the Caml function (in first position), unless it is of type "void" or of a type name that carries the "errorcode" attribute. In the latter two cases, the return value of the IDL function is not transmitted to Caml. \item The Caml function is then given type @in_1 "->" \ldots "->" in_p "->" out_1 "*" \ldots "*" out_q@ where @in_1 \ldots in_p@ are the types of its inputs and @out_1 \ldots out_q@ are the types of its outputs. If there are no inputs, a "unit" parameter is added. If there are no outputs, a "unit" result is added. \end{itemize} Examples: \begin{alltt} int f([in] double x, [in] double y) f : float -> float -> int \end{alltt} \begin{quote} Two "double" input, one "int" output \end{quote} \begin{alltt} void g([in] int x) g : int -> unit \end{alltt} \begin{quote} One "int" input, no output \end{quote} \begin{alltt} int h() h : unit -> int \end{alltt} \begin{quote} No input, one "int" result \end{quote} \begin{alltt} void i([in] int x, [out] double * y) i : int -> double \end{alltt} \begin{quote} One "int" input, one "double" output (as an "out" parameter) \end{quote} \begin{alltt} int j([in] int x, [out] double * y) j : int -> int * double \end{alltt} \begin{quote} One "int" input, one "int" output (in the result), one "double" output (as an "out" parameter) \end{quote} \begin{alltt} void k([in,out,ref] int * x) k : int -> int \end{alltt} \begin{quote} The "in,out" parameter is both one "int" input and one "int" output. \end{quote} \begin{alltt} HRESULT l([in] int x, [out] int * res1, [out] int * res2) l : int -> int * int \end{alltt} \begin{quote} "HRESULT" is a predefined type with the "errorcode" attribute, hence it is ignored. It remains one "int" input and two "int" outputs ("out" parameters) \end{quote} \begin{alltt} void m([in] int len, [in,size_is(len)] double d[]) m : float array -> int \end{alltt} \begin{quote} "len" is a dependent parameter, hence is ignored. The only input is the "double" array \end{quote} \begin{alltt} void n([in] int inputlen, [out] int * outputlen, [in,out,size_is(inputlen),length_is(*outputlen)] double d[]) n : float array -> float array \end{alltt} \begin{quote} The two parameters "inputlen" and "outputlen" are dependent, hence ignored. The "double" array is both an input and an output. \end{quote} \begin{alltt} void p([in] int dimx, [in] int dimy, [in,out,bigarray,size_is(dimx,dimy)] double d[][]) p : (float, Bigarray.float64_elt, Bigarray.c_layout) Bigarray.Array2.t -> unit \end{alltt} \begin{quote} The two parameters "dimx" and "dimy" are dependent (determined from the dimensions of the big array argument), hence ignored. The two-dimensional array "d", although marked "[in,out]", is a big array, hence passed as an input that will be modified in place by the C function "p". The Caml function has no outputs. \end{quote} \paragraph{Error checking:} For every output that is of a named type with the @"errorcheck("fn")"@ attribute, the error checking function @fn@ is called after the C function returns. That function is assumed to raise a Caml exception if it finds an output denoting an error. \paragraph{Custom calling and deallocation sequences:} The IDL declaration for a function can optionally specify a custom calling sequence and/or a custom deallocation sequence, via @quote@ clauses following the function declaration: \begin{syntax} function-decl: attributes type-spec {'*'} ident '(' params ')' { 'quote''(' ident ',' string ')' } ; \end{syntax} The general shape of a "camlidl"-generated stub function is as follows: \begin{alltt} value caml_wrapper(value camlparam1, ..., value camlparamK) { /* Convert the function parameters from Caml to C */ param1 = ...; ... paramN = ...; /* Call the C function 'ident' */ _res = ident(param1, ..., paramN); /* Convert the function result and out parameters to Caml values */ camlres = ...; /* Return result to Caml */ return camlres; } \end{alltt} A @'quote(call,' string ')'@ clause causes the C statements in @string@ to be inserted in the generated stub code instead of the default calling sequence "_res = ident(param1, ..., paramN)". Thus, the statements in @string@ find the converted parameters in local variables that have the same names as the parameters in the IDL declaration, and should leave the result of the function, if any, in the local variable named "_res". A @'quote(dealloc,' string ')'@ clause causes the C statements in @string@ to be inserted in the generated stub code just before the stub function returns, hence after the conversion of the C function results to Caml values. Again, the statements in @string@ have access to the function result in the local variable named "_res", and to out parameters in local variables having the same names as the parameters. Since the function results and out parameters have already been converted to Caml values, the code in @string@ can safely deallocate the data structures they point to. Custom calling sequences are typically used to rearrange or combine function parameters, and to perform extra error checks on the arguments and results. For instance, the Unix "write" system call can be specified in IDL as follows: \begin{verbatim} int write([in] int fd, [in,string,length_is(len)] char * data, [in] int len, [in] int ofs, [in] int towrite) quote(call, " /* Validate the arguments */ if (ofs < 0 || ofs + towrite >= len) failwith(\"write\"); /* Perform the write */ _res = write(fd, data + ofs, towrite); /* Validate the result */ if (_res == -1) failwith(\"write\"); "); \end{verbatim} % Custom deallocation sequences are useful to free data structures dynamically allocated and returned by the C function. For instance, a C function "f" that returns a "malloc"-ed string can be specified in IDL as follows: \begin{verbatim} [string] char * f([in] int x) quote(dealloc, "free(_res); "); \end{verbatim} If the string is returned as an "out" parameter instead, we would write: \begin{verbatim} void f ([in] int x, [out, string*] char ** str) quote(dealloc, "free(*str); "); \end{verbatim} \paragraph{Blocking functions:} A function can be given the attribute "blocking" to indicate that it may block on an input/output operation. The generated code will then allow other Caml threads to execute concurrently with the operation. \subsection{Interfaces} IDL interfaces that do not have the @"object"@ attribute are essentially ignored. That is, the declarations contained in the interface are processed as if they occurred at the top-level of the IDL file. The @"pointer_default"@, @"int_default"@ and @"long_default"@ attributes to the interface can be used to specify the default pointer kind and integer mappings for the declarations contained in the interface. Other attributes, as well as the name of the super-interface if any, are ignored. IDL interfaces having the @"object"@ attribute specify COM-style object interfaces. The function declarations contained in the interface specify the methods of the COM interface. Other kinds of declarations (type declarations, @"import"@ statements, etc) are treated as if they occurred at the top-level of the IDL file. An optional super-interface can be given, in which case the COM interface implements the methods of the super-interface in addition to those specified in the IDL interface. Example: \begin{verbatim} [object, uuid(...)] interface IA { typedef int t; int f(int x); } [object] interface IB : IA { import "foo.idl"; void g([string] char * s); } \end{verbatim} This defines a type "t" and imports the file "foo.idl" as usual. In addition, two interfaces are declared: "IA", containing one method "f" from "int" to "int", and "IB", containing two methods, "f" from "int" to "int" and "g" from "string" to "unit". The definition of an object interface \var{i} generates the following Caml definitions: \begin{itemize} \item An abstract type \var{i} identifying the interface. COM interfaces of type \var{i} are represented in Caml with type \var{i} " Com.interface". \item If a super-interface $s$ is given, a conversion function $s$"_of_"\var{i} of type \var{i} " Com.interface -> " $s$ " Com.interface". \item If the "uuid("$iid$")" attribute is given, a value "iid_"\var{i} of type \var{i}" Com.iid" holding the given interface identifier. \item A Caml class \var{i}"_class", with the same methods as the COM interface. \item A function "use_"\var{i} of type \var{i} " Com.interface -> "\var{i}"_class", to transform a COM object into a Caml object. This allows the methods of the COM object to be invoked from Caml. \item A function "make_"\var{i} of type "#"\var{i}"_class -> "\var{i} " Com.interface", to transform a Caml object into a COM object with interface \var{i}. This allows the methods of the Caml object to be invoked from any COM client. \end{itemize} Example: in the "IA" and "IB" example above, the following Caml definitions are generated for "IA": \begin{verbatim} type iA val iid_iA : iA Com.iid class iA_class : iA Com.interface -> object method f : int -> int end val use_iA : iA Com.interface -> iA_class val make_iA : #iA_class -> iA Com.interface \end{verbatim} For "IB", we get: \begin{verbatim} type iB val iA_of_iB : iB Com.interface -> iA Com.interface class iB_class : iB Com.interface -> object inherit iA_class method g : string -> unit end val use_iB : iB Com.interface -> iB_class val make_iB : #iB_class -> iB Com.interface \end{verbatim} \paragraph{Error handling in interfaces:} Conventionally, methods of COM interfaces always return a result of type "HRESULT" that says whether the method succeeded or failed, and in the latter case returns an error code to its caller. When calling an interface method from Caml, if the method returns an "HRESULT" denoting failure, the exception "Com.Error" is raised with a message describing the error. Successful "HRESULT" return values are ignored. To make them available to Caml, "camlidl" defines the types "HRESULT_bool" and "HRESULT_int". If those types are used as return types instead of "HRESULT", failure results are mapped to "Com.Error" exceptions as before, but successful results are mapped to the Caml types "bool" and "int" respectively. (For "HRESULT_bool", the "S_OK" result is mapped to "true" and other successful results are mapped to "false". For "HRESULT_int", the low 16 bits of the result code are returned as a Caml "int".) When calling a Caml method from a COM client, any exception that escapes the Caml method is mapped back to a failure "HRESULT". A textual description of the uncaught exception is saved using "SetLastError", and can be consulted by the COM client using "GetLastError" (this is the standard convention for passing extended error information in COM). If the IDL return type of the method is not one of the "HRESULT" types, any exception escaping the Caml method aborts the whole program after printing a description of the exception. Hence, programmers of Caml components should either use "HRESULT" as result type, or make very sure that all exceptions are properly caught by the method. \section{Using "camlidl"} \subsection{Overview} The "camlidl" stub generator is invoked as follows: \begin{alltt} camlidl \var{options} \var{file1}.idl \var{file2}.idl ... \end{alltt} For each file \var{f}".idl" given on the command line, "camlidl" generates the following files: \begin{itemize} \item A Caml interface file \var{f}".mli" that defines the Caml view of the IDL file. It contains Caml definitions for the types declared in the IDL file, as well as declarations for the functions and the interfaces. \item A Caml implementation file \var{f}".ml" that implements the \var{f}".mli" file. \item A C source file \var{f}"_stubs.c" that contains the stub functions for converting between C and Caml data representations. \item If the "-header" option is given, a C header file \var{f}".h" containing C declarations for the types declared in the IDL file. \end{itemize} The generated ".ml" and ".c" files must be compiled and linked with the remainder of the Caml program. \subsection{Options} The following command-line options are recognized by "camlidl". \begin{options} \item["-cpp"] Pre-process the source IDL files with the C preprocessor. This option is set by default. \item["-D " \var{symbol}"="\var{value}] Define a preprocessor symbol. The option "-D"\var{symbol}"="\var{value} is passed to the C preprocessor. The \var{value} can be omitted, as in "-D" \var{symbol}, and defaults to "1". \item["-header"] Generate a C header file \var{f}".h" containing C declarations for the types and functions declared in the IDL file \var{f}".c". \item["-I " \var{dir}] Add the directory \var{dir} to the list of directories searched for ".idl" files, as given on the command line or recursively loaded by @"import"@ statements. \item["-keep-labels"] Keep the Caml names of record labels as specified in the IDL file. Do not prefix them with the name of the enclosing struct, even if they appear in several struct definitions. \item["-nocpp"] Suppresses the pre-processing of source IDL files. \item["-no-include"] By default, "camlidl" emits a "#include \""\var{f}".h\"" statement in the file \var{f}".c" containing the generated C code. The \var{f}".h" header file being included is either the one generated by "camlidl -header", or generated by another tool (such as Microsoft's "midl" compiler) from the IDL file, or hand-written. The \var{f}".h" file is assumed to provide all C type declarations needed for compiling the stub code. The "-no-include" option suppresses the automatic inclusion of the \var{f}".h" file. The IDL file should then include the right header files and provide the right type declarations via @"quote"@ statements. \item["-prefix-all-labels"] Prefix all Caml names of record labels with the name of the enclosing struct. The default is to prefix only those labels that could cause ambiguity because they appear in several struct definitions. \item["-prepro" \var{preprocessing-command}] Set the command that is executed to pre-process the source IDL files. The default is the C preprocessor. \end{options} \subsection{The "camlidldll" script} Under Windows, a "bash" script called "camlidldll" is provided to automate the construction of a DLL containing a COM component written in Caml. The script "camlidldll" accepts essentially the same command-line arguments and options as the "ocamlc" compiler. (It also accepts ".tlb" type library files on the command-line; see section~\ref{s-dispatch}, ``Dispatch interfaces'', for more information on type libraries.) It produces a DLL file that encapsulates the Caml and C object files given on the command line. Use "regsvr32 /s "\var{file}".dll" to record the components in the system registry once it is compiled to a DLL. \input{com.tex} \section{Hints on writing IDL files} \subsection{Writing an IDL file for a C library} When writing an IDL file for a C library that doesn't have an IDL interface already, the include files for that library are a good starting point: just copy the relevant type and functin declarations to the IDL file, then annotate them with IDL attributes to describe more precisely their actual behavior. The documentation of the library must be read carefully to determine the mode of function parameters ("in", "out", "inout"), the actual sizes of arrays, etc. The type definitions in the IDL file need not correspond exactly with those in the include files. Often, a cleaner Caml interface can be obtained by omitting irrelevant struct fields, or changing their types. For instance, the Unix library functions for reading library entries may use the following structure: \begin{verbatim} struct dirent { long int d_ino; __off_t d_off; unsigned short int d_reclen; unsigned char d_type; char d_name[256]; }; \end{verbatim} Of those fields, only "d_name" and "d_ino" are of interest to the user; the other fields are internal information for the library functions, are not specified in the POSIX specs, and therefore must not be used. Thus, in the IDL file, you should declare: \begin{verbatim} struct dirent { long int d_ino; char d_name[256]; }; \end{verbatim} Thus, the Caml code will have "type struct_dirent = {d_ino: int; d_name: string}" as desired. However, the generated stub code, being compiled against the ``true'' definition of "struct dirent", will find those two fields at the correct offsets in the actual struct. Special attention must be paid to integer fields or variables. By default, integer IDL types are mapped to the Caml type "int", which is convenient to use in Caml code, but loses one bit when converting from a C "long" integer, and may lose one bit (on 32-bit platforms) when converting from a C "int" integer. When the range of values represented by the C integer is small enough, this loss is acceptable. Otherwise, you should use the attributes "nativeint", "int32" or "int64" so that integer IDL types are mapped to one of the Caml boxed integer types. (We recommend that you use "int32" or "int64" for integers that are specified as being exactly 32 bit wide or 64 bit wide, and "nativeint" for unspecified "int" or "long" integers.) Yet another possibility is to declare certain integer fields or variables as "double" in the IDL file, so that they are represented by "float" in Caml, and all 32 bits of the integer are preserved in Caml. For instance, the Unix function to get the current type is declared as \begin{verbatim} time_t time(time_t * t); \end{verbatim} where "time_t" is usually defined as "long". We can nonetheless pretend (in the IDL file) that "time" returns a double: \begin{verbatim} double time() quote(" _res = time(NULL); "); \end{verbatim} This way, "time" will have the Caml type "unit -> float". Again, the stub code ``knows'' that "time" actually returns an integer, and therefore will insert the right integer-float coercions. \subsection{Sharing IDL files between MIDL and CamlIDL} The Microsoft software development kit provides a number of IDL files describing various libraries and components. In its current state, "camlidl" cannot exploit those files directly: they use many (often poorly documented) Microsoft IDL features that are not implemented yet in "camlidl"; symmetrically, "camlidl" introduces several new annotations that are not recognized by Microsoft's "midl" compiler. So, significant editing work on the IDL files is required. The C preprocessor can be used to alleviate the "camlidl"-"midl" incompatibilities: "camlidl" defines the preprocessor symbol "CAMLIDL" when preprocessing its input files, while "midl" does not. Hence, one can bracket incompatible definitions in "#ifdef CAMLIDL ... #else ... #endif". Along these lines, a C preprocessor header file, "camlidlcompat.h", is provided: it uses "#define" to remove "camlidl"-specific attributes when compiling with "midl", and to remove "midl"-specific attributes when compiling with "camlidl". Thus, an IDL file compatible with both "midl" and "camlidl" would look like this: \begin{verbatim} #include #ifndef CAMLIDL import "unknwn.idl"; // imports specific to MIDL import "oaidl.idl"; #endif import "mymodule.idl"; // imports common to MIDL and CamlIDL typedef [abstract,marshal_as(int)] void * ptr; ... #ifndef CAMLIDL [...] library MyTypeLib { importlib("stdole32.tlb"); [...] coclass MyComponent { [default] interface IX; } } #endif \end{verbatim} Notice that since "camlidl" doesn't handle type libraries, the type library part of an "midl" file must be enclosed in "#ifndef CAMLIDL". \subsection{Dispatch interfaces and type libraries} \label{s-dispatch} A dispatch interface, in COM lingo, is an interface that supports dynamic, interpreted dispatch of method interfaces. This form of interpreted dispatch is used by Visual Basic and other scripting languages to perform calls to methods of COM components. CamlIDL provides minimal support for dispatch interfaces. To equip a Caml component with a dispatch interface (thus making it callable from Visual Basic), you need to do the following: \begin{enumerate} \item Use "IDispatch" instead of "IUnknown" as the super-interface of the component's interfaces. \item Write a type library for your component and compile it using "midl". A type library is a run-time representation of the interfaces supported by an object. The "midl" compiler can generate a type library from the IDL description of the component, enriched with some special-purpose declarations (the "library" and "coclass" statements). Refer to the documentation of "midl" for more information. \item Pass the type library files (".tlb" files) generated by "midl" as extra arguments to "camlidldll" when generating the DLL for your Caml component. \end{enumerate} \section{Release notes} Here are some caveats and open issues that apply to the current release. \paragraph{Deallocation of function results and "out" parameters:} If a C function dynamically allocates some of its outputs (either returned or stored in "out" parameters), its IDL declaration must contain a @'quote(dealloc,' string ')'@ clause to properly free the space occupied by those outputs after they have been converted to Caml. Otherwise, memory leaks will occur. (The only exception is results and output parameters of type "[bigarray,managed] "\var{ty}"[]", where the Caml garbage collector takes care of deallocation.) This does not conform to the MIDL and COM specifications, which say that space for "out" data structures must be allocated with "CoTaskMemAlloc" by the callee, and automatically freed using "CoTaskMemFree" by the generated stub code. (The specs don't say what happens with the return value of the function.) However, there are many functions in Win32 (not to mention the Unix world) that do not follow this convention, and return data structures (e.g. strings) that are statically allocated, or require special deallocation functions. Hence, "camlidl" leaves deallocation of outputs entirely under user control. \paragraph{Allocation and deallocation of "in,out" parameters:} For "in,out" parameters, the MIDL/COM rules are that the caller (the stub code) should allocate the inputs, the callee should free them and allocate again its outputs, and the caller should free the outputs. As explained above, "camlidl"-generated stubs don't automatically free the outputs. Worse, the inputs passed to the functions are allocated partially on the stack and partially in the heap (using "CoTaskMemAlloc"), so the callee may perform an incorrect free on a stack-allocated argument. The best thing to do is avoid "in,out" parameters entirely, and split them into one "in" and one "out" parameter. \paragraph{Reference-counting of COM interfaces:} Caml finalized objects are used to call "Release" automatically on COM interfaces that become unreachable. The reference counting of interfaces passed as "in" and "out" parameters is correctly implemented. However, "in,out" parameters that are interfaces are not correctly handled. Again, avoid "in,out" parameters. \paragraph{COM support:} The support for COM is currently quite small. COM components registered in the system registry can be imported via "Com.create_instance". Components written in Caml can be exported as DLLs, but not yet as standalone servers. Preliminary support for dispatch interfaces is available, however many of the data types used in the Automation framework are not supported yet (e.g. "SAFEARRAY"). camlidl-camlidl109/lib/000077500000000000000000000000001366176261100150775ustar00rootroot00000000000000camlidl-camlidl109/lib/.depend000066400000000000000000000000561366176261100163400ustar00rootroot00000000000000com.cmi : com.cmo : com.cmi com.cmx : com.cmi camlidl-camlidl109/lib/Makefile000066400000000000000000000031561366176261100165440ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile,v 1.4 2002-04-22 11:50:47 xleroy Exp $ include ../config/Makefile BYTEOBJS=com.cmo BYTELIB=com.cma NATIVEOBJS=$(BYTEOBJS:.cmo=.cmx) NATIVELIB=$(BYTELIB:.cma=.cmxa) INTERFACES=$(BYTEOBJS:.cmo=.cmi) all: $(BYTELIB) $(NATIVELIB) $(BYTELIB): $(BYTEOBJS) $(OCAMLC) -a -o $(BYTELIB) -dllib -lcamlidl -cclib -lcamlidl $(BYTEOBJS) $(NATIVELIB): $(NATIVEOBJS) $(OCAMLOPT) -a -o $(NATIVELIB) -cclib -lcamlidl $(NATIVEOBJS) install: cp $(INTERFACES) $(BYTELIB) $(NATIVELIB) $(NATIVELIB:.cmxa=.$(LIBEXT)) $(OCAMLLIB) cd $(OCAMLLIB); $(RANLIB) $(NATIVELIB:.cmxa=.$(LIBEXT)) .SUFFIXES: .mli .ml .cmi .cmo .cmx .mli.cmi: $(OCAMLC) -c $< .ml.cmo: $(OCAMLC) -c $< .ml.cmx: $(OCAMLOPT) -c $< # Clean up clean:: rm -f *.cm[ioax] *.cmxa *.[ao] *.lib *~ # Dependencies depend: $(OCAMLDEP) *.mli *.ml > .depend include .depend camlidl-camlidl109/lib/com.ml000066400000000000000000000040271366176261100162120ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License. *) (* *) (***********************************************************************) (* $Id: com.ml,v 1.9 2004-07-08 09:44:40 xleroy Exp $ *) (* Run-time library for COM components *) type 'a interface type 'a iid type 'a opaque type clsid = string exception Error of int * string * string external initialize : unit -> unit = "camlidl_com_initialize" external uninitialize : unit -> unit = "camlidl_com_uninitialize" external query_interface: 'a interface -> 'b iid -> 'b interface = "camlidl_com_queryInterface" type iUnknown type iDispatch let iUnknown_of (intf : 'a interface) = (Obj.magic intf : iUnknown interface) let _ = Callback.register_exception "Com.Error" (Error(0, "", "")) external combine: 'a interface -> 'b interface -> 'a interface = "camlidl_com_combine" external clsid: string -> clsid = "camlidl_com_parse_uid" external _parse_iid: string -> 'a iid = "camlidl_com_parse_uid" external create_instance : clsid -> 'a iid -> 'a interface = "camlidl_com_create_instance" type 'a component_factory = { create : unit -> 'a interface; clsid : clsid; friendly_name : string; ver_ind_prog_id : string; prog_id : string } external register_factory : 'a component_factory -> unit = "camlidl_com_register_factory" type hRESULT_int = int type hRESULT_bool = bool type bSTR = string camlidl-camlidl109/lib/com.mli000066400000000000000000000127221366176261100163640ustar00rootroot00000000000000(***********************************************************************) (* *) (* CamlIDL *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License. *) (* *) (***********************************************************************) (* $Id: com.mli,v 1.10 2000-08-19 11:04:59 xleroy Exp $ *) (* Module [Com]: run-time library for COM components *) type 'a interface (* The type of COM components implementing interface ['a] *) type 'a iid (* The type of the interface identifier for interface ['a] *) type clsid (* The type of component identifiers *) type 'a opaque (* The type representing opaque pointers to values of type ['a]. Opaque pointers are pointers with attribute [ptr] in IDL files. *) exception Error of int * string * string (* Exception raised to report Com errors. The arguments are [Error(errcode, who, what)]. [errcode] is the Com error code ([HRESULT] code) with the high bit clear. [who] identifies the function or method that raised the exception. [what] is a message explaining the cause of the error. *) val initialize : unit -> unit (* Initialize the COM library. Must be called once before using any function in this module. [Com.initialize] can be called several times, provided that [Com.uninitialize] is called an equal number of times before the program exits. *) val uninitialize : unit -> unit (* Terminate the COM library. *) val query_interface : 'a interface -> 'b iid -> 'b interface (* [Com.query_interface comp iid] asks the component [comp] whether it supports the interface identified by [iid]. If yes, it returns the corresponding interface of the component. If not, it raises [Com.Error]. *) type iUnknown (* The type of the interface [IUnknown], from which all other interfaces derive. *) type iDispatch (* The type of the interface [IDispatch], from which all dispatch interfaces derive. *) val iUnknown_of : 'a interface -> iUnknown interface (* Return the [IUnknown] interface of the given component. This operation never fails, since all components support the [IUnknown] interface. *) val combine : 'a interface -> 'b interface -> 'a interface (* Combine the interfaces of two components. [Com.combine c1 c2] returns a component that supports the union of the interfaces supported by [c1] and [c2]. When queried for an interface, the resulting component delegates its implementation to [c1] if [c1] implements that interface, and otherwise delegates its implementation to [c2]. *) val clsid : string -> clsid (* Parse the string representation of a component identifier ([hex8-hex4-hex4-hex4-hex12], where [hexN] represents [N] hexadecimal digits). *) val create_instance : clsid -> 'a iid -> 'a interface (* [Com.create_instance clsid iid] creates an instance of the component identified by [clsid], and returns its [iid] interface. The implementation of the component is searched in the registry; if the component is implemented in a DLL, the DLL is loaded in memory if necessary; if the component is implemented in a separate server process, the server is started if necessary. Raise [Com.Error] if the component [clsid] cannot be found, or if it does not support interface [iid]. *) type 'a component_factory = { create : unit -> 'a interface; clsid : clsid; friendly_name : string; ver_ind_prog_id : string; prog_id : string } (* Informations required for registering a Caml implementation of a component. [create] is a function that returns a fresh instance of the component. [clsid] is the component identifier. [friendly_name] is a short description of the component (for information only). [ver_ind_prog_id] and [prog_id] are symbolic names for the component. By convention, [prog_id] is [ver_ind_prog_id] plus a version number at the end, i.e. [ver_ind_prog_id] is ["MyCamlComponent"] while [prog_id] is ["MyCamlComponent.3"]. *) val register_factory : 'a component_factory -> unit (* Register a Caml implementation of a component. [Com.register_factory f] stores the component factory [f] in the registry. Other programs can then create instances of the component by calling [CreateInstance] from C and C++ or [Com.create_instance] from Caml. *) type hRESULT_int = int type hRESULT_bool = bool type bSTR = string (* The Caml types corresponding to the IDL types [HRESULT_int], [HRESULT_bool] and [BSTR], respectively. *) (*--*) val _parse_iid : string -> 'a iid camlidl-camlidl109/runtime/000077500000000000000000000000001366176261100160145ustar00rootroot00000000000000camlidl-camlidl109/runtime/Makefile000066400000000000000000000016241366176261100174570ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile,v 1.2 2000-08-19 11:04:59 xleroy Exp $ include ../config/Makefile include Makefile.$(OSTYPE) camlidl-camlidl109/runtime/Makefile.unix000066400000000000000000000026161366176261100204430ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile.unix,v 1.5 2000-08-19 11:05:00 xleroy Exp $ OBJS=idlalloc.o comintf.o comerror.o all: dllcamlidl.so libcamlidl.a dllcamlidl.so libcamlidl.a: $(OBJS) - rm -f $@ ocamlmklib -o camlidl $(OBJS) #libcamlidl.a: $(OBJS) # - rm -f $@ # ar rc $@ $(OBJS) # $(RANLIB) $@ install: cp camlidlruntime.h $(OCAMLLIB)/caml/camlidlruntime.h cp libcamlidl.a $(OCAMLLIB)/libcamlidl.a cp dllcamlidl.so $(OCAMLLIB)/stublibs/dllcamlidl.so cd $(OCAMLLIB); $(RANLIB) libcamlidl.a clean: rm -f *.a *.o *.so .SUFFIXES: .c .o .c.o: $(OCAMLC) -ccopt "$(CFLAGS)" $< $(OBJS): camlidlruntime.h comstuff.h depend: camlidl-camlidl109/runtime/Makefile.win32000066400000000000000000000026711366176261100204230ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile.win32,v 1.7 2000-08-19 11:05:00 xleroy Exp $ CC=cl CFLAGS=/nologo /Zi /MT /I$(OCAMLLIB) OBJS=idlalloc.obj comintf.obj comerror.obj superror.obj \ registry.obj dispatch.obj oletypes.obj all: libcamlidl.lib cfactory.obj libcamlidl.lib: $(OBJS) - rm -f $@ lib /nologo /debugtype:CV /out:$@ $(OBJS) install: cp camlidlruntime.h $(OCAMLLIB)/caml/camlidlruntime.h cp libcamlidl.lib $(OCAMLLIB)/libcamlidl.lib cp cfactory.obj $(OCAMLLIB)/cfactory.obj clean: rm -f *.lib *.obj .SUFFIXES: .c .cpp .obj .c.obj: $(CC) $(CFLAGS) -c $< .cpp.obj: $(CC) $(CFLAGS) -c $< $(OBJS) cfactory.obj: camlidlruntime.h comstuff.h registry.h depend: camlidl-camlidl109/runtime/camlidlruntime.h000066400000000000000000000125771366176261100212120ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: camlidlruntime.h,v 1.13 2004-07-08 09:48:15 xleroy Exp $ */ /* Helper functions for stub code generated by camlidl */ #include #include #include /* Functions for allocating in the Caml heap */ #define camlidl_alloc caml_alloc #define camlidl_alloc_small caml_alloc_small /* Helper functions for conversion */ 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 */ typedef void (* camlidl_free_function)(void *); struct camlidl_block_list { camlidl_free_function free_fn; void * block; struct camlidl_block_list * next; }; struct camlidl_ctx_struct { int flags; struct camlidl_block_list * head; }; #define CAMLIDL_TRANSIENT 1 #define CAMLIDL_ADDREF 2 typedef struct camlidl_ctx_struct * camlidl_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); /* Helper functions for handling COM interfaces */ #ifdef _WIN32 #include #else #define interface struct typedef struct { unsigned int Data1; unsigned short Data2, Data3; unsigned char Data4[8]; } GUID, IID; typedef IID * REFIID; typedef int HRESULT; #define S_OK 0 typedef unsigned long ULONG; #define SetErrorInfo(x,y) #define STDMETHODCALLTYPE #endif typedef HRESULT HRESULT_int; typedef HRESULT HRESULT_bool; #if defined(__GNUC__) #define DECLARE_VTBL_PADDING void * padding; void * constr; #define VTBL_PADDING 0, 0, #else #define DECLARE_VTBL_PADDING #define VTBL_PADDING #endif extern void * camlidl_unpack_interface(value vintf, camlidl_ctx ctx); extern value camlidl_pack_interface(void * intf, camlidl_ctx ctx); struct camlidl_component; struct camlidl_intf { void * vtbl; value caml_object; IID * iid; struct camlidl_component * comp; void * typeinfo; }; struct camlidl_component { int numintfs; long refcount; struct camlidl_intf intf[1]; }; 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 */ extern HRESULT STDMETHODCALLTYPE camlidl_QueryInterface(struct camlidl_intf * self, REFIID iid, void ** object); extern ULONG STDMETHODCALLTYPE camlidl_AddRef(struct camlidl_intf * self); extern ULONG STDMETHODCALLTYPE camlidl_Release(struct camlidl_intf * self); /* Extra methods for the IDispatch interface */ #ifdef _WIN32 extern HRESULT STDMETHODCALLTYPE camlidl_GetTypeInfoCount(struct camlidl_intf * self, UINT * count_type_info); extern HRESULT STDMETHODCALLTYPE camlidl_GetTypeInfo(struct camlidl_intf * self, UINT iTypeInfo, LCID localization, ITypeInfo ** res); extern HRESULT STDMETHODCALLTYPE camlidl_GetIDsOfNames(struct camlidl_intf * self, REFIID iid, OLECHAR** arrayNames, UINT countNames, LCID localization, DISPID * arrayDispIDs); 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 /* Raise an error */ extern void camlidl_error(HRESULT errcode, char * who, char * msg); /* Handle HRESULTs */ 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 */ 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 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 camlidl-camlidl109/runtime/cfactory.cpp000066400000000000000000000134731366176261100203420ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: cfactory.cpp,v 1.9 2004-07-08 09:48:33 xleroy Exp $ */ /* The class factory and DLL support */ #include extern "C" { #include #include #include #include #include #include #include "camlidlruntime.h" } #include "comstuff.h" #include "registry.h" #ifdef __CYGWIN32__ #include #define _MAX_PATH MAXPATHLEN #endif /* Count of server locks */ static long camlidl_num_server_locks = 0; /* The class factory */ class camlidl_factory : public IClassFactory { private: struct camlidl_comp * comp; long refcount; public: virtual HRESULT __stdcall QueryInterface(const IID& iid, void** ppv) { if ((iid == IID_IUnknown) || (iid == IID_IClassFactory)) { *ppv = (IClassFactory*)(this); AddRef(); return S_OK; } else { *ppv = NULL ; return E_NOINTERFACE ; } } virtual ULONG __stdcall AddRef() { return InterlockedIncrement(&refcount); } virtual ULONG __stdcall Release() { ULONG res = InterlockedDecrement(&refcount); if (res == 0) delete this; return res; } virtual HRESULT __stdcall CreateInstance(IUnknown* pUnknownOuter, const IID& iid, void** object) { struct camlidl_ctx_struct ctx = { CAMLIDL_ADDREF, NULL }; // Aggregation is not supported yet if (pUnknownOuter != NULL) return CLASS_E_NOAGGREGATION; // Create the component value vcomp = callback(Field(this->comp->compdata, COMPDATA_CREATE), Val_unit); IUnknown * comp = (IUnknown *) camlidl_unpack_interface(vcomp, &ctx); // Get the requested interface HRESULT res = comp->QueryInterface(iid, object); // Release the initial pointer to the component // (if QueryInterface failed, it will destroy itself) comp->Release(); // Return result of QueryInterface return res; } virtual HRESULT __stdcall LockServer(BOOL bLock) { if (bLock) InterlockedIncrement(&camlidl_num_server_locks); else InterlockedDecrement(&camlidl_num_server_locks); return S_OK ; } // Constructor camlidl_factory(struct camlidl_comp * comp_init) { comp = comp_init; refcount = 1; } }; // The class factory server STDAPI DllGetClassObject(const CLSID & clsid, const IID & iid, void ** object) { struct camlidl_comp * c; for (c = camlidl_registered_components; c != NULL; c = c->next) { if (clsid == GUID_val(Field(c->compdata, COMPDATA_CLSID))) { // Create class factory camlidl_factory * f = new camlidl_factory(c); if (f == NULL) return E_OUTOFMEMORY; // Get requested interface HRESULT res = f->QueryInterface(iid, object); // Release the class factory; // if QueryInterface failed, it will free itself f->Release(); // Return result of QueryInterface return res; } } *object = NULL; return CLASS_E_CLASSNOTAVAILABLE; } /* Server registration */ STDAPI DllRegisterServer() { struct camlidl_comp * c; for (c = camlidl_registered_components; c != NULL; c = c->next) { HRESULT retcode = RegisterServer( camlidl_module_handle, GUID_val(Field(c->compdata, COMPDATA_CLSID)), String_val(Field(c->compdata, COMPDATA_FRIENDLY_NAME)), String_val(Field(c->compdata, COMPDATA_VER_IND_PROG_ID)), String_val(Field(c->compdata, COMPDATA_PROG_ID))); if (FAILED(retcode)) return retcode; } return S_OK; } /* Server unregistration */ STDAPI DllUnregisterServer() { struct camlidl_comp * c; for (c = camlidl_registered_components; c != NULL; c = c->next) { HRESULT retcode = UnregisterServer( GUID_val(Field(c->compdata, COMPDATA_CLSID)), String_val(Field(c->compdata, COMPDATA_VER_IND_PROG_ID)), String_val(Field(c->compdata, COMPDATA_PROG_ID))); if (FAILED(retcode)) return retcode; } return S_OK; } /* Can DLL unload now? */ STDAPI DllCanUnloadNow() { if (camlidl_num_components == 0 && camlidl_num_server_locks == 0) return S_OK; else return S_FALSE; } #if 0 #include #include #include #include #endif /* DLL entry point */ #if OCAML_VERSION_MAJOR > 4 || (OCAML_VERSION_MAJOR == 4 && OCAML_VERSION_MINOR >= 6) #define USE_WIDE_CHARS #else typedef char char_os; #undef USE_WIDE_CHARS #endif BOOL APIENTRY DllMain(HANDLE module, DWORD reason, void *reserved) { char_os * argv[2]; char_os dll_path[_MAX_PATH]; switch(reason) { case DLL_PROCESS_ATTACH: #ifdef USE_WIDE_CHARS GetModuleFileNameW( (HMODULE) module, dll_path, _MAX_PATH ); #else GetModuleFileNameA( (HMODULE) module, dll_path, _MAX_PATH ); #endif 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); dup2(fd, 1); dup2(fd, 2); close(fd); #endif caml_startup(argv); break; /* TODO: free all memory when DLL detached */ } return TRUE; } camlidl-camlidl109/runtime/comerror.c000066400000000000000000000123751366176261100200200ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: comerror.c,v 1.11 2001-06-17 10:51:24 xleroy Exp $ */ /* Error handling */ #include #include #include #include #include #include #include #include #include #include "camlidlruntime.h" #include "comstuff.h" static void camlidl_raise_error(HRESULT errcode, char * who, char * msg) { static const value * com_error_exn = NULL; value bucket, vwho = Val_unit, vmsg = Val_unit; if (com_error_exn == NULL) { com_error_exn = caml_named_value("Com.Error"); if (com_error_exn == NULL) invalid_argument("Exception Com.Error not initialized"); } Begin_roots2(vwho,vmsg) vwho = copy_string(who); vmsg = copy_string(msg); bucket = alloc_small(4, 0); Field(bucket, 0) = *com_error_exn; Field(bucket, 1) = Val_long(errcode); Field(bucket, 2) = vwho; Field(bucket, 3) = vmsg; End_roots(); mlraise(bucket); } void camlidl_error(HRESULT errcode, char * who, char * what) { #ifdef _WIN32 char msg[1024]; #endif if (what == NULL) { #ifdef _WIN32 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, /* message source */ errcode, 0, /* language */ msg, /* message buffer */ sizeof(msg),/* max size */ NULL) /* inserts */ != 0) what = msg; else what = "Unknown error"; #else what = "Unknown error"; #endif } camlidl_raise_error(errcode, who, what); } static void camlidl_hresult_error(HRESULT errcode) { /* Build text representation of errcode */ #ifdef _WIN32 interface IErrorInfo * errinfo = NULL; BSTR source, descr; char who[1024], what[1024]; /* Try to use GetErrorInfo */ GetErrorInfo(0L, &errinfo); if (errinfo != NULL) { errinfo->lpVtbl->GetSource(errinfo, &source); _snprintf(who, sizeof(who) - 1, "%ls", source); who[sizeof(who) - 1] = 0; errinfo->lpVtbl->GetDescription(errinfo, &descr); _snprintf(what, sizeof(who) - 1, "%ls", descr); what[sizeof(what) - 1] = 0; SysFreeString(source); SysFreeString(descr); errinfo->lpVtbl->Release(errinfo); camlidl_error(errcode, who, what); } else { camlidl_error(errcode, "", NULL); } #else camlidl_error(errcode, "", NULL); #endif } void camlidl_check_hresult(HRESULT hr) { if (FAILED(hr)) camlidl_hresult_error(hr); } value camlidl_c2ml_Com_HRESULT_bool(HRESULT_bool * hr, camlidl_ctx ctx) { return Val_bool(*hr == S_OK); } void camlidl_ml2c_Com_HRESULT_bool(value v, HRESULT * hr, camlidl_ctx ctx) { *hr = Bool_val(v) ? S_OK : S_FALSE; } value camlidl_c2ml_Com_HRESULT_int(HRESULT_int * hr, camlidl_ctx ctx) { return Val_int(HRESULT_CODE(*hr)); } void camlidl_ml2c_Com_HRESULT_int(value v, HRESULT * hr, camlidl_ctx ctx) { *hr = MAKE_HRESULT(SEVERITY_SUCCESS, FACILITY_NULL, Int_val(v) & 0xFFFF); } HRESULT camlidl_result_exception(char * methname, value exn_bucket) { /* TODO: clever mapping of exception to HRESULTS ? */ #ifdef _WIN32 interface ICreateErrorInfo * createrr; interface IErrorInfo * errinfo; int wstrlen; wchar_t * wstr; char * exndesc; if (SUCCEEDED(CreateErrorInfo(&createrr))) { wstrlen = strlen(methname); wstr = (wchar_t *) malloc((wstrlen + 1) * sizeof(wchar_t)); if (wstr != NULL) { mbstowcs(wstr, methname, wstrlen + 1); createrr->lpVtbl->SetSource(createrr, wstr); free(wstr); } exndesc = format_caml_exception(exn_bucket); if (exndesc != NULL) { wstrlen = strlen(exndesc); wstr = (wchar_t *) malloc((wstrlen + 1) * sizeof(wchar_t)); if (wstr != NULL) { mbstowcs(wstr, exndesc, wstrlen + 1); createrr->lpVtbl->SetDescription(createrr, wstr); free(wstr); } free(exndesc); } if (SUCCEEDED(createrr->lpVtbl->QueryInterface(createrr, &IID_IErrorInfo, (void **) &errinfo))) { SetErrorInfo(0L, errinfo); errinfo->lpVtbl->Release(errinfo); } createrr->lpVtbl->Release(createrr); } #endif return MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x200); } void camlidl_uncaught_exception(char * methname, value exn_bucket) { char * msg = format_caml_exception(exn_bucket); fprintf(stderr, "Uncaught exception in COM method %s: %s\n", methname, msg); free(msg); exit(2); } camlidl-camlidl109/runtime/comintf.c000066400000000000000000000176641366176261100176350ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: comintf.c,v 1.11 2004-07-08 09:49:37 xleroy Exp $ */ /* Helper functions for handling COM interfaces */ #include #include #include #include #include #include #include #include "camlidlruntime.h" #include "comstuff.h" int camlidl_num_components = 0; static void camlidl_finalize_interface(value intf) { interface IUnknown * i = (interface IUnknown *) Field(intf, 1); i->lpVtbl->Release(i); } value camlidl_pack_interface(void * intf, camlidl_ctx ctx) { value res = alloc_final(2, camlidl_finalize_interface, 0, 1); Field(res, 1) = (value) intf; if (ctx != NULL && (ctx->flags & CAMLIDL_ADDREF)) { struct IUnknown * i = (struct IUnknown *) intf; i->lpVtbl->AddRef(i); } return res; } void * camlidl_unpack_interface(value vintf, camlidl_ctx ctx) { struct IUnknown * intf = (struct IUnknown *) Field(vintf, 1); if (ctx != NULL && (ctx->flags & CAMLIDL_ADDREF)) { intf->lpVtbl->AddRef(intf); } return (void *) intf; } value camlidl_make_interface(void * vtbl, value caml_object, IID * iid, int has_dispatch) { struct camlidl_component * comp = (struct camlidl_component *) stat_alloc(sizeof(struct camlidl_component)); comp->numintfs = 1; comp->refcount = 1; comp->intf[0].vtbl = vtbl; comp->intf[0].caml_object = caml_object; comp->intf[0].iid = iid; comp->intf[0].comp = comp; #ifdef _WIN32 comp->intf[0].typeinfo = has_dispatch ? camlidl_find_typeinfo(iid) : NULL; #else if (has_dispatch) camlidl_error(0, "Com.make_xxx", "Dispatch interfaces not supported"); comp->intf[0].typeinfo = NULL; #endif register_global_root(&(comp->intf[0].caml_object)); InterlockedIncrement(&camlidl_num_components); return camlidl_pack_interface(&(comp->intf[0]), NULL); } /* Basic methods (QueryInterface, AddRef, Release) for COM objects encapsulating a Caml object */ HRESULT STDMETHODCALLTYPE camlidl_QueryInterface(struct camlidl_intf * this, REFIID iid, void ** object) { struct camlidl_component * comp = this->comp; int i; for (i = 0; i < comp->numintfs; i++) { if (comp->intf[i].iid != NULL && IsEqualIID(iid, comp->intf[i].iid)) { *object = (void *) &(comp->intf[i]); InterlockedIncrement(&(comp->refcount)); return S_OK; } } #ifdef _WIN32 if (IsEqualIID(iid, &IID_IUnknown)) { *object = (void *) this; InterlockedIncrement(&(comp->refcount)); return S_OK; } if (this->typeinfo != NULL && IsEqualIID(iid, &IID_IDispatch)) { *object = (void *) this; InterlockedIncrement(&(comp->refcount)); return S_OK; } if (IsEqualIID(iid, &IID_ISupportErrorInfo)) { *object = (void *) camlidl_support_error_info(this); return S_OK; } #endif *object = NULL; return E_NOINTERFACE; } ULONG STDMETHODCALLTYPE camlidl_AddRef(struct camlidl_intf * this) { return InterlockedIncrement(&(this->comp->refcount)); } ULONG STDMETHODCALLTYPE camlidl_Release(struct camlidl_intf * this) { struct camlidl_component * comp = this->comp; ULONG newrefcount = InterlockedDecrement(&(comp->refcount)); int i; if (newrefcount == 0) { for (i = 0; i < comp->numintfs; i++) { struct camlidl_intf * intf = &(comp->intf[i]); remove_global_root(&(intf->caml_object)); if (intf->typeinfo != NULL) { struct IUnknown * i = (struct IUnknown *) intf->typeinfo; i->lpVtbl->Release(i); } } stat_free(comp); InterlockedDecrement(&camlidl_num_components); } return newrefcount; } /* Query a COM interface */ value camlidl_com_queryInterface(value vintf, value viid) { void * res; HRESULT hr; interface IUnknown * intf = (interface IUnknown *) camlidl_unpack_interface(vintf, NULL); hr = intf->lpVtbl->QueryInterface(intf, &GUID_val(viid), &res); if (FAILED(hr)) camlidl_error(hr, "Com.queryInterface", "Interface not available"); return camlidl_pack_interface(res, NULL); } /* Combine the interfaces of two Caml components */ #define is_a_caml_interface(i) \ ((void *) (((interface IUnknown *) i)->lpVtbl->QueryInterface) == \ (void *) camlidl_QueryInterface) value camlidl_com_combine(value vintf1, value vintf2) { struct camlidl_intf * i1, * i2; struct camlidl_component * c1, * c2, * c; int n, i; i1 = camlidl_unpack_interface(vintf1, NULL); i2 = camlidl_unpack_interface(vintf2, NULL); if (! is_a_caml_interface(i1) || ! is_a_caml_interface(i2)) camlidl_error(CLASS_E_NOAGGREGATION, "Com.combine", "Not a Caml interface"); c1 = i1->comp; c2 = i2->comp; n = c1->numintfs + c2->numintfs; c = (struct camlidl_component *) stat_alloc(sizeof(struct camlidl_component) + sizeof(struct camlidl_intf) * (n - 1)); InterlockedIncrement(&camlidl_num_components); c->numintfs = n; c->refcount = 1; for (i = 0; i < c1->numintfs; i++) c->intf[i] = c1->intf[i]; for (i = 0; i < c2->numintfs; i++) c->intf[c1->numintfs + i] = c2->intf[i]; for (i = 0; i < n; i++) { register_global_root(&(c->intf[i].caml_object)); c->intf[i].comp = c; } return camlidl_pack_interface(c->intf + (i1 - c1->intf), NULL); } /* Create an instance of a component */ value camlidl_com_create_instance(value clsid, value iid) { #ifdef _WIN32 void * instance; HRESULT res; res = CoCreateInstance(&GUID_val(clsid), NULL, CLSCTX_ALL, &GUID_val(iid), &instance); if (FAILED(res)) camlidl_error(res, "Com.create_instance", NULL); return camlidl_pack_interface(instance, NULL); #else invalid_argument("Com.create_instance not implemented"); #endif } /* Initialization, termination */ value camlidl_com_initialize(value unit) { #ifdef _WIN32 OleInitialize(NULL); #endif return Val_unit; } value camlidl_com_uninitialize(value unit) { #ifdef _WIN32 OleUninitialize(); #endif return Val_unit; } /* Register a Caml component factory */ struct camlidl_comp * camlidl_registered_components = NULL; value camlidl_com_register_factory(value compdata) { struct camlidl_comp * c = stat_alloc(sizeof(struct camlidl_comp)); c->compdata = compdata; register_global_root(&(c->compdata)); c->next = camlidl_registered_components; camlidl_registered_components = c; return Val_unit; } /* Parse and allocate an UID */ value camlidl_com_parse_uid(value str) { value res; int u1, u2, u3, u4, u5, u6, u7, u8, u9, u10, u11; if (string_length(str) != 36 || sscanf(String_val(str), "%8x-%4x-%4x-%2x%2x-%2x%2x%2x%2x%2x%2x", &u1, &u2, &u3, &u4, &u5, &u6, &u7, &u8, &u9, &u10, &u11) != 11) camlidl_error(CO_E_IIDSTRING, "Com.clsid", "Badly formed GUID"); res = alloc_small((sizeof(GUID) + sizeof(value) - 1) / sizeof(value), Abstract_tag); GUID_val(res).Data1 = u1; GUID_val(res).Data2 = u2; GUID_val(res).Data3 = u3; GUID_val(res).Data4[0] = u4; GUID_val(res).Data4[1] = u5; GUID_val(res).Data4[2] = u6; GUID_val(res).Data4[3] = u7; GUID_val(res).Data4[4] = u8; GUID_val(res).Data4[5] = u9; GUID_val(res).Data4[6] = u10; GUID_val(res).Data4[7] = u11; return res; } camlidl-camlidl109/runtime/comstuff.h000066400000000000000000000053721366176261100200220ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: comstuff.h,v 1.11 2001-06-09 14:48:20 xleroy Exp $ */ /* Load or emulate COM-related includes */ #ifdef _WIN32 #include #include #else /* Emulation for other OS */ interface IUnknown; struct IUnknownVtbl { DECLARE_VTBL_PADDING HRESULT (*QueryInterface)(interface IUnknown * this, IID * iid, void ** object); ULONG (*AddRef)(interface IUnknown * this); ULONG (*Release)(interface IUnknown * this); }; interface IUnknown { struct IUnknownVtbl * lpVtbl; }; #define IsEqualIID(a,b) (memcmp(a, b, sizeof(IID)) == 0) #define InterlockedIncrement(p) (++(*(p))) #define InterlockedDecrement(p) (--(*(p))) #define S_TRUE S_OK #define S_FALSE 1 #define E_NOINTERFACE 0x80004002 #define CLASS_E_NOAGGREGATION 0x80040110 #define CO_E_IIDSTRING 0x800401f4 #define FAILED(hr) ((hr) & 0x80000000) #define HRESULT_CODE(hr) ((hr) & 0xFFFF) #define SEVERITY_ERROR 1 #define SEVERITY_SUCCESS 0 #define FACILITY_NULL 0 #define FACILITY_ITF 4 #define MAKE_HRESULT(s,f,c) (((s) << 31) | ((f) << 16) | (c)) #endif /* Internal functions and data */ #ifdef __cplusplus extern "C"{ #endif #define GUID_val(v) (*((GUID *) Bp_val(v))) /* Count of active component instances */ extern int camlidl_num_components; /* Handle for module (for the DLL) */ #ifdef _WIN32 extern HMODULE camlidl_module_handle; #endif /* The list of all registered components */ struct camlidl_comp { value compdata; struct camlidl_comp * next; }; extern struct camlidl_comp * camlidl_registered_components; /* Structure of the "compdata" Caml record */ #define COMPDATA_CREATE 0 #define COMPDATA_CLSID 1 #define COMPDATA_FRIENDLY_NAME 2 #define COMPDATA_VER_IND_PROG_ID 3 #define COMPDATA_PROG_ID 4 /* Build a ISupportErrorInfo interface */ struct ISupportErrorInfo * camlidl_support_error_info(struct camlidl_intf * i); /* Find the type library for the given IID */ struct IUnknown * camlidl_find_typeinfo(IID * iid); #ifdef __cplusplus } #endif camlidl-camlidl109/runtime/dispatch.c000066400000000000000000000116661366176261100177710ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: dispatch.c,v 1.2 2000-08-19 11:05:00 xleroy Exp $ */ /* Support for dispatch interfaces */ #include #include #include "camlidlruntime.h" #include "comstuff.h" /* Handle for module (for the DLL) */ HMODULE camlidl_module_handle = NULL; /* Retrieves the number of type information interfaces that the object provides (either 0 or 1). */ HRESULT STDMETHODCALLTYPE camlidl_GetTypeInfoCount(struct camlidl_intf * self, UINT * count_type_info) { *count_type_info = 1; return S_OK; } /* Retrieves the type information for the object */ HRESULT STDMETHODCALLTYPE camlidl_GetTypeInfo(struct camlidl_intf * self, UINT iTypeInfo, LCID localization, ITypeInfo ** res) { HRESULT hr; int i; ITypeInfo * tinfo; if (iTypeInfo != 0) { *res = NULL; return DISP_E_BADINDEX; } tinfo = (ITypeInfo *) self->typeinfo; /* Increase refcount of type info object */ tinfo->lpVtbl->AddRef(tinfo); /* Return tinfo */ *res = tinfo; return S_OK; } /* Find the dispatch IDs of the given method names */ HRESULT STDMETHODCALLTYPE camlidl_GetIDsOfNames(struct camlidl_intf * self, REFIID iid, OLECHAR** arrayNames, UINT countNames, LCID localization, DISPID * arrayDispIDs) { ITypeInfo * tinfo; if (! IsEqualIID(iid, &IID_NULL)) return DISP_E_UNKNOWNINTERFACE; tinfo = (ITypeInfo *) self->typeinfo; return tinfo->lpVtbl->GetIDsOfNames(tinfo, arrayNames, countNames, arrayDispIDs); } /* Invoke a method by dynamic dispatch */ HRESULT STDMETHODCALLTYPE camlidl_Invoke(struct camlidl_intf * self, DISPID dispidMember, REFIID iid, LCID localization, WORD wFlags, DISPPARAMS * dispParams, VARIANT * varResult, EXCEPINFO * excepInfo, UINT * argErr) { ITypeInfo * tinfo; if (! IsEqualIID(iid, &IID_NULL)) return DISP_E_UNKNOWNINTERFACE; tinfo = (ITypeInfo *) self->typeinfo; SetErrorInfo(0, NULL); return tinfo->lpVtbl->Invoke(tinfo, (IDispatch *) self, dispidMember, wFlags, dispParams, varResult, excepInfo, argErr); } /* Load the type info library for the object and store it in the typeinfo field of the object */ static int camlidl_num_type_libraries = 0; static void camlidl_read_num_type_libraries(void); IUnknown * camlidl_find_typeinfo(IID * iid) { ITypeLib * tlib; ITypeInfo * tinfo; char module_path[_MAX_PATH]; char resname[_MAX_PATH + 4]; wchar_t wresname[_MAX_PATH + 4]; int i; HRESULT hr; /* Determine number of type libraries available (if not already done) */ if (camlidl_num_type_libraries == 0) camlidl_read_num_type_libraries(); /* Get the full name of the executable */ GetModuleFileName(camlidl_module_handle, module_path, _MAX_PATH); /* Load the type libraries and query them */ for (i = 1; i <= camlidl_num_type_libraries; i++) { /* Build the wide string \ */ sprintf(resname, "%s\\%d", module_path, i); mbstowcs(wresname, resname, _MAX_PATH + 4); /* Load the type library */ hr = LoadTypeLib(wresname, &tlib); if (FAILED(hr)) camlidl_error(hr, "Com.create_dispatch", "Cannot load type library"); /* Query the type library for the type info for the object */ hr = tlib->lpVtbl->GetTypeInfoOfGuid(tlib, iid, &tinfo); /* Release the library */ tlib->lpVtbl->Release(tlib); if (SUCCEEDED(hr)) return (IUnknown *) tinfo; } /* Not found: raise an exception */ camlidl_error(TYPE_E_ELEMENTNOTFOUND, "Com.make_", "Cannot find type library for interface"); return NULL; /* not reached */ } static void camlidl_read_num_type_libraries(void) { HRSRC hFound; HGLOBAL hRes; void * lpBuff; hFound = FindResource(camlidl_module_handle, (char *)1, "num_typelibs"); if (hFound == NULL) camlidl_error(0, "Com.make_", "Cannot find resource num_typelibs"); hRes = LoadResource(camlidl_module_handle, hFound); if (hRes == NULL) camlidl_error(0, "Com.make_", "Cannot load resource num_typelibs"); lpBuff = LockResource(hRes); camlidl_num_type_libraries = *((WORD *) lpBuff); UnlockResource(hRes); FreeResource(hRes); } camlidl-camlidl109/runtime/idlalloc.c000066400000000000000000000073511366176261100177510ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: idlalloc.c,v 1.7 2000-08-19 11:05:00 xleroy Exp $ */ /* Allocation functions and various helper functions for stub code generated by camlidl */ #include #include #include #include #include #include #include "camlidlruntime.h" /* Helper functions for conversion */ value camlidl_find_enum(int n, int *flags, int nflags, char *errmsg) { int i; for (i = 0; i < nflags; i++) { if (n == flags[i]) return Val_int(i); } invalid_argument(errmsg); return Val_unit; /* not reached, keeps CL happy */ } value camlidl_alloc_flag_list(int n, int *flags, int nflags) { value l = Val_int(0); int i; Begin_root(l) for (i = nflags - 1; i >= 0; i--) if (n & flags[i]) { value v = alloc_small(2, 0); Field(v, 0) = Val_int(i); Field(v, 1) = l; l = v; n &= ~ flags[i]; } End_roots(); return l; } mlsize_t camlidl_ptrarray_size(void ** array) { mlsize_t i; for (i = 0; array[i] != NULL; i++) /*nothing*/; return i; } /* Malloc-like allocation with en masse deallocation */ void camlidl_register_allocation(camlidl_free_function free_fn, void * block, camlidl_ctx ctx) { if (ctx->flags & CAMLIDL_TRANSIENT) { struct camlidl_block_list * l = stat_alloc(sizeof(struct camlidl_block_list)); l->free_fn = free_fn; l->block = block; l->next = ctx->head; ctx->head = l; } } #ifdef _WIN32 static void camlidl_task_mem_free(void * ptr) { CoTaskMemFree(ptr); } #endif void * camlidl_malloc(size_t sz, camlidl_ctx ctx) { #ifdef _WIN32 void * res = CoTaskMemAlloc(sz); if (res == NULL) raise_out_of_memory(); camlidl_register_allocation(camlidl_task_mem_free, res, ctx); #else void * res = stat_alloc(sz); camlidl_register_allocation(stat_free, res, ctx); #endif return res; } void camlidl_free(camlidl_ctx ctx) { struct camlidl_block_list * arena, * tmp; for (arena = ctx->head; arena != NULL; /*nothing*/) { arena->free_fn(arena->block); tmp = arena; arena = arena->next; stat_free(tmp); } } char * camlidl_malloc_string(value mlstring, camlidl_ctx ctx) { mlsize_t len = string_length(mlstring); char * res = camlidl_malloc(len + 1, ctx); memcpy(res, String_val(mlstring), len + 1); return res; } /* This function is for compatibility with OCaml 2.00 and earlier */ #if defined(CAMLVERSION) && CAMLVERSION < 201 value camlidl_alloc (mlsize_t wosize, tag_t tag) { value result; mlsize_t i; Assert (wosize > 0); if (wosize <= Max_young_wosize){ result = alloc (wosize, tag); if (tag < No_scan_tag){ for (i = 0; i < wosize; i++) Field (result, i) = 0; } }else{ result = alloc_shr (wosize, tag); if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); result = check_urgent_gc (result); } return result; } #endif camlidl-camlidl109/runtime/oletypes.c000066400000000000000000000034141366176261100200260ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: oletypes.c,v 1.2 2000-08-19 11:05:00 xleroy Exp $ */ /* Support for OLE Automation data types */ #include #include #include #include #include #include #include #include "camlidlruntime.h" #include "comstuff.h" #include static void camlidl_free_bstr(void * data) { SysFreeString((BSTR) data); } /* Convert a Caml string to a BSTR */ void camlidl_ml2c_Com_BSTR(value s, BSTR * res, camlidl_ctx ctx) { int len = mbstowcs(NULL, String_val(s), 0); BSTR bs = SysAllocStringLen(NULL, len); if (bs == NULL) raise_out_of_memory(); camlidl_register_allocation(camlidl_free_bstr, bs, ctx); mbstowcs(bs, String_val(s), len); *res = bs; } /* Convert a BSTR to a Caml string */ value camlidl_c2ml_Com_BSTR(BSTR * bs, camlidl_ctx ctx) { int len = wcstombs(NULL, *bs, 0); value res = alloc_string(len); wcstombs(String_val(res), *bs, len); return res; } camlidl-camlidl109/runtime/registry.cpp000066400000000000000000000141131366176261100203700ustar00rootroot00000000000000// // Registry.cpp // // Note: code taken from "Inside COM", Dale Rogerson, Microsoft Press #include #include #include "Registry.h" //////////////////////////////////////////////////////// // // Internal helper functions prototypes // // Set the given key and its value. BOOL setKeyAndValue(const char* pszPath, const char* szSubkey, const char* szValue) ; // Convert a CLSID into a char string. void CLSIDtochar(const CLSID& clsid, char* szCLSID, int length) ; // Delete szKeyChild and all of its descendents. LONG recursiveDeleteKey(HKEY hKeyParent, const char* szKeyChild) ; //////////////////////////////////////////////////////// // // Constants // // Size of a CLSID as a string const int CLSID_STRING_SIZE = 39 ; ///////////////////////////////////////////////////////// // // Public function implementation // // // Register the component in the registry. // HRESULT RegisterServer(HMODULE hModule, // DLL module handle const CLSID& clsid, // Class ID const char* szFriendlyName, // Friendly Name const char* szVerIndProgID, // Programmatic const char* szProgID) // IDs { // Get server location. char szModule[512] ; DWORD dwResult = ::GetModuleFileName(hModule, szModule, sizeof(szModule)/sizeof(char)) ; assert(dwResult != 0) ; // Convert the CLSID into a char. char szCLSID[CLSID_STRING_SIZE] ; CLSIDtochar(clsid, szCLSID, sizeof(szCLSID)) ; // Build the key CLSID\\{...} char szKey[64] ; strcpy(szKey, "CLSID\\") ; strcat(szKey, szCLSID) ; // Add the CLSID to the registry. setKeyAndValue(szKey, NULL, szFriendlyName) ; // Add the server filename subkey under the CLSID key. setKeyAndValue(szKey, "InprocServer32", szModule) ; // Add the ProgID subkey under the CLSID key. setKeyAndValue(szKey, "ProgID", szProgID) ; // Add the version-independent ProgID subkey under CLSID key. setKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID) ; // Add the version-independent ProgID subkey under HKEY_CLASSES_ROOT. setKeyAndValue(szVerIndProgID, NULL, szFriendlyName) ; setKeyAndValue(szVerIndProgID, "CLSID", szCLSID) ; setKeyAndValue(szVerIndProgID, "CurVer", szProgID) ; // Add the versioned ProgID subkey under HKEY_CLASSES_ROOT. setKeyAndValue(szProgID, NULL, szFriendlyName) ; setKeyAndValue(szProgID, "CLSID", szCLSID) ; return S_OK ; } // // Remove the component from the registry. // LONG UnregisterServer(const CLSID& clsid, // Class ID const char* szVerIndProgID, // Programmatic const char* szProgID) // IDs { // Convert the CLSID into a char. char szCLSID[CLSID_STRING_SIZE] ; CLSIDtochar(clsid, szCLSID, sizeof(szCLSID)) ; // Build the key CLSID\\{...} char szKey[64] ; strcpy(szKey, "CLSID\\") ; strcat(szKey, szCLSID) ; // Delete the CLSID Key - CLSID\{...} LONG lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szKey) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. // Delete the version-independent ProgID Key. lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szVerIndProgID) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. // Delete the ProgID key. lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szProgID) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. return S_OK ; } /////////////////////////////////////////////////////////// // // Internal helper functions // // Convert a CLSID to a char string. void CLSIDtochar(const CLSID& clsid, char* szCLSID, int length) { assert(length >= CLSID_STRING_SIZE) ; // Get CLSID LPOLESTR wszCLSID = NULL ; HRESULT hr = StringFromCLSID(clsid, &wszCLSID) ; assert(SUCCEEDED(hr)) ; // Covert from wide characters to non-wide. wcstombs(szCLSID, wszCLSID, length) ; // Free memory. CoTaskMemFree(wszCLSID) ; } // // Delete a key and all of its descendents. // LONG recursiveDeleteKey(HKEY hKeyParent, // Parent of key to delete const char* lpszKeyChild) // Key to delete { // Open the child. HKEY hKeyChild ; LONG lRes = RegOpenKeyEx(hKeyParent, lpszKeyChild, 0, KEY_ALL_ACCESS, &hKeyChild) ; if (lRes != ERROR_SUCCESS) { return lRes ; } // Enumerate all of the decendents of this child. FILETIME time ; char szBuffer[256] ; DWORD dwSize = 256 ; while (RegEnumKeyEx(hKeyChild, 0, szBuffer, &dwSize, NULL, NULL, NULL, &time) == S_OK) { // Delete the decendents of this child. lRes = recursiveDeleteKey(hKeyChild, szBuffer) ; if (lRes != ERROR_SUCCESS) { // Cleanup before exiting. RegCloseKey(hKeyChild) ; return lRes; } dwSize = 256 ; } // Close the child. RegCloseKey(hKeyChild) ; // Delete this child. return RegDeleteKey(hKeyParent, lpszKeyChild) ; } // // Create a key and set its value. // - This helper function was borrowed and modifed from // Kraig Brockschmidt's book Inside OLE. // BOOL setKeyAndValue(const char* szKey, const char* szSubkey, const char* szValue) { HKEY hKey; char szKeyBuf[1024] ; // Copy keyname into buffer. strcpy(szKeyBuf, szKey) ; // Add subkey name to buffer. if (szSubkey != NULL) { strcat(szKeyBuf, "\\") ; strcat(szKeyBuf, szSubkey ) ; } // Create and open key and subkey. long lResult = RegCreateKeyEx(HKEY_CLASSES_ROOT , szKeyBuf, 0, NULL, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, NULL, &hKey, NULL) ; if (lResult != ERROR_SUCCESS) { return FALSE ; } // Set the Value. if (szValue != NULL) { RegSetValueEx(hKey, NULL, 0, REG_SZ, (BYTE *)szValue, strlen(szValue)+1) ; } RegCloseKey(hKey) ; return TRUE ; } camlidl-camlidl109/runtime/registry.h000066400000000000000000000031671366176261100200440ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: registry.h,v 1.3 2000-08-19 11:05:00 xleroy Exp $ */ #ifndef __Registry_H__ #define __Registry_H__ // // Registry.h // - Helper functions registering and unregistering a component. // // This function will register a component in the Registry. // The component calls this function from its DllRegisterServer function. HRESULT RegisterServer(HMODULE hModule, const CLSID& clsid, const char* szFriendlyName, const char* szVerIndProgID, const char* szProgID) ; // This function will unregister a component. Components // call this function from their DllUnregisterServer function. HRESULT UnregisterServer(const CLSID& clsid, const char* szVerIndProgID, const char* szProgID) ; #endifcamlidl-camlidl109/runtime/superror.cpp000066400000000000000000000037441366176261100204110ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: superror.cpp,v 1.3 2000-08-19 11:05:00 xleroy Exp $ */ /* The ISupportErrorInfo interface for Caml components */ extern "C" { #include #include "camlidlruntime.h" } #include "comstuff.h" class camlidl_sei : public ISupportErrorInfo { private: struct camlidl_intf * intf; long refcount; public: virtual HRESULT __stdcall QueryInterface(const IID& iid, void ** object) { return camlidl_QueryInterface(intf, iid, object); } ULONG __stdcall AddRef() { return InterlockedIncrement(&refcount); } ULONG __stdcall Release() { ULONG newrefcount = InterlockedDecrement(&refcount); if (newrefcount == 0) { ((IUnknown *) intf)->Release(); delete this; } return newrefcount; } HRESULT __stdcall InterfaceSupportsErrorInfo(const IID& iid) { if (iid == IID_IUnknown || iid == IID_ISupportErrorInfo) return S_FALSE; else return S_OK; } // constructor camlidl_sei (struct camlidl_intf * intf_init) { intf = intf_init; ((IUnknown *) intf)->AddRef(); refcount = 1; } }; extern "C" ISupportErrorInfo * camlidl_support_error_info(struct camlidl_intf * i) { return new camlidl_sei(i); } camlidl-camlidl109/tests/000077500000000000000000000000001366176261100154735ustar00rootroot00000000000000camlidl-camlidl109/tests/.gitignore000066400000000000000000000000611366176261100174600ustar00rootroot00000000000000!comcomp.h !component.h *.h *_stubs.c *.ml *.mli camlidl-camlidl109/tests/Makefile000066400000000000000000000032631366176261100171370ustar00rootroot00000000000000include ../config/Makefile CAMLIDL=../compiler/camlidl CAMLC=ocamlc -I ../lib INCLUDES=-DCAML_NAME_SPACE -I.. -I$(OCAMLLIB) CCPP?=$(CC) CPPFLAGS=$(CFLAGS) TESTS=basics.idl arrays.idl structs.idl unions.idl typedefs.idl $(TESTS_$(OSTYPE)) multi_import.idl stdint.idl TESTS_unix=unix.idl COMLIBS=$(COMLIBS_$(OSTYPE)) COMLIBS_win32=advapi32.lib ole32.lib oleaut32.lib all: ../caml/camlidlruntime.h $(TESTS:.idl=.$(OBJEXT)) testcomp $(TESTS:.idl=.$(OBJEXT)) component.$(OBJEXT): $(CAMLIDL) ../runtime/camlidlruntime.h unix.$(OBJEXT): unix.idl $(CAMLIDL) -no-include unix.idl $(CAMLC) -c unix.mli $(CAMLC) -c unix.ml $(CC) $(CFLAGS) $(INCLUDES) -c unix_stubs.c mv unix_stubs.$(OBJEXT) unix.$(OBJEXT) testcomp: comcomp.$(OBJEXT) component.$(OBJEXT) component.cmo testcomponent.cmo \ ../runtime/libcamlidl.$(LIBEXT) $(CAMLC) -cc $(CCPP) -custom -o testcomp \ com.cmo comcomp.$(OBJEXT) component.$(OBJEXT) \ component.cmo testcomponent.cmo \ ../runtime/libcamlidl.$(LIBEXT) $(COMLIBS) clean:: rm -f testcomp component.cmo testcomponent.cmo: component.cmi component.cmo component.cmi: component.$(OBJEXT) ../caml/camlidlruntime.h: mkdir ../caml ln -s ../runtime/camlidlruntime.h ../caml .SUFFIXES: .SUFFIXES: .idl .$(OBJEXT) .cpp .ml .mli .cmo .cmi .idl.$(OBJEXT): $(CAMLIDL) -header $*.idl $(CAMLC) -c $*.mli $(CAMLC) -c $*.ml $(CC) $(CFLAGS) $(INCLUDES) -c $*_stubs.c mv $*_stubs.$(OBJEXT) $*.$(OBJEXT) .cpp.$(OBJEXT): $(CCPP) $(CPPFLAGS) $(INCLUDES) -c $*.cpp .ml.cmo: $(CAMLC) -c $*.ml .mli.cmi: $(CAMLC) -c $*.mli clean:: rm -f $(TESTS:.idl=.mli) $(TESTS:.idl=.ml) $(TESTS:.idl=.h) $(TESTS:.idl=_stubs.c) clean:: rm -f *.cm[io] *.$(OBJEXT) camlidl-camlidl109/tests/arrays.idl000066400000000000000000000021031366176261100174620ustar00rootroot00000000000000[pointer_default(ref)] interface Arrays { /* Strings */ [string] char * str1([in,string] unsigned char * s); /* Arrays */ void array1([in, out] int t[10]); void array2([in] int n, [in, out, size_is(n)] int t[]); void array3([in] int n, [in, out, size_is(n)] int t[10]); void array4([in] int n, [out] int * m, [in, out, size_is(n), length_is(*m)] int t[10]); void array5([in,out] int *n, [in, out, size_is(*n), length_is(*n)] int t[]); /* Optional strings and arrays */ [string,unique] char * optstr1([in,string,unique] unsigned char * s); void optarray1([in,null_terminated,unique] int options[]); /* Multidimensional arrays */ void multarray1([in] int i, [in] int j, [in, size_is(i,j)] int t[][]); void multarray2([in] int i, [in, size_is(,i)] int t[10][]); /* Big arrays */ void bigarray1([bigarray,in,out] double t[10][20]); void bigarray2([in] int dimx, [in] int dimy, [in,bigarray,size_is(dimx,dimy)] long t[][], [out,bigarray,size_is(dimy,dimx)] long tt[][]); [bigarray,unique,size_is(10)] long * bigarray3([bigarray,in,unique] long * b); } camlidl-camlidl109/tests/basics.idl000066400000000000000000000015701366176261100174340ustar00rootroot00000000000000/* Integers */ [pointer_default(ref)] interface Basics { int f1([in] int x); unsigned long f2([in] long x); void f3([out] int * p); void f4([in,out] int * p); int f5([in] int x, [out] int * p); /* Pointers */ [unique] int * f6([in, unique] int * x); [ptr] int * f7([in, ptr] int * x); void f8([in, out] int * p, [in, out] long * q); /* Many arguments */ int f9(int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8); /* Boxed ints */ [nativeint] int f10([int64] long x); [int64] long f11([int32] int x); [int32] unsigned int f12([nativeint] unsigned long x); /* Default ints */ [int_default(int32), long_default(int64)] interface Basics_Integers { int f13(int x); long f14(long x); } int f15(int x); /* Const madness */ void f16([string] const char * p); [string] const char * f17(); /* 64-bit integers */ hyper int f18(unsigned __int64 x, long long y); } camlidl-camlidl109/tests/comcomp.c000066400000000000000000000102371366176261100172770ustar00rootroot00000000000000/* A simple COM component, as per the book */ #include #include #include "comcomp.h" typedef struct { unsigned char data[16]; } IID; typedef int HRESULT; typedef unsigned long ULONG; #define IsEqualIID(a,b) (memcmp(a, b, sizeof(IID)) == 0) #define InterlockedIncrement(p) (++(*(p))) #define InterlockedDecrement(p) (--(*(p))) #define S_OK 0 #define E_NOINTERFACE (-1) IID IID_IUnknown = { { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x80 } }; IID IID_IX = { { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x81 } }; IID IID_IY = { { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x82 } }; struct CA { struct IXVtbl * vtbl_ix; struct IYVtbl * vtbl_ix; int refcount; int ident; }; #define CA_of_IX(i) ((struct CA *) (i)) #define CA_of_IY(i) ((struct CA *) (((void **) (i)) - 1)) #define IX_of_CA(i) ((struct IX *) (i)) #define IY_of_CA(i) ((struct IY *) (((void **) (i)) + 1)) ULONG CA_AddRef(struct CA * this) { ULONG res = InterlockedIncrement(&this->refcount); printf("%d: AddRef: new refcount is %d\n", this->ident, res); return res; } ULONG CA_Release(struct CA * this) { ULONG res = InterlockedDecrement(&this->refcount); printf("%d: Release: new refcount is %d\n", this->ident, res); if (res == 0) { printf("%d: destroying component.\n", this->ident); free(this); } return res; } HRESULT CA_QueryInterface(struct CA * this, IID * iid, void ** res) { if (IsEqualIID(iid, &IID_IUnknown)) { printf("%d: QueryInterface: return IUnknown pointer.\n", this->ident); *res = IX_of_CA(this); } else if (IsEqualIID(iid, &IID_IX)) { printf("%d: QueryInterface: return IX pointer.\n", ident); *res = IX_of_CA(this); } else if (IsEqualIID(iid, &IID_IY)) { printf("%d: QueryInterface: return IY pointer.\n", ident); *res = IY_of_CA(this); } else { printf("%d: QueryInterface: interface not supported.\n", ident); *res = NULL; return E_NOINTERFACE; } CA_AddRef(this); return S_OK; } HRESULT IX_QueryInterface(struct IX * this, IID * iid, void ** res) { return CA_QueryInterface(CA_of_IX(this), iid, res); } ULONG IX_AddRef(struct IX * this) { return CA_AddRef(CA_of_IX(this)); } ULONG IX_Release(struct IX * this) { return CA_Release(CA_of_IX(this)); } void IX_F(struct IX * this, int x) { printf("%d: F(%d) called.\n", this->ident, x); } HRESULT IY_QueryInterface(struct IY * this, IID * iid, void ** res) { return CA_QueryInterface(CA_of_IY(this), iid, res); } ULONG IY_AddRef(struct IY * this) { return CA_AddRef(CA_of_IY(this)); } ULONG IY_Release(struct IY * this) { return CA_Release(CA_of_IY(this)); } int IY_G(struct IY * this, int x) { int res = 3 * x + 1; printf("%d: G(%d) called, returning %d.\n", this->ident, x, res); return res; } struct IXVtbl IX_table = { IX_QueryInterface, IX_AddRef, IX_Release, IX_F }; struct IYVtbl IY_table = { IY_QueryInterface, IY_AddRef, IY_Release, IY_G }; struct CA * make_CA() { struct CA * c = malloc(sizeof(struct CA)); c->vtbl_ix = &IX_table; c->vtbl_iy = &IY_table; c->refcount = 0; c->ident = ++CA_ident; return c; } static void test_component(struct IUnknown * c) { struct IX * cix; struct IY * ciy; int res; // Test IX interface if (c->lpVtbl->QueryInterface(c, &IID_IX, (void **) &cix) == S_OK) { printf("test: got IX interface.\n"); printf("test: calling F(12) on it.\n"); cix->lpVtbl->F(cix, 12); printf("test: releasing the IX interface.\n"); res = cix->lpVtbl->Release(cix); printf("test: return of Release() is %d.\n", res); } // Test IY interface if (c->lpVtbl->QueryInterface(c, &IID_IY, (void **) &ciy) == S_OK) { printf("test: got IY interface.\n"); printf("test: calling G(3) on it.\n"); res = ciy->lpVtbl->G(ciy, 3); printf("test: return value is %d.\n", res); printf("test: releasing the IY interface.\n"); res = ciy->lpVtbl->Release(ciy); printf("test: return of Release() is %d.\n", res); } } void test_ix(struct IX * c) { test_component((struct IUnknown *) c); } void test_iy(struct IY * c) { test_component((struct IUnknown *) c); } extern "C" int main(int argc, char ** argv) { struct IUnknown * i = create_instance(); test_component(i); i->Release(); return 0; } #endif camlidl-camlidl109/tests/comcomp.cpp000066400000000000000000000115321366176261100176360ustar00rootroot00000000000000// A simple COM component, as per the book #include #include #include #ifdef _WIN32 #include extern "C" { IID IID_IX = { 0, 0, 0, { 0, 0, 0, 0, 0, 0, 0, 0x81 } }; IID IID_IY = { 0, 0, 0, { 0, 0, 0, 0, 0, 0, 0, 0x82 } }; } #else #define interface class typedef struct { unsigned char data[16]; } IID; typedef int HRESULT; typedef unsigned long ULONG; #define IsEqualIID(a,b) (memcmp(&a, &b, sizeof(IID)) == 0) #define InterlockedIncrement(p) (++(*(p))) #define InterlockedDecrement(p) (--(*(p))) #define S_OK 0 #define E_NOINTERFACE (-1) #define STDMETHODCALLTYPE extern "C" { IID IID_IUnknown = { { 0, 0, 0, 0, 0, 0, 0xC0, 0, 0, 0, 0, 0, 0, 0, 0x46 } }; IID IID_IX = { { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x81 } }; IID IID_IY = { { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x82 } }; } interface IUnknown { public: virtual HRESULT QueryInterface(const IID& iid, void ** res) = 0; virtual ULONG AddRef() = 0; virtual ULONG Release() = 0; }; #endif interface IX : public IUnknown { public: virtual void STDMETHODCALLTYPE F(int x) = 0; }; interface IY : public IUnknown { public: virtual int STDMETHODCALLTYPE G(int x) = 0; virtual int STDMETHODCALLTYPE H() = 0; virtual int STDMETHODCALLTYPE K(char ** str) = 0; }; static int CA_ident = 0; class CA : public IX, public IY { private: long refcount; int ident; public: virtual HRESULT STDMETHODCALLTYPE QueryInterface(const IID& iid, void ** res) { if (IsEqualIID(iid, IID_IUnknown)) { printf("%d: QueryInterface: return IUnknown pointer.\n", ident); *res = (interface IX *) this; } else if (IsEqualIID(iid, IID_IX)) { printf("%d: QueryInterface: return IX pointer.\n", ident); *res = (interface IX *) this; } else if (IsEqualIID(iid, IID_IY)) { printf("%d: QueryInterface: return IY pointer.\n", ident); *res = (interface IY *) this; } else { printf("%d: QueryInterface: interface not supported.\n", ident); *res = NULL; return E_NOINTERFACE; } ((IUnknown *)(*res))->AddRef(); return S_OK; } virtual ULONG STDMETHODCALLTYPE AddRef() { ULONG res = InterlockedIncrement(&refcount); printf("%d: AddRef: new refcount is %lu\n", ident, res); return res; } virtual ULONG STDMETHODCALLTYPE Release() { ULONG res = InterlockedDecrement(&refcount); printf("%d: Release: new refcount is %lu\n", ident, res); if (res == 0) { printf("%d: destroying component.\n", ident); delete this; } return res; } virtual void STDMETHODCALLTYPE F(int x) { printf("%d: F(%d) called.\n", ident, x); } virtual int STDMETHODCALLTYPE G(int x) { int res = 3 * x + 1; printf("%d: G(%d) called, returning %d.\n", ident, x, res); return res; } virtual int STDMETHODCALLTYPE H() { printf("%d: H() called, returning 0.\n", ident); return 0; } virtual int STDMETHODCALLTYPE K(char ** str) { printf("%d: K() called, returning 0 and `foobar'.\n", ident); *str = "foobar"; return 0; } // constructor: CA() { refcount = 0; ident = ++CA_ident; } // destructor: ~CA() { printf("%d: destroy self.\n", ident); } }; extern "C" interface IUnknown * create_instance() { interface IUnknown * res = (interface IX *) new CA(); res->AddRef(); return res; } extern "C" void test_component(interface IUnknown * c) { interface IX * cix; interface IY * ciy; int res; char * stringres; // Test IX interface if (c->QueryInterface(IID_IX, (void **) &cix) == S_OK) { printf("test: got IX interface.\n"); printf("test: calling F(12) on it.\n"); cix->F(12); printf("test: releasing the IX interface.\n"); res = cix->Release(); printf("test: return of Release() is %d.\n", res); } // Test IY interface if (c->QueryInterface(IID_IY, (void **) &ciy) == S_OK) { printf("test: got IY interface.\n"); printf("test: calling G(3) on it.\n"); res = ciy->G(3); printf("test: return value is %d.\n", res); printf("test: calling H() on it.\n"); res = ciy->H(); printf("test: return value is %d.\n", res); printf("test: calling K() on it.\n"); res = ciy->K(&stringres); printf("test: hresult is %d, return string is `%s'.\n", res, stringres); printf("test: releasing the IY interface.\n"); res = ciy->Release(); printf("test: return of Release() is %d.\n", res); } } extern "C" void test_ix(interface IX * c) { test_component(c); // printf("test: releasing the interface, return of Release() is %d.\n", // c->Release()); } extern "C" void test_iy(interface IY * c) { test_component(c); // printf("test: releasing the interface, return of Release() is %d.\n", // c->Release()); } #if 0 extern "C" int main(int argc, char ** argv) { interface IUnknown * i = create_instance(); test_component(i); i->Release(); return 0; } #endif camlidl-camlidl109/tests/comcomp.h000066400000000000000000000017311366176261100173030ustar00rootroot00000000000000extern IID IID_IUnknown, IID_IX, IID_IY; struct IUnknown; struct IUnknownVtbl { DECLARE_VTBL_PADDING HRESULT (*QueryInterface)(struct IUnknown * this, IID * iid, void ** res); ULONG (*AddRef)(struct IUnknown * this); ULONG (*Release)(struct IUnknown * this); }; struct IUnknown { struct IUnknownVtbl * lpVtbl; }; struct IX; struct IXVtbl { DECLARE_VTBL_PADDING HRESULT (*QueryInterface)(struct IX * this, IID * iid, void ** res); ULONG (*AddRef)(struct IX * this); ULONG (*Release)(struct IX * this); void (*F)(struct IX * this, int x); }; struct IX { struct IXVtbl * lpVtbl; }; struct IY; struct IYVtbl { DECLARE_VTBL_PADDING HRESULT (*QueryInterface)(struct IY * this, IID * iid, void ** res); ULONG (*AddRef)(struct IY * this); ULONG (*Release)(struct IY * this); int (*G)(struct IY * this, int x); }; struct IY { struct IYVtbl * lpVtbl; }; extern struct IUnknown * create_instance(void); extern void test_component(struct IUnknown * c); camlidl-camlidl109/tests/comp/000077500000000000000000000000001366176261100164315ustar00rootroot00000000000000camlidl-camlidl109/tests/comp/CLIENT.CPP000066400000000000000000000036411366176261100177570ustar00rootroot00000000000000// // Client.cpp - client implementation // #include #include #include "Iface.h" void trace(const char* msg) { cout << "Client: \t\t" << msg << endl ;} // test one component static void testcomp(const CLSID & clsid) { trace("Call CoCreateInstance to create") ; trace(" component and get interface IX.") ; IX* pIX = NULL ; HRESULT hr = ::CoCreateInstance(clsid, NULL, CLSCTX_INPROC_SERVER, IID_IX, (void**)&pIX) ; if (SUCCEEDED(hr)) { trace("Succeeded getting IX.") ; pIX->Fx() ; // Use interface IX. trace("Ask for interface IY.") ; IY* pIY = NULL ; hr = pIX->QueryInterface(IID_IY, (void**)&pIY) ; if (SUCCEEDED(hr)) { trace("Succeeded getting IY.") ; pIY->Fy(12) ; // Use interface IY. pIY->Release() ; trace("Release IY interface.") ; } else { trace("Could not get interface IY.") ; } trace("Ask for interface IZ.") ; IZ* pIZ = NULL ; hr = pIX->QueryInterface(IID_IZ, (void**)&pIZ) ; if (SUCCEEDED(hr)) { int res; trace("Succeeded in getting interface IZ.") ; pIZ->Fz(18, &res) ; cout << "Client: \t\tFz(18) returns " << res << endl; pIZ->Release() ; trace("Release IZ interface.") ; } else { trace("Could not get interface IZ.") ; } trace("Release IX interface.") ; pIX->Release() ; } else { cout << "Client: \t\tCould not create component. hr = " << hex << hr << endl ; } } // // main function // int main() { // Initialize COM Library CoInitialize(NULL) ; // Testing the two components trace("Testing Component 1..."); testcomp(CLSID_Component1); trace("Testing Component 2..."); testcomp(CLSID_Component2); // Uninitialize COM Library CoUninitialize() ; return 0 ; } camlidl-camlidl109/tests/comp/CMPNT.CPP000066400000000000000000000143161366176261100176630ustar00rootroot00000000000000// // Cmpnt.cpp // #include #include #include "Iface.h" // Interface declarations #include "Registry.h" // Registry helper functions // Trace function void trace(const char* msg) { cout << msg << endl ;} /////////////////////////////////////////////////////////// // // Global variables // static HMODULE g_hModule = NULL ; // DLL module handle static long g_cComponents = 0 ; // Count of active components static long g_cServerLocks = 0 ; // Count of locks // Friendly name of component const char g_szFriendlyName[] = "Inside COM, Chapter 7 Example" ; // Version-independent ProgID const char g_szVerIndProgID[] = "InsideCOM.Chap07" ; // ProgID const char g_szProgID[] = "InsideCOM.Chap07.1" ; /////////////////////////////////////////////////////////// // // Component // class CA : public IX, public IY, public IZ { public: // IUnknown virtual HRESULT __stdcall QueryInterface(const IID& iid, void** ppv) ; virtual ULONG __stdcall AddRef() ; virtual ULONG __stdcall Release() ; // Interface IX virtual HRESULT __stdcall Fx() { cout << "Fx" << endl ; return S_OK; } // Interface IY virtual HRESULT __stdcall Fy(int x) { cout << "Fy: " << x << endl ; return S_OK; } // Interface IZ virtual HRESULT __stdcall Fz(int x, int * y) { cout << "Fz: " << x << endl ; *y = 2 * x + 1; return S_OK; } // Constructor CA() ; // Destructor ~CA() ; private: // Reference count long m_cRef ; } ; // // Constructor // CA::CA() : m_cRef(1) { InterlockedIncrement(&g_cComponents) ; } // // Destructor // CA::~CA() { InterlockedDecrement(&g_cComponents) ; trace("Component:\t\tDestroy self.") ; } // // IUnknown implementation // HRESULT __stdcall CA::QueryInterface(const IID& iid, void** ppv) { if (iid == IID_IUnknown) { *ppv = static_cast(this) ; } else if (iid == IID_IX) { *ppv = static_cast(this) ; trace("Component:\t\tReturn pointer to IX.") ; } else if (iid == IID_IY) { *ppv = static_cast(this) ; trace("Component:\t\tReturn pointer to IY.") ; } else if (iid == IID_IZ) { *ppv = static_cast(this) ; trace("Component:\t\tReturn pointer to IZ.") ; } else { *ppv = NULL ; return E_NOINTERFACE ; } reinterpret_cast(*ppv)->AddRef() ; return S_OK ; } ULONG __stdcall CA::AddRef() { return InterlockedIncrement(&m_cRef) ; } ULONG __stdcall CA::Release() { if (InterlockedDecrement(&m_cRef) == 0) { delete this ; return 0 ; } return m_cRef ; } /////////////////////////////////////////////////////////// // // Class factory // class CFactory : public IClassFactory { public: // IUnknown virtual HRESULT __stdcall QueryInterface(const IID& iid, void** ppv) ; virtual ULONG __stdcall AddRef() ; virtual ULONG __stdcall Release() ; // Interface IClassFactory virtual HRESULT __stdcall CreateInstance(IUnknown* pUnknownOuter, const IID& iid, void** ppv) ; virtual HRESULT __stdcall LockServer(BOOL bLock) ; // Constructor CFactory() : m_cRef(1) {} // Destructor ~CFactory() { trace("Class factory:\t\tDestroy self.") ;} private: long m_cRef ; } ; // // Class factory IUnknown implementation // HRESULT __stdcall CFactory::QueryInterface(const IID& iid, void** ppv) { if ((iid == IID_IUnknown) || (iid == IID_IClassFactory)) { *ppv = static_cast(this) ; } else { *ppv = NULL ; return E_NOINTERFACE ; } reinterpret_cast(*ppv)->AddRef() ; return S_OK ; } ULONG __stdcall CFactory::AddRef() { return InterlockedIncrement(&m_cRef) ; } ULONG __stdcall CFactory::Release() { if (InterlockedDecrement(&m_cRef) == 0) { delete this ; return 0 ; } return m_cRef ; } // // IClassFactory implementation // HRESULT __stdcall CFactory::CreateInstance(IUnknown* pUnknownOuter, const IID& iid, void** ppv) { trace("Class factory:\t\tCreate component.") ; // Cannot aggregate. if (pUnknownOuter != NULL) { return CLASS_E_NOAGGREGATION ; } // Create component. CA* pA = new CA ; if (pA == NULL) { return E_OUTOFMEMORY ; } // Get the requested interface. HRESULT hr = pA->QueryInterface(iid, ppv) ; // Release the IUnknown pointer. // (If QueryInterface failed, component will delete itself.) pA->Release() ; return hr ; } // LockServer HRESULT __stdcall CFactory::LockServer(BOOL bLock) { if (bLock) { InterlockedIncrement(&g_cServerLocks) ; } else { InterlockedDecrement(&g_cServerLocks) ; } return S_OK ; } /////////////////////////////////////////////////////////// // // Exported functions // // // Can DLL unload now? // STDAPI DllCanUnloadNow() { if ((g_cComponents == 0) && (g_cServerLocks == 0)) { return S_OK ; } else { return S_FALSE ; } } // // Get class factory // STDAPI DllGetClassObject(const CLSID& clsid, const IID& iid, void** ppv) { trace("DllGetClassObject:\tCreate class factory.") ; // Can we create this component? if (clsid != CLSID_Component1) { return CLASS_E_CLASSNOTAVAILABLE ; } // Create class factory. CFactory* pFactory = new CFactory ; // Reference count set to 1 // in constructor if (pFactory == NULL) { return E_OUTOFMEMORY ; } // Get requested interface. HRESULT hr = pFactory->QueryInterface(iid, ppv) ; pFactory->Release() ; return hr ; } // // Server registration // STDAPI DllRegisterServer() { return RegisterServer(g_hModule, CLSID_Component1, g_szFriendlyName, g_szVerIndProgID, g_szProgID) ; } // // Server unregistration // STDAPI DllUnregisterServer() { return UnregisterServer(CLSID_Component1, g_szVerIndProgID, g_szProgID) ; } /////////////////////////////////////////////////////////// // // DLL module information // BOOL APIENTRY DllMain(HANDLE hModule, DWORD dwReason, void* lpReserved) { if (dwReason == DLL_PROCESS_ATTACH) { g_hModule = (HMODULE) hModule ; } return TRUE ; } camlidl-camlidl109/tests/comp/CMPNT.DEF000066400000000000000000000004571366176261100176400ustar00rootroot00000000000000LIBRARY Cmpnt.dll DESCRIPTION 'Chapter 7 Example COM Component (c)1996-1997 Dale E. Rogerson' EXPORTS DllGetClassObject @2 PRIVATE DllCanUnloadNow @3 PRIVATE DllRegisterServer @4 PRIVATE DllUnregisterServer @5 PRIVATE camlidl-camlidl109/tests/comp/GUIDS.CPP000066400000000000000000000017221366176261100176520ustar00rootroot00000000000000// // GUIDs.cpp // - Defines all IIDs and CLSIDs for the client and the component. // The declaration of these GUIDs is in Iface.h // #include // {32bb8320-b41b-11cf-a6bb-0080c7b2d682} extern "C" const IID IID_IX = {0x32bb8320, 0xb41b, 0x11cf, {0xa6, 0xbb, 0x0, 0x80, 0xc7, 0xb2, 0xd6, 0x82}} ; // {32bb8321-b41b-11cf-a6bb-0080c7b2d682} extern "C" const IID IID_IY = {0x32bb8321, 0xb41b, 0x11cf, {0xa6, 0xbb, 0x0, 0x80, 0xc7, 0xb2, 0xd6, 0x82}} ; // {32bb8322-b41b-11cf-a6bb-0080c7b2d682} extern "C" const IID IID_IZ = {0x32bb8322, 0xb41b, 0x11cf, {0xa6, 0xbb, 0x0, 0x80, 0xc7, 0xb2, 0xd6, 0x82}} ; // {0c092c21-882c-11cf-a6bb-0080c7b2d682} extern "C" const CLSID CLSID_Component1 = {0x0c092c21, 0x882c, 0x11cf, {0xa6, 0xbb, 0x0, 0x80, 0xc7, 0xb2, 0xd6, 0x82}} ; // {aab56090-c721-11d2-8e2b-0060974fbf19} extern "C" const CLSID CLSID_Component2 = {0xaab56090, 0xc721, 0x11d2, {0x8e, 0x2b, 0x00, 0x60, 0x97, 0x4f, 0xbf, 0x19}}; camlidl-camlidl109/tests/comp/IFACE.H000066400000000000000000000011161366176261100173500ustar00rootroot00000000000000// // Iface.h - // Declarations of interfaces, IIDs, and CLSID // shared by the client and the component. // interface IX : IUnknown { virtual HRESULT pascal Fx() = 0 ; }; interface IY : IUnknown { virtual HRESULT pascal Fy(int x) = 0 ; }; interface IZ : IUnknown { virtual HRESULT pascal Fz(int x, int * y) = 0 ; }; // // Declaration of GUIDs for interfaces and component. // These constants are defined in GUIDs.cpp. // extern "C" const IID IID_IX ; extern "C" const IID IID_IY ; extern "C" const IID IID_IZ ; extern "C" const CLSID CLSID_Component1, CLSID_Component2 ; camlidl-camlidl109/tests/comp/MAKEFILE000066400000000000000000000043551366176261100175400ustar00rootroot00000000000000# # Chapter 7 - Makefile # # # Flags - Always compiles debug. # CPP_FLAGS=/c /MTd /Zi /Od /D_DEBUG EXE_LINK_FLAGS=/DEBUG DLL_LINK_FLAGS=/DLL /DEBUG LIBS=UUID.lib Advapi32.lib Ole32.lib ################################################# # # Targets # all : client component camlclient camlcomponent client : Client.exe component : Cmpnt.dll ################################################# # # Shared source files # GUIDs.obj : GUIDs.cpp cl $(CPP_FLAGS) GUIDs.cpp Registry.obj : Registry.cpp Registry.h cl $(CPP_FLAGS) Registry.cpp ################################################# # # component source files # Cmpnt.obj : Cmpnt.cpp Iface.h Registry.h cl $(CPP_FLAGS) Cmpnt.cpp ################################################# # # Client source files # Client.obj : Client.cpp Iface.h cl $(CPP_FLAGS) Client.cpp ################################################# # # Link component and automatically register component. # Cmpnt.dll : Cmpnt.obj GUIDs.obj Registry.obj Cmpnt.def link $(DLL_LINK_FLAGS) Cmpnt.obj GUIDs.obj Registry.obj $(LIBS) /DEF:Cmpnt.def regsvr32 -s Cmpnt.dll ################################################# # # Link client. # Client.exe : Client.obj GUIDs.obj link $(EXE_LINK_FLAGS) Client.obj GUIDs.obj $(LIBS) ############# # # Caml side # camlclient : camlclient.exe camlclient.exe: component_stubs.obj GUIDs.obj component.cmo camlclient.cmo ocamlc -ccopt /Zi -o camlclient.exe -custom \ com.cma component.cmo camlclient.cmo \ component_stubs.obj GUIDs.obj \ -cclib -lcamlidl oleaut32.lib ole32.lib component.ml component.mli component_stubs.c: component.idl ../../compiler/camlidl ../../compiler/camlidl -header component.idl component.cmo: component.ml component.cmi component.cmi: component.mli camlclient.cmo: component.cmi camlcomponent: camlcomp.dll camlcomp.dll: component_stubs.obj GUIDs.obj \ component.cmo camlcomp.cmo camlidldll -o camlcomp.dll \ component_stubs.obj GUIDs.obj \ component.cmo camlcomp.cmo regsvr32 -s camlcomp.dll camlcomp.cmo: component.cmi .SUFFIXES: .ml .mli .cmo .cmx .cmi .c .obj .ml.cmo: ocamlc -c $< .ml.cmx: ocamlopt -c $< .mli.cmi: ocamlc -c $< .c.obj: ocamlc -ccopt /Zi -c $< camlcomponent: camlidl-camlidl109/tests/comp/README000066400000000000000000000002731366176261100173130ustar00rootroot00000000000000The source files in uppercase come from an example in "Inside Com", Dale Rogerson, Microsoft Press. Although no license is provided for those files, I hope it's OK to redistribute them. camlidl-camlidl109/tests/comp/REGISTRY.CPP000066400000000000000000000140051366176261100202450ustar00rootroot00000000000000// // Registry.cpp // #include #include #include "Registry.h" //////////////////////////////////////////////////////// // // Internal helper functions prototypes // // Set the given key and its value. BOOL setKeyAndValue(const char* pszPath, const char* szSubkey, const char* szValue) ; // Convert a CLSID into a char string. void CLSIDtochar(const CLSID& clsid, char* szCLSID, int length) ; // Delete szKeyChild and all of its descendents. LONG recursiveDeleteKey(HKEY hKeyParent, const char* szKeyChild) ; //////////////////////////////////////////////////////// // // Constants // // Size of a CLSID as a string const int CLSID_STRING_SIZE = 39 ; ///////////////////////////////////////////////////////// // // Public function implementation // // // Register the component in the registry. // HRESULT RegisterServer(HMODULE hModule, // DLL module handle const CLSID& clsid, // Class ID const char* szFriendlyName, // Friendly Name const char* szVerIndProgID, // Programmatic const char* szProgID) // IDs { // Get server location. char szModule[512] ; DWORD dwResult = ::GetModuleFileName(hModule, szModule, sizeof(szModule)/sizeof(char)) ; assert(dwResult != 0) ; // Convert the CLSID into a char. char szCLSID[CLSID_STRING_SIZE] ; CLSIDtochar(clsid, szCLSID, sizeof(szCLSID)) ; // Build the key CLSID\\{...} char szKey[64] ; strcpy(szKey, "CLSID\\") ; strcat(szKey, szCLSID) ; // Add the CLSID to the registry. setKeyAndValue(szKey, NULL, szFriendlyName) ; // Add the server filename subkey under the CLSID key. setKeyAndValue(szKey, "InprocServer32", szModule) ; // Add the ProgID subkey under the CLSID key. setKeyAndValue(szKey, "ProgID", szProgID) ; // Add the version-independent ProgID subkey under CLSID key. setKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID) ; // Add the version-independent ProgID subkey under HKEY_CLASSES_ROOT. setKeyAndValue(szVerIndProgID, NULL, szFriendlyName) ; setKeyAndValue(szVerIndProgID, "CLSID", szCLSID) ; setKeyAndValue(szVerIndProgID, "CurVer", szProgID) ; // Add the versioned ProgID subkey under HKEY_CLASSES_ROOT. setKeyAndValue(szProgID, NULL, szFriendlyName) ; setKeyAndValue(szProgID, "CLSID", szCLSID) ; return S_OK ; } // // Remove the component from the registry. // LONG UnregisterServer(const CLSID& clsid, // Class ID const char* szVerIndProgID, // Programmatic const char* szProgID) // IDs { // Convert the CLSID into a char. char szCLSID[CLSID_STRING_SIZE] ; CLSIDtochar(clsid, szCLSID, sizeof(szCLSID)) ; // Build the key CLSID\\{...} char szKey[64] ; strcpy(szKey, "CLSID\\") ; strcat(szKey, szCLSID) ; // Delete the CLSID Key - CLSID\{...} LONG lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szKey) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. // Delete the version-independent ProgID Key. lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szVerIndProgID) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. // Delete the ProgID key. lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szProgID) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. return S_OK ; } /////////////////////////////////////////////////////////// // // Internal helper functions // // Convert a CLSID to a char string. void CLSIDtochar(const CLSID& clsid, char* szCLSID, int length) { assert(length >= CLSID_STRING_SIZE) ; // Get CLSID LPOLESTR wszCLSID = NULL ; HRESULT hr = StringFromCLSID(clsid, &wszCLSID) ; assert(SUCCEEDED(hr)) ; // Covert from wide characters to non-wide. wcstombs(szCLSID, wszCLSID, length) ; // Free memory. CoTaskMemFree(wszCLSID) ; } // // Delete a key and all of its descendents. // LONG recursiveDeleteKey(HKEY hKeyParent, // Parent of key to delete const char* lpszKeyChild) // Key to delete { // Open the child. HKEY hKeyChild ; LONG lRes = RegOpenKeyEx(hKeyParent, lpszKeyChild, 0, KEY_ALL_ACCESS, &hKeyChild) ; if (lRes != ERROR_SUCCESS) { return lRes ; } // Enumerate all of the decendents of this child. FILETIME time ; char szBuffer[256] ; DWORD dwSize = 256 ; while (RegEnumKeyEx(hKeyChild, 0, szBuffer, &dwSize, NULL, NULL, NULL, &time) == S_OK) { // Delete the decendents of this child. lRes = recursiveDeleteKey(hKeyChild, szBuffer) ; if (lRes != ERROR_SUCCESS) { // Cleanup before exiting. RegCloseKey(hKeyChild) ; return lRes; } dwSize = 256 ; } // Close the child. RegCloseKey(hKeyChild) ; // Delete this child. return RegDeleteKey(hKeyParent, lpszKeyChild) ; } // // Create a key and set its value. // - This helper function was borrowed and modifed from // Kraig Brockschmidt's book Inside OLE. // BOOL setKeyAndValue(const char* szKey, const char* szSubkey, const char* szValue) { HKEY hKey; char szKeyBuf[1024] ; // Copy keyname into buffer. strcpy(szKeyBuf, szKey) ; // Add subkey name to buffer. if (szSubkey != NULL) { strcat(szKeyBuf, "\\") ; strcat(szKeyBuf, szSubkey ) ; } // Create and open key and subkey. long lResult = RegCreateKeyEx(HKEY_CLASSES_ROOT , szKeyBuf, 0, NULL, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, NULL, &hKey, NULL) ; if (lResult != ERROR_SUCCESS) { return FALSE ; } // Set the Value. if (szValue != NULL) { RegSetValueEx(hKey, NULL, 0, REG_SZ, (BYTE *)szValue, strlen(szValue)+1) ; } RegCloseKey(hKey) ; return TRUE ; } camlidl-camlidl109/tests/comp/REGISTRY.H000066400000000000000000000014121366176261100200100ustar00rootroot00000000000000#ifndef __Registry_H__ #define __Registry_H__ // // Registry.h // - Helper functions registering and unregistering a component. // // This function will register a component in the Registry. // The component calls this function from its DllRegisterServer function. HRESULT RegisterServer(HMODULE hModule, const CLSID& clsid, const char* szFriendlyName, const char* szVerIndProgID, const char* szProgID) ; // This function will unregister a component. Components // call this function from their DllUnregisterServer function. HRESULT UnregisterServer(const CLSID& clsid, const char* szVerIndProgID, const char* szProgID) ; #endifcamlidl-camlidl109/tests/comp/camlclient.ml000066400000000000000000000025641366176261100211050ustar00rootroot00000000000000(* A simple client in Caml *) open Printf let testcomp clsid = print_string "Call Com.create_instance to create component and get interface IX"; print_newline(); begin try let ix = Com.create_instance clsid Component.iid_iX in print_string "Calling Fx..."; print_newline(); (Component.use_iX ix)#fx; begin try print_string "Ask for interface IY"; print_newline(); let iy = Com.query_interface ix Component.iid_iY in print_string "Got it, calling Fy(5)..."; print_newline(); (Component.use_iY iy)#fy 5 with Com.Error(_, src, msg) -> printf "COM error (%s): %s\n" src msg; flush stdout end; begin try print_string "Ask for interface IZ"; print_newline(); let iz = Com.query_interface ix Component.iid_iZ in print_string "Got it, calling Fz(12)..."; print_newline(); let res = (Component.use_iZ iz)#fz 12 in printf "Return value is %d\n" res; flush stdout with Com.Error(_, src, msg) -> printf "COM error (%s): %s\n" src msg; flush stdout end with Com.Error(_, src, msg) -> printf "COM error (%s): %s\n" src msg; flush stdout end let clsid_component1 = Com.clsid "0c092c21-882c-11cf-a6bb-0080c7b2d682" let clsid_component2 = Com.clsid "aab56090-c721-11d2-8e2b-0060974fbf19" let _ = Com.initialize(); testcomp clsid_component1; testcomp clsid_component2; Com.uninitialize() camlidl-camlidl109/tests/comp/camlcomp.def000066400000000000000000000004161366176261100207050ustar00rootroot00000000000000LIBRARY Camlcomp.dll DESCRIPTION 'CAMLIDL, test component 1' EXPORTS DllGetClassObject @2 PRIVATE DllCanUnloadNow @3 PRIVATE DllRegisterServer @4 PRIVATE DllUnregisterServer @5 PRIVATE camlidl-camlidl109/tests/comp/camlcomp.ml000066400000000000000000000015131366176261100205560ustar00rootroot00000000000000(* A simple component in Caml *) class mycomponent = object method fx = print_string "Camlcomp: fx"; print_newline() method fy n = print_string "Camlcomp: fy "; print_int n; print_newline() method fz n = print_string "Camlcomp: fz "; print_int n; print_newline(); n / 2 end let factory () = print_string "Camlcomp: factory is called"; print_newline(); let obj = new mycomponent in let ix = Component.make_iX obj and iy = Component.make_iY obj and iz = Component.make_iZ obj in Com.combine (Com.combine ix iy) iz let _ = Com.register_factory { Com.create = factory; Com.clsid = Com.clsid "aab56090-c721-11d2-8e2b-0060974fbf19"; Com.friendly_name = "CAMLIDL, test component 1"; Com.ver_ind_prog_id = "CAMLIDL.Testcomp1"; Com.prog_id = "CAMLIDL.Testcomp1.1" } camlidl-camlidl109/tests/comp/component.idl000066400000000000000000000004761366176261100211340ustar00rootroot00000000000000[object, uuid(32bb8320-b41b-11cf-a6bb-0080c7b2d682)] interface IX : IUnknown { HRESULT Fx(); } [object, uuid(32bb8321-b41b-11cf-a6bb-0080c7b2d682)] interface IY : IUnknown { HRESULT Fy(int x); } [object, uuid(32bb8322-b41b-11cf-a6bb-0080c7b2d682)] interface IZ : IUnknown { HRESULT Fz(int x, [out] int * y); } camlidl-camlidl109/tests/component.idl000066400000000000000000000006751366176261100201770ustar00rootroot00000000000000[object, uuid(00000000-0000-0000-0000-000000000081)] interface IX : IUnknown { void F(int x); } [object, uuid(00000000-0000-0000-0000-000000000082), pointer_default(ref)] interface IY : IUnknown { HRESULT_int G(int x); HRESULT_bool H(); HRESULT K([out,string*] char ** str); } [pointer_default(ref)] interface Test { IUnknown * create_instance(void); void test_component(IUnknown * c); void test_ix(IX * c); void test_iy(IY * c); } camlidl-camlidl109/tests/dispatch/000077500000000000000000000000001366176261100172725ustar00rootroot00000000000000camlidl-camlidl109/tests/dispatch/CFACTORY.CPP000066400000000000000000000155701366176261100210600ustar00rootroot00000000000000/////////////////////////////////////////////////////////// // // CFactory // - Base class for reusing a single class factory for // all components in a DLL // #include #include "Registry.h" #include "CFactory.h" /////////////////////////////////////////////////////////// // // Static variables // LONG CFactory::s_cServerLocks = 0 ; // Count of locks HMODULE CFactory::s_hModule = NULL ; // DLL module handle #ifdef _OUTPROC_SERVER_ DWORD CFactory::s_dwThreadID = 0 ; #endif /////////////////////////////////////////////////////////// // // CFactory implementation // CFactory::CFactory(const CFactoryData* pFactoryData) : m_cRef(1) { m_pFactoryData = pFactoryData ; } // // IUnknown implementation // HRESULT __stdcall CFactory::QueryInterface(REFIID iid, void** ppv) { IUnknown* pI ; if ((iid == IID_IUnknown) || (iid == IID_IClassFactory)) { pI = this ; } else { *ppv = NULL; return E_NOINTERFACE; } pI->AddRef() ; *ppv = pI ; return S_OK; } ULONG __stdcall CFactory::AddRef() { return ::InterlockedIncrement(&m_cRef) ; } ULONG __stdcall CFactory::Release() { if (::InterlockedDecrement(&m_cRef) == 0) { delete this; return 0 ; } return m_cRef; } // // IClassFactory implementation // HRESULT __stdcall CFactory::CreateInstance(IUnknown* pUnknownOuter, const IID& iid, void** ppv) { // Aggregate only if the requested IID is IID_IUnknown. if ((pUnknownOuter != NULL) && (iid != IID_IUnknown)) { return CLASS_E_NOAGGREGATION ; } // Create the component. CUnknown* pNewComponent ; HRESULT hr = m_pFactoryData->CreateInstance(pUnknownOuter, &pNewComponent) ; if (FAILED(hr)) { return hr ; } // Initialize the component. hr = pNewComponent->Init(); if (FAILED(hr)) { // Initialization failed. Release the component. pNewComponent->NondelegatingRelease() ; return hr ; } // Get the requested interface. hr = pNewComponent->NondelegatingQueryInterface(iid, ppv) ; // Release the reference held by the class factory. pNewComponent->NondelegatingRelease() ; return hr ; } // LockServer HRESULT __stdcall CFactory::LockServer(BOOL bLock) { if (bLock) { ::InterlockedIncrement(&s_cServerLocks) ; } else { ::InterlockedDecrement(&s_cServerLocks) ; } // If this is an out-of-proc server, check to see // whether we should shut down. CloseExe() ; //@local return S_OK ; } /////////////////////////////////////////////////////////// // // GetClassObject // - Create a class factory based on a CLSID. // HRESULT CFactory::GetClassObject(const CLSID& clsid, const IID& iid, void** ppv) { if ((iid != IID_IUnknown) && (iid != IID_IClassFactory)) { return E_NOINTERFACE ; } // Traverse the array of data looking for this class ID. for (int i = 0; i < g_cFactoryDataEntries; i++) { const CFactoryData* pData = &g_FactoryDataArray[i] ; if (pData->IsClassID(clsid)) { // Found the ClassID in the array of components we can // create. So create a class factory for this component. // Pass the CFactoryData structure to the class factory // so that it knows what kind of components to create. *ppv = (IUnknown*) new CFactory(pData) ; if (*ppv == NULL) { return E_OUTOFMEMORY ; } return NOERROR ; } } return CLASS_E_CLASSNOTAVAILABLE ; } // // Determine if the component can be unloaded. // HRESULT CFactory::CanUnloadNow() { if (CUnknown::ActiveComponents() || IsLocked()) { return S_FALSE ; } else { return S_OK ; } } // // Register all components. // HRESULT CFactory::RegisterAll() { for(int i = 0 ; i < g_cFactoryDataEntries ; i++) { RegisterServer(s_hModule, *(g_FactoryDataArray[i].m_pCLSID), g_FactoryDataArray[i].m_RegistryName, g_FactoryDataArray[i].m_szVerIndProgID, g_FactoryDataArray[i].m_szProgID, *(g_FactoryDataArray[i].m_pLIBID)) ; } return S_OK ; } HRESULT CFactory::UnregisterAll() { for(int i = 0 ; i < g_cFactoryDataEntries ; i++) { UnregisterServer(*(g_FactoryDataArray[i].m_pCLSID), g_FactoryDataArray[i].m_szVerIndProgID, g_FactoryDataArray[i].m_szProgID) ; } return S_OK ; } #ifndef _OUTPROC_SERVER_ ////////////////////////////////////////////////////////// // // Exported functions // STDAPI DllCanUnloadNow() { return CFactory::CanUnloadNow() ; } // // Get class factory // STDAPI DllGetClassObject(const CLSID& clsid, const IID& iid, void** ppv) { return CFactory::GetClassObject(clsid, iid, ppv) ; } // // Server registration // STDAPI DllRegisterServer() { return CFactory::RegisterAll() ; } STDAPI DllUnregisterServer() { return CFactory::UnregisterAll() ; } /////////////////////////////////////////////////////////// // // DLL module information // BOOL APIENTRY DllMain(HANDLE hModule, DWORD dwReason, void* lpReserved ) { if (dwReason == DLL_PROCESS_ATTACH) { CFactory::s_hModule = (HMODULE) hModule ; } return TRUE ; } #else ////////////////////////////////////////////////////////// // // Out of process Server support // // // Start factories // BOOL CFactory::StartFactories() { CFactoryData* pStart = &g_FactoryDataArray[0] ; const CFactoryData* pEnd = &g_FactoryDataArray[g_cFactoryDataEntries - 1] ; for(CFactoryData* pData = pStart ; pData <= pEnd ; pData++) { // Initialize the class factory pointer and cookie. pData->m_pIClassFactory = NULL ; pData->m_dwRegister = NULL ; // Create the class factory for this component. IClassFactory* pIFactory = new CFactory(pData) ; // Register the class factory. DWORD dwRegister ; HRESULT hr = ::CoRegisterClassObject( *pData->m_pCLSID, static_cast(pIFactory), CLSCTX_LOCAL_SERVER, REGCLS_MULTIPLEUSE, // REGCLS_MULTI_SEPARATE, //@Multi &dwRegister) ; if (FAILED(hr)) { pIFactory->Release() ; return FALSE ; } // Set the data. pData->m_pIClassFactory = pIFactory ; pData->m_dwRegister = dwRegister ; } return TRUE ; } // // Stop factories // void CFactory::StopFactories() { CFactoryData* pStart = &g_FactoryDataArray[0] ; const CFactoryData* pEnd = &g_FactoryDataArray[g_cFactoryDataEntries - 1] ; for (CFactoryData* pData = pStart ; pData <= pEnd ; pData++) { // Get the magic cookie and stop the factory from running. DWORD dwRegister = pData->m_dwRegister ; if (dwRegister != 0) { ::CoRevokeClassObject(dwRegister) ; } // Release the class factory. IClassFactory* pIFactory = pData->m_pIClassFactory ; if (pIFactory != NULL) { pIFactory->Release() ; } } } #endif //_OUTPROC_SERVER_ camlidl-camlidl109/tests/dispatch/CFACTORY.H000066400000000000000000000062711366176261100206230ustar00rootroot00000000000000#ifndef __CFactory_h__ #define __CFactory_h__ #include "CUnknown.h" /////////////////////////////////////////////////////////// // Forward reference class CFactoryData ; // Global data used by CFactory extern CFactoryData g_FactoryDataArray[] ; extern int g_cFactoryDataEntries ; ////////////////////////////////////////////////////////// // // Component creation function // class CUnknown ; typedef HRESULT (*FPCREATEINSTANCE)(IUnknown*, CUnknown**) ; /////////////////////////////////////////////////////////// // // CFactoryData // - Information CFactory needs to create a component // supported by the DLL // class CFactoryData { public: // The class ID for the component const CLSID* m_pCLSID ; // Pointer to the function that creates it FPCREATEINSTANCE CreateInstance ; // Name of the component to register in the registry const char* m_RegistryName ; // ProgID const char* m_szProgID ; // Version-independent ProgID const char* m_szVerIndProgID ; // Helper function for finding the class ID BOOL IsClassID(const CLSID& clsid) const { return (*m_pCLSID == clsid) ;} // Type Library ID const GUID* m_pLIBID ; // // Out of process server support // // Pointer to running class factory for this component IClassFactory* m_pIClassFactory ; // Magic cookie to identify running object DWORD m_dwRegister ; } ; /////////////////////////////////////////////////////////// // // Class Factory // class CFactory : public IClassFactory { public: // IUnknown virtual HRESULT __stdcall QueryInterface(const IID& iid, void** ppv) ; virtual ULONG __stdcall AddRef() ; virtual ULONG __stdcall Release() ; // IClassFactory virtual HRESULT __stdcall CreateInstance(IUnknown* pUnknownOuter, const IID& iid, void** ppv) ; virtual HRESULT __stdcall LockServer(BOOL bLock) ; // Constructor - Pass pointer to data of component to create. CFactory(const CFactoryData* pFactoryData) ; // Destructor ~CFactory() { } // // Static FactoryData support functions // // DllGetClassObject support static HRESULT GetClassObject(const CLSID& clsid, const IID& iid, void** ppv) ; // Helper function for DllCanUnloadNow static BOOL IsLocked() { return (s_cServerLocks > 0) ;} // Functions to [un]register all components static HRESULT RegisterAll() ; static HRESULT UnregisterAll() ; // Function to determine if component can be unloaded static HRESULT CanUnloadNow() ; #ifdef _OUTPROC_SERVER_ // // Out-of-process server support // static BOOL StartFactories() ; static void StopFactories() ; static DWORD s_dwThreadID ; // Shut down the application. static void CloseExe() { if (CanUnloadNow() == S_OK) { ::PostThreadMessage(s_dwThreadID, WM_QUIT, 0, 0) ; } } #else // CloseExe doesn't do anything if we are in process. static void CloseExe() { /*Empty*/ } #endif public: // Reference Count LONG m_cRef ; // Pointer to information about class this factory creates const CFactoryData* m_pFactoryData ; // Count of locks static LONG s_cServerLocks ; // Module handle static HMODULE s_hModule ; } ; #endif camlidl-camlidl109/tests/dispatch/CLIENT.CPP000066400000000000000000000031251366176261100206150ustar00rootroot00000000000000// // Client.cpp - Client implementation // This client connects to the IX dual interface // through the vtbl. // #include #include #include "Util.h" #include "Iface.h" static inline void trace(char* msg) { Util::Trace("Client", msg, S_OK) ;} static inline void trace(char* msg, HRESULT hr) { Util::Trace("Client", msg, hr) ;} void test(const CLSID & clsid) { DWORD clsctx ; clsctx = CLSCTX_INPROC_SERVER ; trace("Attempt to create in-proc component.") ; IX* pIX = NULL ; HRESULT hr = CoCreateInstance(clsid, NULL, clsctx, IID_IX, (void**)&pIX) ; if (SUCCEEDED(hr)) { trace("Successfully created component.") ; trace("Use interface IX.") ; wchar_t* wszIn = L"This is the test." ; BSTR bstrIn ; bstrIn = ::SysAllocString(wszIn) ; pIX->FxStringIn(bstrIn) ; ::SysFreeString(bstrIn) ; BSTR bstrOut ; //@dual pIX->FxStringOut(&bstrOut ) ; // Display returned string. ostrstream sout ; sout << "FxStringOut returned a string: " << bstrOut << ends; trace(sout.str()) ; ::SysFreeString(bstrOut ) ; trace("Release IX.") ; pIX->Release() ; } else { trace("Could not create component.", hr); } } const CLSID CLSID_Caml_Component = {0x6a3d0750, 0xdad9, 0x11d2, {0x8e, 0x2c, 0x00, 0x60, 0x97, 0x4f, 0xbf, 0x19} }; int main() { // Initialize COM Library CoInitialize(NULL) ; test(CLSID_Component); test(CLSID_Caml_Component); // Uninitialize COM Library CoUninitialize() ; return 0; } camlidl-camlidl109/tests/dispatch/CMPNT.CPP000066400000000000000000000154541366176261100205300ustar00rootroot00000000000000// // Cmpnt.cpp - Component // #include #include // sprintf #include //splitpath #include "Iface.h" #include "Util.h" #include "CUnknown.h" #include "CFactory.h" // Needed for module handle #include "Cmpnt.h" static inline void trace(char* msg) { Util::Trace("Component", msg, S_OK) ;} static inline void trace(char* msg, HRESULT hr) { Util::Trace("Component", msg, hr) ;} // // Type library name // const char szTypeLibName[] = "Server.tlb" ; /////////////////////////////////////////////////////////// // // Interface IX - Implementation // HRESULT __stdcall CA::Fx() { trace("!!!!! We made it here!!!!!") ; return S_OK ; } HRESULT __stdcall CA::FxStringIn(BSTR bstrIn) { // Display the incoming string. ostrstream sout ; sout << "FxStringIn received a string: " << bstrIn << ends ; trace(sout.str()) ; return S_OK ; } HRESULT __stdcall CA::FxStringOut(BSTR* pbstrOut) { const wchar_t wsz[] = L"[String from FxStringOut]" ; // Allocate an outgoing string. *pbstrOut = ::SysAllocString(wsz) ; if (*pbstrOut == NULL) { return E_OUTOFMEMORY ; } return S_OK ; } HRESULT __stdcall CA::FxFakeError() { trace("FxFakeError is faking an error.") ; // Create the error info object. ICreateErrorInfo* pICreateErr ; HRESULT hr = ::CreateErrorInfo(&pICreateErr) ; if (FAILED(hr)) { return E_FAIL ; } // pICreateErr->SetHelpFile(...) ; // pICreateErr->SetHelpContext(...) ; pICreateErr->SetSource(L"InsideCOM.Chap11") ; pICreateErr->SetDescription( L"This is a fake error generated by the component.") ; IErrorInfo* pIErrorInfo = NULL ; hr = pICreateErr->QueryInterface(IID_IErrorInfo, (void**)&pIErrorInfo) ; if (SUCCEEDED(hr)) { ::SetErrorInfo(0L, pIErrorInfo) ; pIErrorInfo->Release() ; } pICreateErr->Release() ; return E_FAIL ; } // // Constructor // CA::CA(IUnknown* pUnknownOuter) : CUnknown(pUnknownOuter), m_pITypeInfo(NULL) { // Empty } // // Destructor // CA::~CA() { if (m_pITypeInfo != NULL) { m_pITypeInfo->Release() ; } trace("Destroy self.") ; } // // NondelegatingQueryInterface implementation // HRESULT __stdcall CA::NondelegatingQueryInterface(const IID& iid, void** ppv) { if (iid == IID_IX) { return FinishQI(static_cast(this), ppv) ; } else if (iid == IID_IDispatch) { trace("Queried for IDispatch.") ; return FinishQI(static_cast(this), ppv) ; } else if (iid == IID_ISupportErrorInfo) { trace("Queried for ISupportErrorInfo.") ; return FinishQI(static_cast(this), ppv) ; } else { return CUnknown::NondelegatingQueryInterface(iid, ppv) ; } } // // Load and register the type library. // HRESULT CA::Init() { HRESULT hr ; // Load TypeInfo on demand if we haven't already loaded it. if (m_pITypeInfo == NULL) { ITypeLib* pITypeLib = NULL ; hr = ::LoadRegTypeLib(LIBID_ServerLib, 1, 0, // Major/Minor version numbers 0x00, &pITypeLib) ; if (FAILED(hr)) { trace("LoadRegTypeLib Failed, now trying LoadTypeLib.", hr) ; // If it wasn't registered, try to load it from the path. // Get the fullname of the server's executable. char szModule[512] ; DWORD dwResult = ::GetModuleFileName(CFactory::s_hModule, szModule, 512) ; // Split the fullname to get the pathname. char szDrive[_MAX_DRIVE]; char szDir[_MAX_DIR]; _splitpath(szModule, szDrive, szDir, NULL, NULL) ; // Append name of registry. char szTypeLibFullName[_MAX_PATH]; sprintf(szTypeLibFullName, "%s%s%s", szDrive, szDir, szTypeLibName) ; // convert to wide char wchar_t wszTypeLibFullName[_MAX_PATH] ; mbstowcs(wszTypeLibFullName, szTypeLibFullName, _MAX_PATH) ; // if LoadTypeLib succeeds, it will have registered // the type library for us. // for the next time. hr = ::LoadTypeLib(wszTypeLibFullName, &pITypeLib) ; if(FAILED(hr)) { trace("LoadTypeLib Failed.", hr) ; return hr; } // Ensure that the type library is registered. hr = RegisterTypeLib(pITypeLib, wszTypeLibFullName, NULL) ; if(FAILED(hr)) { trace("RegisterTypeLib Failed.", hr) ; return hr ; } } // Get type information for the interface of the object. hr = pITypeLib->GetTypeInfoOfGuid(IID_IX, &m_pITypeInfo) ; pITypeLib->Release() ; if (FAILED(hr)) { trace("GetTypeInfoOfGuid failed.", hr) ; return hr ; } } return S_OK ; } /////////////////////////////////////////////////////////// // // Creation function used by CFactory // HRESULT CA::CreateInstance(IUnknown* pUnknownOuter, CUnknown** ppNewComponent ) { if (pUnknownOuter != NULL) { // Don't allow aggregation (just for the heck of it). return CLASS_E_NOAGGREGATION ; } *ppNewComponent = new CA(pUnknownOuter) ; return S_OK ; } /////////////////////////////////////////////////////////// // // IDispatch implementation // HRESULT __stdcall CA::GetTypeInfoCount(UINT* pCountTypeInfo) { trace("GetTypeInfoCount call succeeded.") ; *pCountTypeInfo = 1 ; return S_OK ; } HRESULT __stdcall CA::GetTypeInfo( UINT iTypeInfo, LCID, // This object does not support localization. ITypeInfo** ppITypeInfo) { *ppITypeInfo = NULL ; if(iTypeInfo != 0) { trace("GetTypeInfo call failed -- bad iTypeInfo index.") ; return DISP_E_BADINDEX ; } trace("GetTypeInfo call succeeded.") ; // Call AddRef and return the pointer. m_pITypeInfo->AddRef() ; *ppITypeInfo = m_pITypeInfo ; return S_OK ; } HRESULT __stdcall CA::GetIDsOfNames( const IID& iid, OLECHAR** arrayNames, UINT countNames, LCID, // Localization is not supported. DISPID* arrayDispIDs) { if (iid != IID_NULL) { trace("GetIDsOfNames call failed -- bad IID.") ; return DISP_E_UNKNOWNINTERFACE ; } trace("GetIDsOfNames call succeeded.") ; HRESULT hr = m_pITypeInfo->GetIDsOfNames(arrayNames, countNames, arrayDispIDs) ; return hr ; } HRESULT __stdcall CA::Invoke( DISPID dispidMember, const IID& iid, LCID, // Localization is not supported. WORD wFlags, DISPPARAMS* pDispParams, VARIANT* pvarResult, EXCEPINFO* pExcepInfo, UINT* pArgErr) { if (iid != IID_NULL) { trace("Invoke call failed -- bad IID.") ; return DISP_E_UNKNOWNINTERFACE ; } ::SetErrorInfo(0, NULL) ; trace("Invoke call succeeded.") ; HRESULT hr = m_pITypeInfo->Invoke( static_cast(this), dispidMember, wFlags, pDispParams, pvarResult, pExcepInfo, pArgErr) ; return hr ; } camlidl-camlidl109/tests/dispatch/CMPNT.H000066400000000000000000000034031366176261100202640ustar00rootroot00000000000000// // Cmpnt.cpp - Component // #include "Iface.h" #include "CUnknown.h" /////////////////////////////////////////////////////////// // // Component A // class CA : public CUnknown, public IX, public ISupportErrorInfo { public: // Creation static HRESULT CreateInstance(IUnknown* pUnknownOuter, CUnknown** ppNewComponent ) ; private: // Declare the delegating IUnknown. DECLARE_IUNKNOWN // IUnknown virtual HRESULT __stdcall NondelegatingQueryInterface(const IID& iid, void** ppv) ; // IDispatch virtual HRESULT __stdcall GetTypeInfoCount(UINT* pCountTypeInfo) ; virtual HRESULT __stdcall GetTypeInfo( UINT iTypeInfo, LCID, // Localization is not supported. ITypeInfo** ppITypeInfo) ; virtual HRESULT __stdcall GetIDsOfNames( const IID& iid, OLECHAR** arrayNames, UINT countNames, LCID, // Localization is not supported. DISPID* arrayDispIDs) ; virtual HRESULT __stdcall Invoke( DISPID dispidMember, const IID& iid, LCID, // Localization is not supported. WORD wFlags, DISPPARAMS* pDispParams, VARIANT* pvarResult, EXCEPINFO* pExcepInfo, UINT* pArgErr) ; // Interface IX virtual HRESULT __stdcall Fx() ; virtual HRESULT __stdcall FxStringIn(BSTR bstrIn) ; virtual HRESULT __stdcall FxStringOut(BSTR* pbstrOut) ; virtual HRESULT __stdcall FxFakeError() ; // ISupportErrorInfo virtual HRESULT __stdcall InterfaceSupportsErrorInfo(const IID& riid) { return (riid == IID_IX) ? S_OK : S_FALSE ; } // Initialization virtual HRESULT Init() ; // Constructor CA(IUnknown* pUnknownOuter) ; // Destructor ~CA() ; // Pointer to type information. ITypeInfo* m_pITypeInfo ; } ; camlidl-camlidl109/tests/dispatch/CUNKNOWN.CPP000066400000000000000000000046101366176261100211010ustar00rootroot00000000000000/////////////////////////////////////////////////////////// // // CUnknown.cpp // // Implementation of IUnknown Base class // #include "CUnknown.h" #include "CFactory.h" #include "Util.h" static inline void trace(char* msg) {Util::Trace("CUnknown", msg, S_OK) ;} static inline void trace(char* msg, HRESULT hr) {Util::Trace("CUnknown", msg, hr) ;} /////////////////////////////////////////////////////////// // // Count of active objects // - Use to determine if we can unload the DLL. // long CUnknown::s_cActiveComponents = 0 ; /////////////////////////////////////////////////////////// // // Constructor // CUnknown::CUnknown(IUnknown* pUnknownOuter) : m_cRef(1) { // Set m_pUnknownOuter pointer. if (pUnknownOuter == NULL) { trace("Not aggregating; delegate to nondelegating IUnknown.") ; m_pUnknownOuter = reinterpret_cast (static_cast (this)) ; // notice cast } else { trace("Aggregating; delegate to outer IUnknown.") ; m_pUnknownOuter = pUnknownOuter ; } // Increment count of active components. ::InterlockedIncrement(&s_cActiveComponents) ; } // // Destructor // CUnknown::~CUnknown() { ::InterlockedDecrement(&s_cActiveComponents) ; // If this is an EXE server, shut it down. CFactory::CloseExe() ; } // // FinalRelease - called by Release before it deletes the component // void CUnknown::FinalRelease() { trace("Increment reference count for final release.") ; m_cRef = 1 ; } // // Nondelegating IUnknown // - Override to handle custom interfaces. // HRESULT __stdcall CUnknown::NondelegatingQueryInterface(const IID& iid, void** ppv) { // CUnknown supports only IUnknown. if (iid == IID_IUnknown) { return FinishQI(reinterpret_cast (static_cast(this)), ppv) ; } else { *ppv = NULL ; return E_NOINTERFACE ; } } // // AddRef // ULONG __stdcall CUnknown::NondelegatingAddRef() { return InterlockedIncrement(&m_cRef) ; } // // Release // ULONG __stdcall CUnknown::NondelegatingRelease() { InterlockedDecrement(&m_cRef) ; if (m_cRef == 0) { FinalRelease() ; delete this ; return 0 ; } return m_cRef ; } // // FinishQI // - Helper function to simplify overriding // NondelegatingQueryInterface // HRESULT CUnknown::FinishQI(IUnknown* pI, void** ppv) { *ppv = pI ; pI->AddRef() ; return S_OK ; } camlidl-camlidl109/tests/dispatch/CUNKNOWN.H000066400000000000000000000052371366176261100206540ustar00rootroot00000000000000#ifndef __CUnknown_h__ #define __CUnknown_h__ #include /////////////////////////////////////////////////////////// // // Nondelegating IUnknown interface // - Nondelegating version of IUnknown // interface INondelegatingUnknown { virtual HRESULT __stdcall NondelegatingQueryInterface(const IID& iid, void** ppv) = 0 ; virtual ULONG __stdcall NondelegatingAddRef() = 0 ; virtual ULONG __stdcall NondelegatingRelease() = 0 ; } ; /////////////////////////////////////////////////////////// // // Declaration of CUnknown // - Base class for implementing IUnknown // class CUnknown : public INondelegatingUnknown { public: // Nondelegating IUnknown implementation virtual HRESULT __stdcall NondelegatingQueryInterface(const IID&, void**) ; virtual ULONG __stdcall NondelegatingAddRef() ; virtual ULONG __stdcall NondelegatingRelease() ; // Constructor CUnknown(IUnknown* pUnknownOuter) ; // Destructor virtual ~CUnknown() ; // Initialization (especially for aggregates) virtual HRESULT Init() { return S_OK ;} // Notification to derived classes that we are releasing virtual void FinalRelease() ; // Count of currently active components static long ActiveComponents() { return s_cActiveComponents ;} // Helper function HRESULT FinishQI(IUnknown* pI, void** ppv) ; protected: // Support for delegation IUnknown* GetOuterUnknown() const { return m_pUnknownOuter ;} private: // Reference count for this object long m_cRef ; // Pointer to (external) outer IUnknown IUnknown* m_pUnknownOuter ; // Count of all active instances static long s_cActiveComponents ; } ; /////////////////////////////////////////////////////////// // // Delegating IUnknown // - Delegates to the nondelegating IUnknown, or to the // outer IUnknown if the component is aggregated. // #define DECLARE_IUNKNOWN \ virtual HRESULT __stdcall \ QueryInterface(const IID& iid, void** ppv) \ { \ return GetOuterUnknown()->QueryInterface(iid,ppv) ; \ } ; \ virtual ULONG __stdcall AddRef() \ { \ return GetOuterUnknown()->AddRef() ; \ } ; \ virtual ULONG __stdcall Release() \ { \ return GetOuterUnknown()->Release() ; \ } ; /////////////////////////////////////////////////////////// #endif camlidl-camlidl109/tests/dispatch/DCLIENT.CPP000066400000000000000000000150721366176261100207250ustar00rootroot00000000000000// // DClient.cpp - Dispatch client implementation // // This client connects to the IX dual interface // through the dispinterface. // #include #include "Util.h" static inline void trace(char* msg) { Util::Trace("DClient", msg, S_OK) ;} static inline void trace(char* msg, HRESULT hr) { Util::Trace("DClient", msg, hr) ;} void test(wchar_t * progid) { DWORD clsctx ; clsctx = CLSCTX_INPROC_SERVER ; trace("Attempt to create in-proc component.") ; // Get the CLSID for the application. CLSID clsid ; HRESULT hr = ::CLSIDFromProgID(progid, &clsid) ; if(FAILED(hr)) { trace("Failed to get CLSID.", hr) ; return ; } // Create the component. IDispatch* pIDispatch = NULL ; hr = ::CoCreateInstance(clsid, NULL, clsctx, IID_IDispatch, (void**)&pIDispatch) ; if (FAILED(hr)) { trace("Create instance failed.", hr) ; OleUninitialize() ; return ; } trace("CoCreateInstance succeeded.") ; // First we need to get the IDs for the function names. trace("Get DispID for function \"Fx\".") ; DISPID dispid ; OLECHAR* name = L"Fx" ; hr = pIDispatch->GetIDsOfNames(IID_NULL, &name, 1, GetUserDefaultLCID(), &dispid) ; if (FAILED(hr)) { trace("Query GetIDsOfNames failed.", hr) ; pIDispatch->Release() ; return ; } // Prepare the arguments for Fx. DISPPARAMS dispparamsNoArgs = { NULL, NULL, 0, // Zero arguments 0 // Zero named arguments } ; trace("Invoke the function \"Fx\".") ; hr = pIDispatch->Invoke(dispid, IID_NULL, GetUserDefaultLCID(), DISPATCH_METHOD, &dispparamsNoArgs, NULL, NULL, NULL) ; if (FAILED(hr)) { trace("Invoke call failed.", hr) ; pIDispatch->Release() ; return ; } // // Now pass a BSTR to the component. // trace("Get DispID for function \"FxStringIn\".") ; name = L"FxStringIn" ; hr = pIDispatch->GetIDsOfNames(IID_NULL, &name, 1, GetUserDefaultLCID(), &dispid) ; if (FAILED(hr)) { trace("Query GetIDsOfNames failed.", hr) ; pIDispatch->Release() ; return ; } // Pass the following string to the component. wchar_t wszIn[] = L"This is the test." ; // Convert the wide-character string to a BSTR. BSTR bstrIn ; bstrIn = ::SysAllocString(wszIn) ; // Build up the parameters for the invoke call. // Allocate and initialize a VARIANT argument. VARIANTARG varg ; ::VariantInit(&varg) ; // Initialize the VARIANT. varg.vt = VT_BSTR ; // Type of VARIANT data varg.bstrVal = bstrIn ; // Data for the VARIANT // Fill in the DISPPARAMS structure. DISPPARAMS param ; param.cArgs = 1 ; // Number of arguments param.rgvarg = &varg ; // Arguments param.cNamedArgs = 0 ; // Number of named args param.rgdispidNamedArgs = NULL ; // Named arguments trace("Invoke the function \"FxStringIn\".") ; hr = pIDispatch->Invoke(dispid, IID_NULL, GetUserDefaultLCID(), DISPATCH_METHOD, ¶m, NULL, NULL, NULL) ; if (FAILED(hr)) { trace("Invoke call failed.", hr) ; pIDispatch->Release() ; return ; } // Clean up ::SysFreeString(bstrIn) ; // // Now get a BSTR back from the component. // // Get the dispid. trace("Get DispID for function \"FxStringOut\".") ; name = L"FxStringOut" ; hr = pIDispatch->GetIDsOfNames(IID_NULL, &name, 1, GetUserDefaultLCID(), &dispid) ; if (FAILED(hr)) { trace("Query GetIDsOfNames failed.", hr) ; pIDispatch->Release() ; return ; } // Allocate a variant for the returned parameter. VARIANT varResult ; ::VariantInit(&varResult) ; // Invoke the function. trace("Invoke the function \"FxStringOut\".") ; hr = pIDispatch->Invoke(dispid, IID_NULL, GetUserDefaultLCID(), DISPATCH_METHOD, &dispparamsNoArgs, //¶m, &varResult, NULL, NULL) ; if (FAILED(hr)) { trace("Invoke call failed.", hr) ; pIDispatch->Release() ; return ; } // Display the returned string. if (varResult.vt == VT_BSTR) { strstream sout ; sout << "String returned from component: " << varResult.bstrVal << ends ; trace(sout.str()) ; // Free the string. ::SysFreeString(varResult.bstrVal) ; } // // Show how to handle a function which returns an EXCEPINFO. // trace("Get DispID for function \"FxFakeError\"") ; name = L"FxFakeError" ; hr = pIDispatch->GetIDsOfNames(IID_NULL, &name, 1, GetUserDefaultLCID(), &dispid) ; if (FAILED(hr)) { trace("Query GetIDsOfNames failed.", hr) ; pIDispatch->Release() ; return ; } EXCEPINFO excepinfo ; trace("Invoke the function \"FxFakeError\".") ; hr = pIDispatch->Invoke(dispid, IID_NULL, GetUserDefaultLCID(), DISPATCH_METHOD, &dispparamsNoArgs, NULL, &excepinfo, NULL) ; if (FAILED(hr)) { trace("FxFakeError failed.", hr) ; if (hr == DISP_E_EXCEPTION) { trace("We have error information from the component.") ; if (excepinfo.pfnDeferredFillIn != NULL) { (*(excepinfo.pfnDeferredFillIn))(&excepinfo) ; } strstream sout ; sout << "Information from component: " << excepinfo.bstrSource << "/" << excepinfo.bstrDescription << ends ; trace(sout.str()) ; } } // Release the dispatch interface. pIDispatch->Release() ; } int main() { HRESULT hr = OleInitialize(NULL) ; if (FAILED(hr)) { trace("Failed to initialize.", hr) ; return 1 ; } test(L"InsideCOM.Chap11"); test(L"CAMLIDL.Testcomp2"); // Uninitialize the OLE library. OleUninitialize() ; return 0 ; } camlidl-camlidl109/tests/dispatch/IFACE.H000066400000000000000000000170511366176261100202160ustar00rootroot00000000000000/* this ALWAYS GENERATED file contains the definitions for the interfaces */ /* File created by MIDL compiler version 5.01.0164 */ /* at Mon Mar 15 14:37:47 1999 */ /* Compiler settings for Server.idl: Os (OptLev=s), W1, Zp8, env=Win32, ms_ext, c_ext error checks: allocation ref bounds_check enum stub_data */ //@@MIDL_FILE_HEADING( ) /* verify that the version is high enough to compile this file*/ #ifndef __REQUIRED_RPCNDR_H_VERSION__ #define __REQUIRED_RPCNDR_H_VERSION__ 440 #endif #include "rpc.h" #include "rpcndr.h" #ifndef __RPCNDR_H_VERSION__ #error this stub requires an updated version of #endif // __RPCNDR_H_VERSION__ #ifndef COM_NO_WINDOWS_H #include "windows.h" #include "ole2.h" #endif /*COM_NO_WINDOWS_H*/ #ifndef __Iface_h__ #define __Iface_h__ #ifdef __cplusplus extern "C"{ #endif /* Forward Declarations */ #ifndef __IX_FWD_DEFINED__ #define __IX_FWD_DEFINED__ typedef interface IX IX; #endif /* __IX_FWD_DEFINED__ */ #ifndef __Component_FWD_DEFINED__ #define __Component_FWD_DEFINED__ #ifdef __cplusplus typedef class Component Component; #else typedef struct Component Component; #endif /* __cplusplus */ #endif /* __Component_FWD_DEFINED__ */ /* header files for imported files */ #include "oaidl.h" void __RPC_FAR * __RPC_USER MIDL_user_allocate(size_t); void __RPC_USER MIDL_user_free( void __RPC_FAR * ); #ifndef __IX_INTERFACE_DEFINED__ #define __IX_INTERFACE_DEFINED__ /* interface IX */ /* [oleautomation][dual][unique][helpstring][uuid][object] */ EXTERN_C const IID IID_IX; #if defined(__cplusplus) && !defined(CINTERFACE) MIDL_INTERFACE("32BB8326-B41B-11CF-A6BB-0080C7B2D682") IX : public IDispatch { public: virtual HRESULT STDMETHODCALLTYPE Fx( void) = 0; virtual HRESULT STDMETHODCALLTYPE FxStringIn( /* [in] */ BSTR bstrIn) = 0; virtual HRESULT STDMETHODCALLTYPE FxStringOut( /* [retval][out] */ BSTR __RPC_FAR *pbstrOut) = 0; virtual HRESULT STDMETHODCALLTYPE FxFakeError( void) = 0; }; #else /* C style interface */ typedef struct IXVtbl { BEGIN_INTERFACE HRESULT ( STDMETHODCALLTYPE __RPC_FAR *QueryInterface )( IX __RPC_FAR * This, /* [in] */ REFIID riid, /* [iid_is][out] */ void __RPC_FAR *__RPC_FAR *ppvObject); ULONG ( STDMETHODCALLTYPE __RPC_FAR *AddRef )( IX __RPC_FAR * This); ULONG ( STDMETHODCALLTYPE __RPC_FAR *Release )( IX __RPC_FAR * This); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetTypeInfoCount )( IX __RPC_FAR * This, /* [out] */ UINT __RPC_FAR *pctinfo); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetTypeInfo )( IX __RPC_FAR * This, /* [in] */ UINT iTInfo, /* [in] */ LCID lcid, /* [out] */ ITypeInfo __RPC_FAR *__RPC_FAR *ppTInfo); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetIDsOfNames )( IX __RPC_FAR * This, /* [in] */ REFIID riid, /* [size_is][in] */ LPOLESTR __RPC_FAR *rgszNames, /* [in] */ UINT cNames, /* [in] */ LCID lcid, /* [size_is][out] */ DISPID __RPC_FAR *rgDispId); /* [local] */ HRESULT ( STDMETHODCALLTYPE __RPC_FAR *Invoke )( IX __RPC_FAR * This, /* [in] */ DISPID dispIdMember, /* [in] */ REFIID riid, /* [in] */ LCID lcid, /* [in] */ WORD wFlags, /* [out][in] */ DISPPARAMS __RPC_FAR *pDispParams, /* [out] */ VARIANT __RPC_FAR *pVarResult, /* [out] */ EXCEPINFO __RPC_FAR *pExcepInfo, /* [out] */ UINT __RPC_FAR *puArgErr); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *Fx )( IX __RPC_FAR * This); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *FxStringIn )( IX __RPC_FAR * This, /* [in] */ BSTR bstrIn); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *FxStringOut )( IX __RPC_FAR * This, /* [retval][out] */ BSTR __RPC_FAR *pbstrOut); HRESULT ( STDMETHODCALLTYPE __RPC_FAR *FxFakeError )( IX __RPC_FAR * This); END_INTERFACE } IXVtbl; interface IX { CONST_VTBL struct IXVtbl __RPC_FAR *lpVtbl; }; #ifdef COBJMACROS #define IX_QueryInterface(This,riid,ppvObject) \ (This)->lpVtbl -> QueryInterface(This,riid,ppvObject) #define IX_AddRef(This) \ (This)->lpVtbl -> AddRef(This) #define IX_Release(This) \ (This)->lpVtbl -> Release(This) #define IX_GetTypeInfoCount(This,pctinfo) \ (This)->lpVtbl -> GetTypeInfoCount(This,pctinfo) #define IX_GetTypeInfo(This,iTInfo,lcid,ppTInfo) \ (This)->lpVtbl -> GetTypeInfo(This,iTInfo,lcid,ppTInfo) #define IX_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) \ (This)->lpVtbl -> GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) #define IX_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) \ (This)->lpVtbl -> Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) #define IX_Fx(This) \ (This)->lpVtbl -> Fx(This) #define IX_FxStringIn(This,bstrIn) \ (This)->lpVtbl -> FxStringIn(This,bstrIn) #define IX_FxStringOut(This,pbstrOut) \ (This)->lpVtbl -> FxStringOut(This,pbstrOut) #define IX_FxFakeError(This) \ (This)->lpVtbl -> FxFakeError(This) #endif /* COBJMACROS */ #endif /* C style interface */ HRESULT STDMETHODCALLTYPE IX_Fx_Proxy( IX __RPC_FAR * This); void __RPC_STUB IX_Fx_Stub( IRpcStubBuffer *This, IRpcChannelBuffer *_pRpcChannelBuffer, PRPC_MESSAGE _pRpcMessage, DWORD *_pdwStubPhase); HRESULT STDMETHODCALLTYPE IX_FxStringIn_Proxy( IX __RPC_FAR * This, /* [in] */ BSTR bstrIn); void __RPC_STUB IX_FxStringIn_Stub( IRpcStubBuffer *This, IRpcChannelBuffer *_pRpcChannelBuffer, PRPC_MESSAGE _pRpcMessage, DWORD *_pdwStubPhase); HRESULT STDMETHODCALLTYPE IX_FxStringOut_Proxy( IX __RPC_FAR * This, /* [retval][out] */ BSTR __RPC_FAR *pbstrOut); void __RPC_STUB IX_FxStringOut_Stub( IRpcStubBuffer *This, IRpcChannelBuffer *_pRpcChannelBuffer, PRPC_MESSAGE _pRpcMessage, DWORD *_pdwStubPhase); HRESULT STDMETHODCALLTYPE IX_FxFakeError_Proxy( IX __RPC_FAR * This); void __RPC_STUB IX_FxFakeError_Stub( IRpcStubBuffer *This, IRpcChannelBuffer *_pRpcChannelBuffer, PRPC_MESSAGE _pRpcMessage, DWORD *_pdwStubPhase); #endif /* __IX_INTERFACE_DEFINED__ */ #ifndef __ServerLib_LIBRARY_DEFINED__ #define __ServerLib_LIBRARY_DEFINED__ /* library ServerLib */ /* [helpstring][version][uuid] */ EXTERN_C const IID LIBID_ServerLib; EXTERN_C const CLSID CLSID_Component; #ifdef __cplusplus class DECLSPEC_UUID("0C092C2C-882C-11CF-A6BB-0080C7B2D682") Component; #endif #endif /* __ServerLib_LIBRARY_DEFINED__ */ /* Additional Prototypes for ALL interfaces */ unsigned long __RPC_USER BSTR_UserSize( unsigned long __RPC_FAR *, unsigned long , BSTR __RPC_FAR * ); unsigned char __RPC_FAR * __RPC_USER BSTR_UserMarshal( unsigned long __RPC_FAR *, unsigned char __RPC_FAR *, BSTR __RPC_FAR * ); unsigned char __RPC_FAR * __RPC_USER BSTR_UserUnmarshal(unsigned long __RPC_FAR *, unsigned char __RPC_FAR *, BSTR __RPC_FAR * ); void __RPC_USER BSTR_UserFree( unsigned long __RPC_FAR *, BSTR __RPC_FAR * ); /* end of Additional Prototypes */ #ifdef __cplusplus } #endif #endif camlidl-camlidl109/tests/dispatch/MAKEFILE000066400000000000000000000065551366176261100204050ustar00rootroot00000000000000# # Chapter 11 - Makefile # TARGETS = Server.dll DIR_SERVER = InProc # # Flags - Always compiles debug # CPP_FLAGS=/c /MT /Zi /Od /D_DEBUG EXE_LINK_FLAGS= /NOD /DEBUG DLL_LINK_FLAGS=/NOD /DLL /DEBUG LIBS = kernel32.lib uuid.lib advapi32.lib ole32.lib oleaut32.lib # NOTE: Added oleaut32.lib ################################################# # # Targets # all : Client.exe DClient.exe $(TARGETS) camlclient camlcomponent ################################################# # # Proxy source files # Iface.h Server.tlb Proxy.c Guids.c DllData.c : Server.idl midl /h Iface.h /iid Guids.c /proxy Proxy.c Server.idl ################################################# # # Shared source files # Guids.obj : Guids.c cl $(CPP_FLAGS) Guids.c ################################################# # # Component/server source files # Server.obj : Server.cpp cunknown.h cfactory.h Iface.h cl $(CPP_FLAGS) Server.cpp Cmpnt.obj : Cmpnt.cpp Cmpnt.h Iface.h Registry.h \ CUnknown.h cl $(CPP_FLAGS) Cmpnt.cpp # # Helper classes # CUnknown.obj : CUnknown.cpp CUnknown.h cl $(CPP_FLAGS) $(SERVER) CUnknown.cpp CFactory.obj : CFactory.cpp CFactory.h cl $(CPP_FLAGS) $(SERVER) CFactory.cpp Registry.obj : Registry.cpp Registry.h cl $(CPP_FLAGS) $(SERVER) Registry.cpp ################################################# # # Client source files # Client.obj : Client.cpp Iface.h Util.h cl $(CPP_FLAGS) Client.cpp DClient.obj : DClient.cpp Util.h cl $(CPP_FLAGS) DClient.cpp # Util.cpp compiled for the client Util.obj : Util.cpp Util.h cl $(CPP_FLAGS) Util.cpp ################################################# # # Link component - Automatically register component. # SERVER_OBJS = Server.obj \ Cmpnt.obj \ Registry.obj \ CFactory.obj \ CUnknown.obj \ Util.obj \ Guids.obj Server.dll: $(SERVER_OBJS) Server.def link $(DLL_LINK_FLAGS) $(SERVER_OBJS) libcmtd.lib \ libcimtd.lib $(LIBS) /DEF:Server.def regsvr32 -s Server.dll ################################################# # # Link clients # Client.exe : Client.obj Guids.obj Util.obj link $(EXE_LINK_FLAGS) Client.obj Guids.obj Util.obj \ libcmtd.lib libcimtd.lib $(LIBS) DClient.exe : DClient.obj Util.obj link $(EXE_LINK_FLAGS) DClient.obj Guids.obj Util.obj \ libcmtd.lib libcimtd.lib $(LIBS) ############# # # Caml side # camlclient : camlclient.exe camlclient.exe: component.obj GUIDs.obj component.cmo camlclient.cmo ocamlc -verbose -ccopt /Zi -o camlclient.exe -custom \ com.cma component.cmo camlclient.cmo \ component.obj GUIDs.obj \ -cclib -lcamlidl oleaut32.lib ole32.lib component.ml component.mli component.c: component.idl ../../compiler/camlidl ../../compiler/camlidl -header component.idl component.cmo: component.ml component.cmi component.cmi: component.mli camlclient.cmo: component.cmi camlcomponent: camlcomp.dll COMPONENTFILES=\ component.obj GUIDs.obj \ component.cmo camlcomp.cmo camlcomp.cmo \ component.tlb camlcomp.dll: $(COMPONENTFILES) camlidldll -o camlcomp.dll $(COMPONENTFILES) regsvr32 -s camlcomp.dll component.tlb: component.idl midl /client none /server none /header component.h2 /newtlb component.idl camlcomp.cmo: component.cmi .SUFFIXES: .ml .mli .cmo .cmi .c .obj .ml.cmo: ocamlc -I ../.. -c $< .mli.cmi: ocamlc -I ../.. -c $< .c.obj: ocamlc -ccopt /Zi -c $< camlidl-camlidl109/tests/dispatch/README000066400000000000000000000002731366176261100201540ustar00rootroot00000000000000The source files in uppercase come from an example in "Inside Com", Dale Rogerson, Microsoft Press. Although no license is provided for those files, I hope it's OK to redistribute them. camlidl-camlidl109/tests/dispatch/REGISTRY.CPP000066400000000000000000000172361366176261100211170ustar00rootroot00000000000000// // Registry.cpp // #include #include #include "Registry.h" //////////////////////////////////////////////////////// // // Internal helper functions prototypes // // Set the given key and its value. BOOL setKeyAndValue(const char* pszPath, const char* szSubkey, const char* szValue) ; // Convert a GUID into a char string. void GUIDtochar(const GUID& guid, char* szGUID, int length) ; // Determine if a particular subkey exists. BOOL SubkeyExists(const char* pszPath, const char* szSubkey) ; // Delete szKeyChild and all of its descendents. LONG recursiveDeleteKey(HKEY hKeyParent, const char* szKeyChild) ; //////////////////////////////////////////////////////// // // Constants // // Size of a GUID as a string const int GUID_STRING_SIZE = 39 ; ///////////////////////////////////////////////////////// // // Public function implementation // // // Register the component in the registry. // HRESULT RegisterServer(HMODULE hModule, // DLL module handle const CLSID& clsid, // Class ID const char* szFriendlyName, // Friendly Name const char* szVerIndProgID, // Programmatic const char* szProgID, // IDs const GUID& libid) // Library ID { // Get server location. char szModule[512] ; DWORD dwResult = ::GetModuleFileName(hModule, szModule, sizeof(szModule)/sizeof(char)) ; assert(dwResult != 0) ; // Convert the CLSID into a char. char szCLSID[GUID_STRING_SIZE] ; GUIDtochar(clsid, szCLSID, sizeof(szCLSID)) ; // Build the key CLSID\\{...} char szKey[64] ; strcpy(szKey, "CLSID\\") ; strcat(szKey, szCLSID) ; // Add the CLSID to the registry. setKeyAndValue(szKey, NULL, szFriendlyName) ; // Add the server filename subkey under the CLSID key. #ifdef _OUTPROC_SERVER_ setKeyAndValue(szKey, "LocalServer32", szModule) ; #else setKeyAndValue(szKey, "InprocServer32", szModule) ; #endif // Add the ProgID subkey under the CLSID key. setKeyAndValue(szKey, "ProgID", szProgID) ; // Add the version-independent ProgID subkey under CLSID key. setKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID) ; // Add the Type Library ID subkey under the CLSID key. char szLIBID[GUID_STRING_SIZE] ; GUIDtochar(libid, szLIBID, sizeof(szLIBID)) ; setKeyAndValue(szKey, "TypeLib", szLIBID) ; // Add the version-independent ProgID subkey under HKEY_CLASSES_ROOT. setKeyAndValue(szVerIndProgID, NULL, szFriendlyName) ; setKeyAndValue(szVerIndProgID, "CLSID", szCLSID) ; setKeyAndValue(szVerIndProgID, "CurVer", szProgID) ; // Add the versioned ProgID subkey under HKEY_CLASSES_ROOT. setKeyAndValue(szProgID, NULL, szFriendlyName) ; setKeyAndValue(szProgID, "CLSID", szCLSID) ; return S_OK ; } // // Remove the component from the registry. // LONG UnregisterServer(const CLSID& clsid, // Class ID const char* szVerIndProgID, // Programmatic const char* szProgID) // IDs { // Convert the CLSID into a char. char szCLSID[GUID_STRING_SIZE] ; GUIDtochar(clsid, szCLSID, sizeof(szCLSID)) ; // Build the key CLSID\\{...} char szKey[80] ; strcpy(szKey, "CLSID\\") ; strcat(szKey, szCLSID) ; // Check for a another server for this component. #ifdef _OUTPROC_SERVER_ if (SubkeyExists(szKey, "InprocServer32")) #else if (SubkeyExists(szKey, "LocalServer32")) #endif { // Delete only the path for this server. #ifdef _OUTPROC_SERVER_ strcat(szKey, "\\LocalServer32") ; #else strcat(szKey, "\\InprocServer32") ; #endif LONG lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szKey) ; assert(lResult == ERROR_SUCCESS) ; } else { // Delete all related keys. // Delete the CLSID Key - CLSID\{...} LONG lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szKey) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. // Delete the version-independent ProgID Key. lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szVerIndProgID) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. // Delete the ProgID key. lResult = recursiveDeleteKey(HKEY_CLASSES_ROOT, szProgID) ; assert((lResult == ERROR_SUCCESS) || (lResult == ERROR_FILE_NOT_FOUND)) ; // Subkey may not exist. } return S_OK ; } /////////////////////////////////////////////////////////// // // Internal helper functions // // Convert a GUID to a char string. void GUIDtochar(const GUID& guid, char* szGUID, int length) { assert(length >= GUID_STRING_SIZE) ; // Get wide string version. LPOLESTR wszGUID = NULL ; HRESULT hr = StringFromCLSID(guid, &wszGUID) ; assert(SUCCEEDED(hr)) ; // Covert from wide characters to non-wide. wcstombs(szGUID, wszGUID, length) ; // Free memory. CoTaskMemFree(wszGUID) ; } // // Delete a key and all of its descendents. // LONG recursiveDeleteKey(HKEY hKeyParent, // Parent of key to delete const char* lpszKeyChild) // Key to delete { // Open the child. HKEY hKeyChild ; LONG lRes = RegOpenKeyEx(hKeyParent, lpszKeyChild, 0, KEY_ALL_ACCESS, &hKeyChild) ; if (lRes != ERROR_SUCCESS) { return lRes ; } // Enumerate all of the decendents of this child. FILETIME time ; char szBuffer[256] ; DWORD dwSize = 256 ; while (RegEnumKeyEx(hKeyChild, 0, szBuffer, &dwSize, NULL, NULL, NULL, &time) == S_OK) { // Delete the decendents of this child. lRes = recursiveDeleteKey(hKeyChild, szBuffer) ; if (lRes != ERROR_SUCCESS) { // Cleanup before exiting. RegCloseKey(hKeyChild) ; return lRes; } dwSize = 256 ; } // Close the child. RegCloseKey(hKeyChild) ; // Delete this child. return RegDeleteKey(hKeyParent, lpszKeyChild) ; } // // Determine if a particular subkey exists. // BOOL SubkeyExists(const char* pszPath, // Path of key to check const char* szSubkey) // Key to check { HKEY hKey ; char szKeyBuf[80] ; // Copy keyname into buffer. strcpy(szKeyBuf, pszPath) ; // Add subkey name to buffer. if (szSubkey != NULL) { strcat(szKeyBuf, "\\") ; strcat(szKeyBuf, szSubkey ) ; } // Determine if key exists by trying to open it. LONG lResult = ::RegOpenKeyEx(HKEY_CLASSES_ROOT, szKeyBuf, 0, KEY_ALL_ACCESS, &hKey) ; if (lResult == ERROR_SUCCESS) { RegCloseKey(hKey) ; return TRUE ; } return FALSE ; } // // Create a key and set its value. // - This helper function was borrowed and modifed from // Kraig Brockschmidt's book Inside OLE. // BOOL setKeyAndValue(const char* szKey, const char* szSubkey, const char* szValue) { HKEY hKey; char szKeyBuf[1024] ; // Copy keyname into buffer. strcpy(szKeyBuf, szKey) ; // Add subkey name to buffer. if (szSubkey != NULL) { strcat(szKeyBuf, "\\") ; strcat(szKeyBuf, szSubkey ) ; } // Create and open key and subkey. long lResult = RegCreateKeyEx(HKEY_CLASSES_ROOT , szKeyBuf, 0, NULL, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, NULL, &hKey, NULL) ; if (lResult != ERROR_SUCCESS) { return FALSE ; } // Set the Value. if (szValue != NULL) { RegSetValueEx(hKey, NULL, 0, REG_SZ, (BYTE *)szValue, strlen(szValue)+1) ; } RegCloseKey(hKey) ; return TRUE ; } camlidl-camlidl109/tests/dispatch/REGISTRY.H000066400000000000000000000014651366176261100206610ustar00rootroot00000000000000#ifndef __Registry_H__ #define __Registry_H__ // // Registry.h // - Helper functions registering and unregistering a component. // // This function will register a component in the Registry. // The component calls this function from its DllRegisterServer function. HRESULT RegisterServer(HMODULE hModule, const CLSID& clsid, const char* szFriendlyName, const char* szVerIndProgID, const char* szProgID, const GUID& libid) ; // This function will unregister a component. Components // call this function from their DllUnregisterServer function. HRESULT UnregisterServer(const CLSID& clsid, const char* szVerIndProgID, const char* szProgID) ; #endif camlidl-camlidl109/tests/dispatch/SERVER.CPP000066400000000000000000000022131366176261100206420ustar00rootroot00000000000000#include "CFactory.h" #include "Iface.h" #include "Cmpnt.h" /////////////////////////////////////////////////////////// // // Server.cpp // // This file contains the component server code. // The FactoryDataArray contains the components that // can be served. // // Each component derived from CUnknown defines a static function // for creating the component with the following prototype. // HRESULT CreateInstance(IUnknown* pUnknownOuter, // CUnknown** ppNewComponent) ; // This function is used to create the component. // // // The following array contains the data used by CFactory // to create components. Each element in the array contains // the CLSID, the pointer to the creation function, and the name // of the component to place in the Registry. // CFactoryData g_FactoryDataArray[] = { {&CLSID_Component, CA::CreateInstance, "Inside COM, Chapter 11 Example", // Friendly Name "InsideCOM.Chap11", // ProgID "InsideCOM.Chap11.1", // Version-independent ProgID &LIBID_ServerLib, // Type Library ID NULL, 0} } ; int g_cFactoryDataEntries = sizeof(g_FactoryDataArray) / sizeof(CFactoryData) ; camlidl-camlidl109/tests/dispatch/SERVER.DEF000066400000000000000000000004571366176261100206260ustar00rootroot00000000000000LIBRARY Server.dll DESCRIPTION 'Chapter 11, Example COM Server (c)1996-1997 Dale E. Rogerson' EXPORTS DllGetClassObject @2 PRIVATE DllCanUnloadNow @3 PRIVATE DllRegisterServer @4 PRIVATE DllUnregisterServer @5 PRIVATE camlidl-camlidl109/tests/dispatch/SERVER.IDL000066400000000000000000000015651366176261100206410ustar00rootroot00000000000000// // Server.idl - IDL source for Server.dll // // This file will be processed by the MIDL compiler to // produce the type library (Server.tlb) and marshaling code. // // Interface IX [ object, uuid(32BB8326-B41B-11CF-A6BB-0080C7B2D682), helpstring("IX Interface"), pointer_default(unique), dual, oleautomation ] interface IX : IDispatch { import "oaidl.idl" ; HRESULT Fx() ; HRESULT FxStringIn([in] BSTR bstrIn) ; HRESULT FxStringOut([out, retval] BSTR* pbstrOut) ; HRESULT FxFakeError() ; } ; // // Component and type library descriptions // [ uuid(D3011EE1-B997-11CF-A6BB-0080C7B2D682), version(1.0), helpstring("Inside COM, Chapter 11 1.0 Type Library") ] library ServerLib { importlib("stdole32.tlb") ; // Component [ uuid(0C092C2C-882C-11CF-A6BB-0080C7B2D682), helpstring("Component Class") ] coclass Component { [default] interface IX ; } ; } ; camlidl-camlidl109/tests/dispatch/UTIL.CPP000066400000000000000000000033351366176261100204170ustar00rootroot00000000000000// // // util.cpp - Common utilities for printing out messages // // #include #include //sprintf #include #include // #include #include "util.h" #ifdef _OUTPROC_SERVER_ // We are building a local or remote server. // Listbox window handle extern HWND g_hWndListBox ; static inline void output(const char* sz) { ::SendMessage(g_hWndListBox, LB_ADDSTRING, 0, (LPARAM)sz) ; } #else // We are building an in-proc server. #include static inline void output(const char* sz) { cout << sz << endl ; } #endif //_OUTPROC_SERVER_ // // Utilities // namespace Util { // // Print out a message with a label. // void Trace(char* szLabel, char* szText, HRESULT hr) { char buf[256] ; sprintf(buf, "%s: \t%s", szLabel, szText) ; output(buf) ; if (FAILED(hr)) { ErrorMessage(hr) ; } } // // Print out the COM/OLE error string for an HRESULT. // void ErrorMessage(HRESULT hr) { void* pMsgBuf ; ::FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, hr, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Default language (LPTSTR)&pMsgBuf, 0, NULL ) ; char buf[256] ; sprintf(buf, "Error (%x): %s", hr, (char*)pMsgBuf) ; output(buf) ; // Free the buffer. LocalFree(pMsgBuf) ; } } ; // End Namespace Util // // Overloaded ostream insertion operator // Converts from wchar_t to char // ostream& operator<< ( ostream& os, const wchar_t* wsz ) { // Length of incoming string int iLength = wcslen(wsz)+1 ; // Allocate buffer for converted string. char* psz = new char[iLength] ; // Convert from wchar_t to char. wcstombs(psz, wsz, iLength) ; // Send it out. os << psz ; // cleanup delete [] psz ; return os ; } camlidl-camlidl109/tests/dispatch/camlclient.ml000066400000000000000000000024201366176261100217350ustar00rootroot00000000000000(* A simple client in Caml *) open Printf let testcomp clsid = print_string "Call Com.create_instance to create component and get interface IX"; print_newline(); begin try let ix = Com.create_instance clsid Component.iid_iX in let obj = Component.use_iX ix in print_string "Calling Fx..."; print_newline(); obj#fx; print_string "Calling FxStringIn(\"foo bar\")..."; print_newline(); obj#fxStringIn("foo bar"); print_string "Calling FxStringOut..."; print_newline(); let res = obj#fxStringOut in print_string "Result is: "; print_string res; print_newline(); print_string "Calling FxFakeError..."; print_newline(); begin try obj#fxFakeError; print_string "FxFakeError returned normally"; print_newline() with Com.Error(_, who, what) -> print_string "Exception Com.Error("; print_string who; print_string ", "; print_string what; print_string ")"; print_newline() end with Com.Error(_, src, msg) -> printf "COM error (%s): %s\n" src msg; flush stdout end let clsid_component1 = Com.clsid "0C092C2C-882C-11CF-A6BB-0080C7B2D682" let clsid_component2 = Com.clsid "6a3d0750-dad9-11d2-8e2c-0060974fbf19" let _ = Com.initialize(); testcomp clsid_component1; testcomp clsid_component2; Com.uninitialize() camlidl-camlidl109/tests/dispatch/camlcomp.ml000066400000000000000000000015101366176261100214140ustar00rootroot00000000000000(* A simple component in Caml *) class mycomponent = object method fx = (*print_string "Camlcomp: fx"; print_newline(); *) () method fxStringIn str = print_string "Camlcomp: fxStringIn "; print_string str; print_newline() method fxStringOut = (*print_string "Camlcomp: fxStringOut "; print_newline();*) "This string comes from Caml" method fxFakeError = (failwith "FxFakeError" : unit) end let factory () = (*print_string "Camlcomp: factory is called"; print_newline();*) Component.make_iX(new mycomponent) let _ = Com.register_factory { Com.create = factory; Com.clsid = Com.clsid "6a3d0750-dad9-11d2-8e2c-0060974fbf19"; Com.friendly_name = "CAMLIDL, test component 2"; Com.ver_ind_prog_id = "CAMLIDL.Testcomp2"; Com.prog_id = "CAMLIDL.Testcomp2.1" } camlidl-camlidl109/tests/dispatch/component.idl000066400000000000000000000012701366176261100217660ustar00rootroot00000000000000#ifndef CAMLIDL import "oaidl.idl" ; #endif [ object, uuid(32BB8326-B41B-11CF-A6BB-0080C7B2D682), pointer_default(unique), dual, oleautomation ] interface IX : IDispatch { HRESULT Fx() ; HRESULT FxStringIn([in] BSTR bstrIn) ; HRESULT FxStringOut([out, retval] BSTR* pbstrOut) ; HRESULT FxFakeError() ; } #ifndef CAMLIDL [ uuid(e59e3b70-dad8-11d2-8e2c-0060974fbf19), version(1.0), helpstring("CAMLIDL, test component 2, type library") ] library ComponentLib { importlib("stdole32.tlb") ; // Component [ uuid(6a3d0750-dad9-11d2-8e2c-0060974fbf19), helpstring("Component Class") ] coclass Component { [default] interface IX ; } ; } ; #endif camlidl-camlidl109/tests/hdirect/000077500000000000000000000000001366176261100171155ustar00rootroot00000000000000camlidl-camlidl109/tests/hdirect/.cvsignore000066400000000000000000000000431366176261100211120ustar00rootroot00000000000000test*.mli test*.ml test*.c test*.h camlidl-camlidl109/tests/hdirect/Makefile000066400000000000000000000013761366176261100205640ustar00rootroot00000000000000ALLTESTS=\ test001.idl test002.idl test003.idl test004.idl \ test007.idl test008.idl test009.idl test010.idl \ test011.idl test013.idl test014.idl test015.idl \ test016.idl test017.idl test018.idl test019.idl test020.idl \ test021.idl test022.idl test023.idl test024.idl test025.idl \ test026.idl test027.idl test028.idl test029.idl test030.idl \ test031.idl test032.idl test033.idl test034.idl test035.idl CAMLIDL=../../compiler/camlidl CAMLC=ocamlc -I ../../lib CC=gcc CFLAGS=-I../.. -I/usr/local/lib/ocaml -Wall all: $(ALLTESTS:.idl=.o) $(ALLTESTS:.idl=.o): $(CAMLIDL) .SUFFIXES: .SUFFIXES: .idl .o .idl.o: $(CAMLIDL) -header $*.idl $(CAMLC) -c $*.mli $(CAMLC) -c $*.ml $(CC) $(CFLAGS) -c $*.c clean: rm -f *.ml *.mli *.cm[io] *.[cho] *~ camlidl-camlidl109/tests/hdirect/test001.idl000066400000000000000000000001761366176261100210130ustar00rootroot00000000000000// --!! Toplevel constants const int x = 2; const int y = 0xff; // const int y = sizeof(int); /*FIXME*/ const int z = y + 1; camlidl-camlidl109/tests/hdirect/test002.idl000066400000000000000000000001271366176261100210100ustar00rootroot00000000000000// --!! Simpl toplevel typedefs typedef int foo; typedef foo bar; typedef foo baz; camlidl-camlidl109/tests/hdirect/test003.idl000066400000000000000000000004061366176261100210110ustar00rootroot00000000000000// --!! Toplevel struct typedefs typedef struct __POINT { int x; int y; } Point; typedef Point* PPoint; typedef PPoint* PPPoint; // Same shape and tag, different type name. typedef struct POINTa { int ax; int ay; } Point1; camlidl-camlidl109/tests/hdirect/test004.idl000066400000000000000000000002231366176261100210070ustar00rootroot00000000000000// !! Basic interface definition [object] interface IFoo { void f([in] int x); } [object] interface IBar : IFoo { void g([in] int x); } camlidl-camlidl109/tests/hdirect/test005.idl000066400000000000000000000011421366176261100210110ustar00rootroot00000000000000//!! The IUnknown interface // definitions to make it self contained. typedef unsigned long DWORD; typedef unsigned short WORD; typedef unsigned char BYTE; typedef struct _GUID { DWORD Data1; WORD Data2; WORD Data3; BYTE Data4[8]; } GUID; typedef GUID IID; typedef IID *REFIID; typedef int HRESULT; typedef unsigned long ULONG; [ local, object, uuid(00000000-0000-0000-C000-000000000046), pointer_default(unique) ] interface IUnknown { HRESULT QueryInterface( [in] REFIID riid, [out, iid_is(riid)] void **ppvObject); ULONG AddRef(); ULONG Release(); } camlidl-camlidl109/tests/hdirect/test006.idl000066400000000000000000000020551366176261100210160ustar00rootroot00000000000000//!! The IClassFactory interface // definitions to make it self contained. typedef int BOOL; typedef unsigned long DWORD; typedef unsigned short WORD; typedef unsigned char BYTE; typedef struct _GUID { DWORD Data1; WORD Data2; WORD Data3; BYTE Data4[8]; } GUID; typedef GUID IID; typedef IID *REFIID; typedef int HRESULT; //Cheat to avoid having to an `import' of the //the IUnknown interface. typedef char *IUnknown; [ object, uuid(00000001-0000-0000-C000-000000000046), pointer_default(unique) ] interface IClassFactory //: IUnknown { typedef [unique] IClassFactory * LPCLASSFACTORY; [local] HRESULT CreateInstance( [in, unique] IUnknown * pUnkOuter, [in] REFIID riid, [out, iid_is(riid)] void **ppvObject); [call_as(CreateInstance)] HRESULT RemoteCreateInstance( [in] REFIID riid, [out, iid_is(riid)] IUnknown ** ppvObject); [local] HRESULT LockServer( [in] BOOL fLock); [call_as(LockServer)] HRESULT __stdcall RemoteLockServer( [in] BOOL fLock); } camlidl-camlidl109/tests/hdirect/test007.idl000066400000000000000000000001021366176261100210060ustar00rootroot00000000000000//!! Enumerations typedef enum _rgb { red,green=2,blue=-1 } rgb; camlidl-camlidl109/tests/hdirect/test008.idl000066400000000000000000000000721366176261100210150ustar00rootroot00000000000000//!! Generating code for pointers typedef [ref]int* foo; camlidl-camlidl109/tests/hdirect/test009.idl000066400000000000000000000000771366176261100210230ustar00rootroot00000000000000interface IFoo { int foo([in]int x,[in,out,unique]int* y); } camlidl-camlidl109/tests/hdirect/test010.idl000066400000000000000000000003121366176261100210030ustar00rootroot00000000000000 [ uuid(00000000-0000-0000-C000-000000000046), pointer_default(unique) ] interface IFoo { typedef struct _S1_TYPE { unsigned int f1; double d2; } S1_TYPE; void f([in]S1_TYPE x); } camlidl-camlidl109/tests/hdirect/test011.idl000066400000000000000000000004171366176261100210120ustar00rootroot00000000000000 [ uuid(00000000-0000-0000-C000-000000000046), pointer_default(unique) ] interface IFoo { typedef struct _S1_TYPE { unsigned int f; unsigned int g; [size_is(f)]double* d2; [size_is(g)]double* d3; } S1_TYPE; void f([in]S1_TYPE x); } camlidl-camlidl109/tests/hdirect/test012.idl000066400000000000000000000002051366176261100210060ustar00rootroot00000000000000//!!! Testing enumeration references enum _rgb { red,green=0,blue=-1 }; typedef enum _rgb rgb2,rgb3; typedef [v1_enum]enum _rgb rgb; camlidl-camlidl109/tests/hdirect/test013.idl000066400000000000000000000003421366176261100210110ustar00rootroot00000000000000//!!! Testing enumeration references typedef struct _pt pt5; typedef struct _pt { int data,x; } pt1; typedef pt1 pt2,*pt3,*pt4; typedef struct _pt pt6; typedef struct _p { int data1; } foo; typedef int bar; typedef int _bar; camlidl-camlidl109/tests/hdirect/test014.idl000066400000000000000000000003771366176261100210220ustar00rootroot00000000000000//!!! Testing dependent arguments [uuid(00020405-0000-0000-C000-000000000046)] interface IFoo { int f([in,out] int* len, [in] char foo, [out] double *d, [in, out, size_is(,*len)] char** str); void negate([in, out, string] char* x); } camlidl-camlidl109/tests/hdirect/test015.idl000066400000000000000000000001541366176261100210140ustar00rootroot00000000000000//!!! Testing dependent arguments typedef struct _tag { int x; int y; struct { int z;} a; } pt3; camlidl-camlidl109/tests/hdirect/test016.idl000066400000000000000000000003201366176261100210100ustar00rootroot00000000000000//!!! Testing dependent arguments [object,pointer_default(unique),uuid(D3980A60-910C-1068-9341-00DD010F2F1C)] interface IFoo /*: IBar*/ { void Bar( [out]int *len , [out,size_is(,*len)]char** ps); } camlidl-camlidl109/tests/hdirect/test017.idl000066400000000000000000000003351366176261100210170ustar00rootroot00000000000000 typedef struct tagPALETTEENTRY { int peRed; int peGreen; int peBlue; int peFlags; } PALETTEENTRY, *PPALETTEENTRY, *LPPALETTEENTRY; typedef struct foo { int x,y; } Bar, Pbar; camlidl-camlidl109/tests/hdirect/test018.idl000066400000000000000000000001451366176261100210170ustar00rootroot00000000000000typedef struct tagPALETTEENTRY { int x; [size_is(x)]int foo[]; } PALETTEENTRY; camlidl-camlidl109/tests/hdirect/test019.idl000066400000000000000000000003371366176261100210230ustar00rootroot00000000000000//!!! testing precedences + constant size array marshalling. typedef struct tagPALETTEENTRY { [ref**]int* foo[34][42]; [unique**]int* bar[34][42]; [ptr**]int* baz[34][42]; } PALETTEENTRY; camlidl-camlidl109/tests/hdirect/test020.idl000066400000000000000000000003461366176261100210130ustar00rootroot00000000000000//!!! testing precedences + constant size array marshalling. [object, uuid(00020405-0000-0000-C000-000000000046), pointer_default(unique)] interface IBoo : IUnknown { IBoo* meth([in]int* Len, [in,string]char* str ); } camlidl-camlidl109/tests/hdirect/test021.idl000066400000000000000000000002161366176261100210100ustar00rootroot00000000000000 [pointer_default(unique)] interface foo { typedef [ptr]int* boz; typedef [unique]boz* baz; void bar([out]int* x, [out]baz* y); } camlidl-camlidl109/tests/hdirect/test022.idl000066400000000000000000000005501366176261100210120ustar00rootroot00000000000000///!!! checking the assignment of pointer attributes // !!! in struct declarations. interface foo { const int x = (1>=2) ? 2 : 1; typedef [ptr]int* baz; typedef struct _foo { int* p1; // default is unique [ptr]int* p2; // ptr [unique]int* p3; // unique [ref]int* p4; // ref baz p5; // ptr [ref]baz p6; // ref } bar; } camlidl-camlidl109/tests/hdirect/test023.idl000066400000000000000000000001121366176261100210050ustar00rootroot00000000000000 typedef struct _pt { int x; int y; } point; typedef point* ppoint; camlidl-camlidl109/tests/hdirect/test024.idl000066400000000000000000000001741366176261100210160ustar00rootroot00000000000000 import "test023.idl"; interface foo { typedef struct _cp { [ref]struct _pt* p; int col; } ColourPoint; } camlidl-camlidl109/tests/hdirect/test025.idl000066400000000000000000000002511366176261100210130ustar00rootroot00000000000000//!!! Array parameters interface IFoo { void foo([in]char str[80]); void foz([in]char str[80][40]); void bar([in,out]char str[80]); void baz([out]char **str); } camlidl-camlidl109/tests/hdirect/test026.idl000066400000000000000000000003621366176261100210170ustar00rootroot00000000000000//!! Dependent parameters interface Test { void foo( [in]int len , [in,size_is(len)]char* str); void foz( [in]int len , [in,size_is(len,len)]char** str); void faz( [in,ref]int *len , [in,size_is(*len,*len)]char** str); } camlidl-camlidl109/tests/hdirect/test027.idl000066400000000000000000000003221366176261100210140ustar00rootroot00000000000000//!! More dependent parameter tests interface Test { void foo( [out]int* len , [out]char** str); void fob( [out]int* len , [in]int l , [in,out,size_is(,*len)]char** str , [in]int l1 ); } camlidl-camlidl109/tests/hdirect/test028.idl000066400000000000000000000011301366176261100210130ustar00rootroot00000000000000//!!! example taken from DCOM mailing list posting //!!! by Erik Westlin interface IFoo { const short MAX_ADB_PARAM_INDEX=2048; const short ADB_NAME_LENGTH=14; typedef char param_name_t[ADB_NAME_LENGTH]; const short _maxcount_names=ADB_NAME_LENGTH; typedef char ADB_STATUS; int ADB_convert_index( [in]long name_count, [in,size_is(name_count)]short* indexes, [out,size_is(name_count)]param_name_t names[], [out,size_is(name_count)]ADB_STATUS status_tab[] ); } camlidl-camlidl109/tests/hdirect/test029.idl000066400000000000000000000004151366176261100210210ustar00rootroot00000000000000//!! More dependent parameter tests interface Test { void count([out] long* sizeArray); void arrayIn( [in]long sizeIn, [in, size_is(sizeIn)]long aIn[]); void arrayOut( [in, out]long* psizeOut, [out, size_is(*psizeOut)] long aOut[]); } camlidl-camlidl109/tests/hdirect/test030.idl000066400000000000000000000002151366176261100210070ustar00rootroot00000000000000//!! Enumerations with expressions on RHS interface Test { const int int_size=4; typedef enum _foo { a = int_size, b = 1 } bar; } camlidl-camlidl109/tests/hdirect/test031.idl000066400000000000000000000003321366176261100210100ustar00rootroot00000000000000//!! Array of strings interface Test { typedef [string]char* LPSTR; typedef struct tagCALPSTR { unsigned long cElems; [size_is( cElems )]LPSTR* pElems; } CALPSTR; } camlidl-camlidl109/tests/hdirect/test032.idl000066400000000000000000000002161366176261100210120ustar00rootroot00000000000000//!! Forward type references interface Test { typedef [unique] struct _wireVARIANT * wireVARIANT; struct _wireVARIANT { int i; int j; }; } camlidl-camlidl109/tests/hdirect/test033.idl000066400000000000000000000016611366176261100210200ustar00rootroot00000000000000//!! Forward type references quote(C, "enum { VT_I4, VT_UI1, VT_R4, VT_R8, VT_BOOL, VT_BSTR, VT_I4_BYREF, VT_UI1_BYREF, VT_R4_BYREF, VT_R8_BYREF, VT_BOOL_BYREF, VT_BSTR_BYREF }; ") interface Test { // A cut-down version of the VARIANT type // defined by the Ole Automation interfaces. typedef [string] char * BSTR; typedef struct tagVARIANT VARIANT; struct tagVARIANT { unsigned int vt; [switch_is(vt)] union { case VT_I4: long lVal; case VT_UI1: unsigned char bVal; case VT_R4: float fltVal; case VT_R8: double dblVal; case VT_BOOL: boolean bool; case VT_BSTR: BSTR bstrVal; case VT_I4_BYREF: long * plVal; case VT_UI1_BYREF: unsigned char * pbVal; case VT_R4_BYREF: float * pfltVal; case VT_R8_BYREF: double * pdblVal; case VT_BOOL_BYREF: boolean * pbool; case VT_BSTR_BYREF: BSTR * pbstrVal; } u; }; } camlidl-camlidl109/tests/hdirect/test034.idl000066400000000000000000000034071366176261100210210ustar00rootroot00000000000000//!! Toplevel enum declarations [ uuid(A3980A60-910C-1068-9341-00DD010F2F1C), version(0.1), pointer_default(unique) ] interface ITest { enum VARENUM { VT_EMPTY = 0, VT_NULL = 1, VT_I2 = 2, VT_I4 = 3, VT_R4 = 4, VT_R8 = 5, VT_CY = 6, VT_DATE = 7, VT_BSTR = 8, VT_DISPATCH = 9, VT_ERROR = 10, VT_BOOL = 11, VT_VARIANT = 12, VT_UNKNOWN = 13, VT_DECIMAL = 14, VT_I1 = 16, VT_UI1 = 17, VT_UI2 = 18, VT_UI4 = 19, VT_I8 = 20, VT_UI8 = 21, VT_INT = 22, VT_UINT = 23, VT_VOID = 24, VT_HRESULT = 25, VT_PTR = 26, VT_SAFEARRAY = 27, VT_CARRAY = 28, VT_USERDEFINED = 29, VT_LPSTR = 30, VT_LPWSTR = 31, VT_FILETIME = 64, VT_BLOB = 65, VT_STREAM = 66, VT_STORAGE = 67, VT_STREAMED_OBJECT = 68, VT_STORED_OBJECT = 69, VT_BLOB_OBJECT = 70, VT_CF = 71, VT_CLSID = 72, VT_BSTR_BLOB = 0x0fff, VT_VECTOR = 0x1000, VT_ARRAY = 0x2000, VT_BYREF = 0x4000, VT_RESERVED = 0x8000, VT_ILLEGAL = 0xffff, VT_ILLEGALMASKED = 0x0fff, VT_TYPEMASK = 0x0fff }; typedef struct _silly { [unique]char* c;} vs; typedef struct _pt { char a; double x; [unique] char* z; [unique] vs* v; } pt, *ppt; void foo ([in,unique] int* a, [in,unique]pt* x); } camlidl-camlidl109/tests/hdirect/test035.idl000066400000000000000000000001711366176261100210150ustar00rootroot00000000000000interface ITest { typedef int* pInt; void foo([in]pInt x,[out]pInt y); typedef struct _bar { int a; pInt y; } baz; } camlidl-camlidl109/tests/imports.idl000066400000000000000000000004431366176261100176630ustar00rootroot00000000000000/* Test import statements */ import "structs.idl"; import "unix.idl"; int bar1([in] struct s1 * s); void bar2([out] struct s1 * s); int openfile([in,string] char * name, [in,set] enum open_flags flags, [in] int perms) {| _res = open(name, flags, perms); |}; camlidl-camlidl109/tests/multi_import.idl000066400000000000000000000001501366176261100207050ustar00rootroot00000000000000import "structs.idl", "typedefs.idl"; interface test { const char *SOME_CONSTANT = "this is a test"; } camlidl-camlidl109/tests/stdint.idl000066400000000000000000000012211366176261100174660ustar00rootroot00000000000000interface foo { struct bar { int8 small_ish; /* */ uint8 usmall_ish; /* */ int16 short_ish; /* */ uint16 ushort_ish; /* */ int32 long_ish; /* */ uint32 ulong_ish; /* */ int64 llong_ish; /* */ uint64 ullong_ish; /* */ __int64 llong_compat; /* non-standard */ signed __int64 llong2_compat; /* non-standard */ unsigned __int64 ullong_compat; /* non-standard */ }; } camlidl-camlidl109/tests/structs.idl000066400000000000000000000017571366176261100177060ustar00rootroot00000000000000/* Structs, unions and typedefs */ struct s1 { int x; double d; float f; long l[3]; }; int foo0([in] struct s1 s); int foo1([in] struct s1 * s); void foo2([out] struct s1 * s); typedef struct { int x; struct { int y; int z; } t; double d; } t; int foo3([in] t * s); struct s2 { int n; [size_is(n)] long l[]; }; int foo4([in] struct s2 * s); void foo5([out] struct s2 * s); struct s4 { float x, y, z; }; int foo6([in] struct s4 * s); void foo7([out] struct s4 * s); // Forward declarations struct s5; struct s6 { int info; [unique] struct s5 * next; }; struct s5 { int count; [unique] struct s6 * data; }; // Unions enum switchtype { FLOAT_ARRAY = 1, DOUBLE_ARRAY = 2, OTHER = 3 }; struct su1 { int len; enum switchtype type; [switch_is(type)] union { case FLOAT_ARRAY: [size_is(len)] float* fl; case DOUBLE_ARRAY: [size_is(len)] double* db; case OTHER: struct { int len2; [size_is(len2)] int* c; } i; } data; }; camlidl-camlidl109/tests/testcomponent.ml000066400000000000000000000034771366176261100207420ustar00rootroot00000000000000(* Test the Com component *) let test_ix c = print_string "Testing IX interface..."; print_newline(); print_string "Calling f 10"; print_newline(); c#f 10 let test_iy c = print_string "Testing IY interface..."; print_newline(); print_string "Calling g 2"; print_newline(); let n = c#g 2 in print_string "Result is "; print_int n; print_newline(); print_string "Calling h"; print_newline(); let n = c#h in print_string "Result is "; print_string (if n then "true" else "false"); print_newline(); print_string "Calling k"; print_newline(); let n = c#k in print_string "Result is "; print_string n; print_newline() class my_ix = object method f x = print_string "my_ix: f "; print_int x; print_newline() end class my_iy = object method g x = print_string "my_iy: g "; print_int x; print_newline(); let res = x / 2 in print_string "my_iy: g returns "; print_int res; print_newline(); res method h = print_string "my_iy: h returns true"; print_newline(); true method k = print_string "my_iy: k returns `hello'"; print_newline(); "hello" end let make_test() = let c = Component.create_instance() in begin try test_ix (Component.use_iX (Com.query_interface c Component.iid_iX)) with Com.Error(_, _, s) -> print_string "Lookup of IX interface failed: "; print_string s; print_newline() end; begin try test_iy (Component.use_iY (Com.query_interface c Component.iid_iY)) with Com.Error(_, _, s) -> print_string "Lookup of IY interface failed: "; print_string s; print_newline() end; let cx = Component.make_iX (new my_ix) and cy = Component.make_iY (new my_iy) in Component.test_ix cx; Component.test_iy cy; Component.test_component(Com.iUnknown_of(Com.combine cx cy)) let _ = make_test(); Gc.full_major() camlidl-camlidl109/tests/typedefs.idl000066400000000000000000000004621366176261100200120ustar00rootroot00000000000000/* Typedefs */ typedef int t0; typedef [abstract] int t1; typedef [abstract,finalize(t2_final),compare(t2_compare)] int t2; typedef [abstract,ml2c(t3_ml2c),c2ml(t3_c2ml)] int t3; quote(C, "void t3_ml2c(value v, t3 * c) { *c = Int_val(v); }") quote(C, "value t3_c2ml(t3 * c) { return Val_int(*c); }") camlidl-camlidl109/tests/unix.idl000066400000000000000000000111641366176261100171530ustar00rootroot00000000000000/* Parts of the Unix library */ quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote(C,"#include ") quote (C, " /* Wrapping of return code for wait */ union process_status { int code; }; enum { WEXITED_, WSIGNALED_, WSTOPPED_ }; static void decode_status(int status, int * kind, union process_status * p) { if (WIFEXITED(status)) { *kind = WEXITED_; p->code = WEXITSTATUS(status); } else if (WIFSIGNALED(status)) { *kind = WSIGNALED_; p->code = WTERMSIG(status); } else { *kind = WSTOPPED_; p->code = WSTOPSIG(status); } } int read2(int fd, int len, int * rd, char * buf) { int retcode = read(fd, buf, len); if (retcode != -1) { *rd = retcode; retcode = 0; } return retcode; } typedef DIR * dir_handle; typedef struct dirent dirent; typedef fd_set * file_descr_set; extern char ** environ; ") [string*, null_terminated] char ** environment(void) quote(call, "_res = environ;"); [string] char * getenv([in,string] char * varname); void putenv([in,string] char * name_val); int execv([in,string] char * path, [in,null_terminated,string*] char ** argv); int execve([in,string] char * path, [in,null_terminated,string*] char ** argv, [in,null_terminated,string*] char ** env); int fork(void); union process_status { case WEXITED_: int code; case WSIGNALED_: int code; case WSTOPPED_: int code; }; int wait([out] int * kind, [out,switch_is(*kind)] union process_status * p) quote(call, " { int status; _res = wait(&status); if (_res != -1) decode_status(status, kind, p); }"); void system([in,string] char * cmd, [out] int * kind, [out,switch_is(*kind)] union process_status * p) quote(call, " { int ret = system(cmd); decode_status(ret, kind, p); } "); int getpid(void); int getppid(void); int nice(int pid); enum open_flags { O_RDONLY, O_WRONLY, O_RDWR, O_CREAT, O_EXCL, O_TRUNC, O_APPEND, O_NONBLOCK }; int openfile([in,string] char * name, [in,set] enum open_flags flags, [in] int perms) quote(call, " _res = open(name, flags, perms); "); int close([in] int fd); /* read in place */ int read([in] int fd, [in,string,size_is(len)] char * buf, [in] int len); /* read with copy */ void read2([in] int fd, [in] int len, [out] int *rd, [out,string,size_is(len),length_is(*rd)] char * buf) quote(call, " *rd = read(fd, buf, len); if (*rd == -1) caml_failwith(\"read2\"); "); /* write */ int write([in] int fd, [in,string,size_is(len)] char * buf, [in] int len); /* seeking */ enum seek_command { SEEK_SET, SEEK_CUR, SEEK_END }; int lseek(int fd, int ofs, enum seek_command cmd); int truncate([string] char * filename, int size); int ftruncate(int fd, int size); /* stats */ /* Note: the types given are not the C representation types, */ /* but just the conversion types. So it's OK to say st_dev is an int */ /* even if actually it's a short. We can even claim that st_?time */ /* are doubles while actually they are integers! */ struct stat { int st_dev, st_ino; int st_mode; int st_nlink; int st_uid, st_gid; int st_rdev; int st_size; long st_blksize, st_blocks; double st_atime, st_mtime, st_ctime; }; int stat([string] char * filename, [out] struct stat * st); int lstat([string] char * filename, [out] struct stat * st); int fstat(int fd, [out] struct stat * st); /* Operations on file names */ int unlink([string] char * filename); int rename([string] char * filename, [string] char * newname); int link([string] char * filename, [string] char * newname); /* Directories */ typedef [abstract,ptr] void * dir_handle; dir_handle opendir([string] char * filename) quote(call, " _res = opendir(filename); if (_res == NULL) caml_failwith(\"opendir\"); "); typedef struct { [string] char d_name[256]; // NAME_MAX in fact } dirent; [unique] dirent * readdir(dir_handle d); void rewinddir(dir_handle d); void closedir(dir_handle d); /* pipes */ int pipe([out] int fds[2]); /* select */ typedef [abstract] void * file_descr_set; void FD_ZERO(file_descr_set s); void FD_SET(int fd, file_descr_set s); void FD_CLR(int fd, file_descr_set s); boolean FD_ISSET(int fd, file_descr_set s); struct timeval { int tv_sec; int tv_usec; }; int select(int n, file_descr_set read, file_descr_set write, file_descr_set except, [unique] struct timeval * timeout); camlidl-camlidl109/tools/000077500000000000000000000000001366176261100154715ustar00rootroot00000000000000camlidl-camlidl109/tools/.cvsignore000066400000000000000000000000131366176261100174630ustar00rootroot00000000000000camlidldll camlidl-camlidl109/tools/Makefile000066400000000000000000000016241366176261100171340ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile,v 1.2 2000-08-19 11:05:00 xleroy Exp $ include ../config/Makefile include Makefile.$(OSTYPE) camlidl-camlidl109/tools/Makefile.unix000066400000000000000000000016021366176261100201120ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile.unix,v 1.2 2000-08-19 11:05:00 xleroy Exp $ all: install: clean: depend: camlidl-camlidl109/tools/Makefile.win32000066400000000000000000000022231366176261100200710ustar00rootroot00000000000000#*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: Makefile.win32,v 1.4 2001-06-21 13:17:19 xleroy Exp $ all: camlidldll camlidldll: camlidldll.tpl ../config/Makefile $(file >camlidldll.tmp,camllib='$(OCAMLLIB)') sed -e '/%%CAMLLIB%%/r camlidldll.tmp' camlidldll.tpl > camlidldll rm camlidldll.tmp install: cp camlidldll $(BINDIR) cp camlidlcompat.h $(OCAMLLIB)/caml clean: rm -f camlidldll depend: camlidl-camlidl109/tools/camlidlcompat.h000066400000000000000000000041631366176261100204570ustar00rootroot00000000000000/***********************************************************************/ /* */ /* CamlIDL */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id: camlidlcompat.h,v 1.4 2002-04-19 14:15:11 xleroy Exp $ */ /* Compatibility macros to share IDL source between CamlIDL and MIDL */ #ifdef CAMLIDL /* Define away MIDL-specific attributes */ #define local #define endpoint #define version(x) #define transmit_as(x) #define implicit_handle #define auto_handle #define callback /* Define away OLE/Automation attributes */ #define bindable #define custom(x,y) #define defaultbind #define defaultcollelem #define defaultvalue(x) #define displaybind #define dual #define helpcontext(x) #define helpstring(x) #define helpstringcontext(x) #define hidden #define id(x) #define immediatebind #define lcid #define nonbrowsable #define nonextensible #define odl #define oleautomation #define optional #define readonly #define replaceable #define requestedit #define restricted #define retval #define source #define uidefault #define usesgetlasterror #define vararg #else /* Define away CamlIDL-specific attributes */ #define abstract #define bigarray #define camlint #define compare(x) #define c2ml(x) #define errorcheck(x) #define errorcode #define finalize(x) #define fortran #define hash(x) #define int_default(x) #define int32 #define int64 #define long_default(x) #define managed #define ml2c(x) #define mlname(x) #define mltype(x) #define mlname(x) #define null_terminated #define set #endif camlidl-camlidl109/tools/camlidldll.tpl000066400000000000000000000060751366176261100203230ustar00rootroot00000000000000#!/bin/sh # This is a Bash script #*********************************************************************** #* * #* CamlIDL * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1999 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the GNU Library General Public License. * #* * #*********************************************************************** #* $Id: camlidldll.tpl,v 1.6 2002-04-22 11:50:47 xleroy Exp $ # Automates the creation of a DLL for a Caml component # camllib=%%CAMLLIB%% output=caml.dll linkopts='' camlopts='' linkobjs='' camlobjs='' camlnativeobjs='' camlobjfile="caml$$.obj" resourcefile="caml$$.rc" resfile='' tlbcounter=0 rm -f $resourcefile # Parse the command line while : ; do case "$1" in "") break;; # my options -o) output=$2; shift;; -linkopt) linkopts="$linkopts $2"; shift;; # ocamlc options -cc|-ccopt|-I|-w) camlopts="$camlopts $1 $2"; shift;; -cclib) lib=`echo $2 | sed -e 's/^-l\(.*\)$/lib\1.lib/'` linkobjs="$linkobjs $lib" shift;; -linkall|-verbose) camlopts="$camlopts $1";; # other options -*) echo "Unknown option \"$1\", ignored" 1>&2;; # files *.cm[oa]) camlobjs="$camlobjs $1";; *.cmx|*.cmxa) camlnativeobjs="$camlnativeobjs $1";; *.obj|*.lib) linkobjs="$linkobjs $1";; *.tlb) tlbcounter=`expr $tlbcounter + 1` echo "$tlbcounter typelib $1" >> $resourcefile;; *) echo "Don't know what to do with \"$1\", ignored" 1>&2;; esac shift done if test -n "$camlobjs" -a -n "$camlnativeobjs"; then echo "Both bytecode object files and native object files given, cannot proceed" 1>&2 exit 2 fi if test $tlbcounter -ne 0; then echo "1 num_typelibs { $tlbcounter }" >> $resourcefile resfile="caml$$.res" rc /fo$resfile $resourcefile || { exit $?; } rm -f $resourcefile fi if test -z "$camlnativeobjs"; then ocamlc -custom -output-obj -o $camlobjfile $camlopts com.cma $camlobjs exitcode=$? runtimelib=libcamlrun.lib else ocamlopt -output-obj -o $camlobjfile $camlopts com.cmxa $camlnativeobjs exitcode=$? runtimelib=libasmrun.lib fi if test "$exitcode" -eq 0; then link /nologo /incremental:no /dll /machine:ix86 \ /out:${output} /libpath:$camllib \ /export:DllGetClassObject,PRIVATE \ /export:DllCanUnloadNow,PRIVATE \ /export:DllRegisterServer,PRIVATE \ /export:DllUnregisterServer,PRIVATE \ $resfile \ $linkopts $camlobjfile $linkobjs \ ${camllib}\\cfactory.obj libcamlidl.lib \ $runtimelib \ advapi32.lib ole32.lib oleaut32.lib exitcode=$? fi rm -f $resfile $camlobjfile exit $exitcode