camlidl-1.05/0040755004340400512160000000000010074761075012630 5ustar xleroycristalcamlidl-1.05/.cvsignore0100644004340400512160000000000506663273351014624 0ustar xleroycristalcaml camlidl-1.05/Changes0100644004340400512160000000636410073230342014114 0ustar xleroycristalCamlIDL 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-1.05/LICENSE0100644004340400512160000007545407460023636013650 0ustar xleroycristalAll files marked "Copyright Institut National de Recherche en Informatique et en Automatique" in the "compiler" directory are distributed under the terms of the Q Public License version 1.0 (included below). All other files marked "Copyright Institut National de Recherche en Informatique et en Automatique" are distributed under the terms of the GNU Library General Public License version 2 (included below). These files are collectively referred as "the Library" in the following. As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by INRIA, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ---------------------------------------------------------------------- THE Q PUBLIC LICENSE version 1.0 Copyright (C) 1999 Troll Tech AS, Norway. Everyone is permitted to copy and distribute this license document. The intent of this license is to establish freedom to share and change the software regulated by this license under the open source model. This license applies to any software containing a notice placed by the copyright holder saying that it may be distributed under the terms of the Q Public License version 1.0. Such software is herein referred to as the Software. This license covers modification and distribution of the Software, use of third-party application programs based on the Software, and development of free software which uses the Software. Granted Rights 1. You are granted the non-exclusive rights set forth in this license provided you agree to and comply with any and all conditions in this license. Whole or partial distribution of the Software, or software items that link with the Software, in any form signifies acceptance of this license. 2. You may copy and distribute the Software in unmodified form provided that the entire package, including - but not restricted to - copyright, trademark notices and disclaimers, as released by the initial developer of the Software, is distributed. 3. You may make modifications to the Software and distribute your modifications, in a form that is separate from the Software, such as patches. The following restrictions apply to modifications: a. Modifications must not alter or remove any copyright notices in the Software. b. When modifications to the Software are released under this license, a non-exclusive royalty-free right is granted to the initial developer of the Software to distribute your modification in future versions of the Software provided such versions remain available under these terms in addition to any other license(s) of the initial developer. 4. You may distribute machine-executable forms of the Software or machine-executable forms of modified versions of the Software, provided that you meet these restrictions: a. You must include this license document in the distribution. b. You must ensure that all recipients of the machine-executable forms are also able to receive the complete machine-readable source code to the distributed Software, including all modifications, without any charge beyond the costs of data transfer, and place prominent notices in the distribution explaining this. c. You must ensure that all modifications included in the machine-executable forms are available under the terms of this license. 5. You may use the original or modified versions of the Software to compile, link and run application programs legally developed by you or by others. 6. You may develop application programs, reusable components and other software items that link with the original or modified versions of the Software. These items, when distributed, are subject to the following requirements: a. You must ensure that all recipients of machine-executable forms of these items are also able to receive and use the complete machine-readable source code to the items without any charge beyond the costs of data transfer. b. You must explicitly license all recipients of your items to use and re-distribute original and modified versions of the items in both machine-executable and source code forms. The recipients must be able to do so without any charges whatsoever, and they must be able to re-distribute to anyone they choose. c. If the items are not available to the general public, and the initial developer of the Software requests a copy of the items, then you must supply one. Limitations of Liability In no event shall the initial developers or copyright holders be liable for any damages whatsoever, including - but not restricted to - lost revenue or profits or other direct, indirect, special, incidental or consequential damages, even if they have been advised of the possibility of such damages, except to the extent invariable law, if any, provides otherwise. No Warranty The Software and this license document are provided AS IS with NO WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. Choice of Law This license is governed by the Laws of France. Disputes shall be settled by the Court of Versailles. ---------------------------------------------------------------------- GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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 library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] 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 Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, 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 or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the 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 a program 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. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. 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, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library 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 compile 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) 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. c) 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. d) 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 source code 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 to 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 Library 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 Appendix: 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. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 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 Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! camlidl-1.05/Makefile0100644004340400512160000000247007147464727014303 0ustar xleroycristal#*********************************************************************** #* * #* 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-1.05/README0100644004340400512160000000357710073236163013513 0ustar xleroycristalOVERVIEW: Camlidl is a stub code generator for Objective Caml. It generates stub code for interfacing Caml with C from an IDL description of the C functions. Thus, Camlidl automates the most tedious task in interfacing C libraries with Caml programs. It can also be used to interface Caml programs with other languages, as long as those languages have a well-defined C interface. In addition, Camlidl provides basic support for COM interfaces and components under MS Windows. It supports both using COM components (usually written in C++ or C) from Caml programs, and packaging Caml objects as COM components that can then be used from C++ or C. COPYRIGHT: All files marked "Copyright INRIA" in this distribution are copyright 1999, 2000, 2001, 2002, 2003, 2004 Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the conditions stated in file LICENSE. REQUIREMENTS: Camlidl requires Objective Caml 3.08 or later. This version will not work with earlier releases of Objective Caml. Under MS Windows, you must use the MSVC port of Objective Caml. Microsoft's Visual C++ 6.0 is required, as well as the Cygnus CYGWIN32 tools (http://sourceware.cygnus.com/cygwin/). INSTALLATION: - Under Unix, copy config/Makefile.unix to config/Makefile. Under Windows, copy config/Makefile.win32 to config/Makefile. - Edit config/Makefile to set configuration options, following the comments in that file. You must set the OCAMLLIB and BINDIR variables to reflect the location of your OCaml installation. Other variables have reasonable defaults. - Do "make all". - Become super-user if necessary and do "make install". DOCUMENTATION: - The doc/ subdirectory contains the user's manual in HTML and in Postscript. - Several examples are provided in the directories tests/ and tests/comp/. SUPPORT: - Please send bug reports and comments to caml@inria.fr camlidl-1.05/compiler/0040755004340400512160000000000010074760723014441 5ustar xleroycristalcamlidl-1.05/compiler/.cvsignore0100644004340400512160000000013506663273351016442 0ustar xleroycristalcamlidl config.ml parser_midl.output parser_midl.ml parser_midl.mli lexer_midl.ml linenum.ml camlidl-1.05/compiler/.depend0100644004340400512160000001326607421245350015702 0ustar xleroycristalarray.cmi: idltypes.cmi prefix.cmi constdecl.cmi: idltypes.cmi cvttyp.cmi: idltypes.cmi cvtval.cmi: idltypes.cmi prefix.cmi enumdecl.cmi: idltypes.cmi enum.cmi: idltypes.cmi file.cmi: constdecl.cmi funct.cmi idltypes.cmi intf.cmi typedef.cmi fixlabels.cmi: file.cmi funct.cmi: idltypes.cmi intf.cmi: funct.cmi idltypes.cmi lexer_midl.cmi: parser_midl.cmi lexpr.cmi: idltypes.cmi normalize.cmi: file.cmi parse_aux.cmi: file.cmi funct.cmi idltypes.cmi typedef.cmi parse.cmi: file.cmi parser_midl.cmi: file.cmi predef.cmi: intf.cmi typedef.cmi prefix.cmi: idltypes.cmi structdecl.cmi: idltypes.cmi struct.cmi: idltypes.cmi prefix.cmi typedef.cmi: idltypes.cmi uniondecl.cmi: idltypes.cmi union.cmi: idltypes.cmi prefix.cmi variables.cmi: idltypes.cmi array.cmo: cvttyp.cmi idltypes.cmi lexpr.cmi utils.cmi variables.cmi \ array.cmi array.cmx: cvttyp.cmx idltypes.cmi lexpr.cmx utils.cmx variables.cmx \ array.cmi clflags.cmo: config.cmi clflags.cmx: config.cmx config.cmo: config.cmi config.cmx: config.cmi constdecl.cmo: cvttyp.cmi idltypes.cmi lexpr.cmi utils.cmi constdecl.cmi constdecl.cmx: cvttyp.cmx idltypes.cmi lexpr.cmx utils.cmx constdecl.cmi cvttyp.cmo: config.cmi idltypes.cmi lexpr.cmi utils.cmi cvttyp.cmi cvttyp.cmx: config.cmx idltypes.cmi lexpr.cmx utils.cmx cvttyp.cmi cvtval.cmo: array.cmi cvttyp.cmi enum.cmi idltypes.cmi lexpr.cmi struct.cmi \ union.cmi utils.cmi variables.cmi cvtval.cmi cvtval.cmx: array.cmx cvttyp.cmx enum.cmx idltypes.cmi lexpr.cmx struct.cmx \ union.cmx utils.cmx variables.cmx cvtval.cmi enumdecl.cmo: cvttyp.cmi cvtval.cmi enum.cmi idltypes.cmi utils.cmi \ variables.cmi enumdecl.cmi enumdecl.cmx: cvttyp.cmx cvtval.cmx enum.cmx idltypes.cmi utils.cmx \ variables.cmx enumdecl.cmi enum.cmo: idltypes.cmi utils.cmi variables.cmi enum.cmi enum.cmx: idltypes.cmi utils.cmx variables.cmx enum.cmi file.cmo: clflags.cmo constdecl.cmi enumdecl.cmi funct.cmi idltypes.cmi \ intf.cmi structdecl.cmi typedef.cmi uniondecl.cmi utils.cmi file.cmi file.cmx: clflags.cmx constdecl.cmx enumdecl.cmx funct.cmx idltypes.cmi \ intf.cmx structdecl.cmx typedef.cmx uniondecl.cmx utils.cmx file.cmi fixlabels.cmo: clflags.cmo file.cmi funct.cmi idltypes.cmi intf.cmi \ typedef.cmi utils.cmi fixlabels.cmi fixlabels.cmx: clflags.cmx file.cmx funct.cmx idltypes.cmi intf.cmx \ typedef.cmx utils.cmx fixlabels.cmi funct.cmo: cvttyp.cmi cvtval.cmi idltypes.cmi lexpr.cmi prefix.cmi \ typedef.cmi utils.cmi variables.cmi funct.cmi funct.cmx: cvttyp.cmx cvtval.cmx idltypes.cmi lexpr.cmx prefix.cmx \ typedef.cmx utils.cmx variables.cmx funct.cmi intf.cmo: cvttyp.cmi cvtval.cmi funct.cmi idltypes.cmi prefix.cmi utils.cmi \ variables.cmi intf.cmi intf.cmx: cvttyp.cmx cvtval.cmx funct.cmx idltypes.cmi prefix.cmx utils.cmx \ variables.cmx intf.cmi lexer_midl.cmo: parse_aux.cmi parser_midl.cmi utils.cmi lexer_midl.cmi lexer_midl.cmx: parse_aux.cmx parser_midl.cmx utils.cmx lexer_midl.cmi lexpr.cmo: config.cmi idltypes.cmi prefix.cmi utils.cmi lexpr.cmi lexpr.cmx: config.cmx idltypes.cmi prefix.cmx utils.cmx lexpr.cmi linenum.cmo: linenum.cmi linenum.cmx: linenum.cmi main.cmo: clflags.cmo file.cmi idltypes.cmi normalize.cmi utils.cmi main.cmx: clflags.cmx file.cmx idltypes.cmi normalize.cmx utils.cmx normalize.cmo: constdecl.cmi cvttyp.cmi file.cmi fixlabels.cmi funct.cmi \ idltypes.cmi intf.cmi parse.cmi predef.cmi typedef.cmi utils.cmi \ normalize.cmi normalize.cmx: constdecl.cmx cvttyp.cmx file.cmx fixlabels.cmx funct.cmx \ idltypes.cmi intf.cmx parse.cmx predef.cmx typedef.cmx utils.cmx \ normalize.cmi parse_aux.cmo: constdecl.cmi cvttyp.cmi file.cmi funct.cmi idltypes.cmi \ intf.cmi linenum.cmi predef.cmi typedef.cmi parse_aux.cmi parse_aux.cmx: constdecl.cmx cvttyp.cmx file.cmx funct.cmx idltypes.cmi \ intf.cmx linenum.cmx predef.cmx typedef.cmx parse_aux.cmi parse.cmo: clflags.cmo lexer_midl.cmi linenum.cmi parse_aux.cmi \ parser_midl.cmi utils.cmi parse.cmi parse.cmx: clflags.cmx lexer_midl.cmx linenum.cmx parse_aux.cmx \ parser_midl.cmx utils.cmx parse.cmi parser_midl.cmo: constdecl.cmi cvttyp.cmi file.cmi funct.cmi idltypes.cmi \ intf.cmi parse_aux.cmi typedef.cmi parser_midl.cmi parser_midl.cmx: constdecl.cmx cvttyp.cmx file.cmx funct.cmx idltypes.cmi \ intf.cmx parse_aux.cmx typedef.cmx parser_midl.cmi predef.cmo: idltypes.cmi intf.cmi typedef.cmi predef.cmi predef.cmx: idltypes.cmi intf.cmx typedef.cmx predef.cmi prefix.cmo: idltypes.cmi utils.cmi prefix.cmi prefix.cmx: idltypes.cmi utils.cmx prefix.cmi structdecl.cmo: cvttyp.cmi cvtval.cmi idltypes.cmi prefix.cmi struct.cmi \ utils.cmi variables.cmi structdecl.cmi structdecl.cmx: cvttyp.cmx cvtval.cmx idltypes.cmi prefix.cmx struct.cmx \ utils.cmx variables.cmx structdecl.cmi struct.cmo: cvttyp.cmi idltypes.cmi lexpr.cmi prefix.cmi utils.cmi \ variables.cmi struct.cmi struct.cmx: cvttyp.cmx idltypes.cmi lexpr.cmx prefix.cmx utils.cmx \ variables.cmx struct.cmi typedef.cmo: cvttyp.cmi cvtval.cmi idltypes.cmi prefix.cmi utils.cmi \ variables.cmi typedef.cmi typedef.cmx: cvttyp.cmx cvtval.cmx idltypes.cmi prefix.cmx utils.cmx \ variables.cmx typedef.cmi uniondecl.cmo: cvttyp.cmi cvtval.cmi idltypes.cmi prefix.cmi union.cmi \ utils.cmi variables.cmi uniondecl.cmi uniondecl.cmx: cvttyp.cmx cvtval.cmx idltypes.cmi prefix.cmx union.cmx \ utils.cmx variables.cmx uniondecl.cmi union.cmo: cvttyp.cmi idltypes.cmi utils.cmi variables.cmi union.cmi union.cmx: cvttyp.cmx idltypes.cmi utils.cmx variables.cmx union.cmi utils.cmo: utils.cmi utils.cmx: utils.cmi variables.cmo: cvttyp.cmi idltypes.cmi utils.cmi variables.cmi variables.cmx: cvttyp.cmx idltypes.cmi utils.cmx variables.cmi camlidl-1.05/compiler/Makefile0100644004340400512160000000434207421245350016075 0ustar xleroycristal#*********************************************************************** #* * #* 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 \ array.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-1.05/compiler/array.ml0100644004340400512160000002235607421245350016112 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 (* 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 (string_length(%s) >= %d) invalid_argument(\"%s\");\n" v (Lexpr.eval_int n) !current_function; iprintf oc "strcpy(%s, String_val(%s));\n" c v end; begin match attr.size with None -> () | Some re -> iprintf oc "%a = string_length(%s);\n" Lexpr.output (pref, re) v end end else begin (* Determine actual size of ML array *) let size = new_c_variable (Type_named("", "mlsize_t")) in if is_float_type ty_elt then iprintf oc "%s = Wosize_val(%s) / Double_wosize;\n" size v else iprintf oc "%s = Wosize_val(%s);\n" size v; begin match attr.bound with None -> (* Allocate C array of same size as ML array *) iprintf oc "%s = camlidl_malloc(" c; if attr.null_terminated then fprintf oc "(%s + 1)" size else fprintf oc "%s" size; fprintf oc " * sizeof(%a), _ctx);\n" out_c_type ty_elt; need_context := true; | Some n -> (* Check compatibility of actual size w.r.t. expected size *) iprintf oc "if (%s %s %d) invalid_argument(\"%s\");\n" (if attr.null_terminated then size ^ " + 1" else size) (if attr.size = None && not attr.null_terminated then "!=" else ">") (Lexpr.eval_int n) !current_function end; (* Copy the array elements *) let idx = new_c_variable (Type_named("", "mlsize_t")) in begin match attr with {bound = Some n; size = None} -> iprintf oc "for (%s = 0; %s < %d; %s++) {\n" idx idx (Lexpr.eval_int n) idx | _ -> iprintf oc "for (%s = 0; %s < %s; %s++) {\n" idx idx size idx end; increase_indent(); if is_float_type ty_elt then iprintf oc "%s[%s] = Double_field(%s, %s);\n" c idx v idx else begin let v' = new_ml_variable() in iprintf oc "%s = Field(%s, %s);\n" v' v idx; ml_to_c oc onstack pref ty_elt v' (sprintf "%s[%s]" c idx) end; decrease_indent(); iprintf oc "}\n"; (* Null-terminate the array if requested *) if attr.null_terminated then iprintf oc "%s[%s] = 0;\n" c size; (* Update dependent size variable *) begin match attr.size with None -> () | Some re -> iprintf oc "%a = %s;\n" Lexpr.output (pref, re) size end end (* Translation from a C array [c] to an ML array [v] *) let array_c_to_ml c_to_ml oc pref attr ty_elt c v = if attr.is_string then iprintf oc "%s = copy_string(%s);\n" v c else begin (* Determine size of ML array *) let (nsize, size) = match attr with {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 "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 = Bigarray_val(%s)->data;\n" c v; (* Update dependent size variables, if any *) iter_index (fun i attr -> match attr.size with None -> () | Some re -> iprintf oc "%a = Bigarray_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), _) -> "BIGARRAY_UINT8" | Type_int((SChar | Small), _) -> "BIGARRAY_SINT8" | Type_int(Short, _) -> "BIGARRAY_SINT16" | Type_int(UShort, _) -> "BIGARRAY_UINT16" | Type_int((Int | UInt), _) -> "BIGARRAY_INT32" | Type_int((Long | ULong), I64) -> "BIGARRAY_INT64" | Type_int((Long | ULong), _) -> "BIGARRAY_NATIVE_INT" | Type_int((Hyper | UHyper), _) -> "BIGARRAY_INT64" | Type_float -> "BIGARRAY_FLOAT32" | Type_double -> "BIGARRAY_FLOAT64" | _ -> assert false let bigarray_alloc_layout attr = if attr.fortran_layout then "BIGARRAY_FORTRAN_LAYOUT" else "BIGARRAY_C_LAYOUT" let bigarray_alloc_managed attr = if attr.malloced then "BIGARRAY_MANAGED" else "BIGARRAY_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 = alloc_bigarray_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 = 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-1.05/compiler/array.mli0100644004340400512160000000335607421245350016262 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/clflags.ml0100644004340400512160000000245007147464730016412 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/config.mli0100644004340400512160000000206007317101327016377 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/config.mlp0100644004340400512160000000212707317101327016412 0ustar xleroycristal(***********************************************************************) (* *) (* 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-1.05/compiler/constdecl.ml0100644004340400512160000000564207421323442016750 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 c.cd_name); match scrape_type c.cd_type with Type_int(_, _) as ty -> 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 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-1.05/compiler/constdecl.mli0100644004340400512160000000230207147464730017122 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/cvttyp.ml0100644004340400512160000001726710073227373016334 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 modl); output_string oc (String.uncapitalize 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 modl); if name = "" then fprintf oc "%s_%d" kind stamp else output_string oc (String.uncapitalize 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-1.05/compiler/cvttyp.mli0100644004340400512160000000346407421323443016475 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/cvtval.ml0100644004340400512160000002214210073216612016260 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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) -> Array.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' -> Array.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) -> Array.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' -> Array.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 -> "copy_nativeint" | I32 -> "copy_int32" | I64 -> "copy_int64" in iprintf oc "%s = %s(%s);\n" v conv c | Type_float | Type_double -> iprintf oc "%s = 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) -> Array.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 (Array.array_c_to_ml c_to_ml oc pref attr ty_elt c) | Type_bigarray({bigarray_maybe_null=false} as attr, ty_elt) -> Array.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 (Array.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) -> Array.array_allocate_output_space oc pref attr ty_arg c | Type_bigarray(attr, ty_arg) -> Array.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-1.05/compiler/cvtval.mli0100644004340400512160000000224307421245351016436 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/enum.ml0100644004340400512160000000464107147464730015747 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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: 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 = 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-1.05/compiler/enum.mli0100644004340400512160000000276707421245351016116 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/enumdecl.ml0100644004340400512160000000643307147464730016600 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 en.en_name); List.iter (fun c -> fprintf oc " | %s\n" (String.capitalize 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-1.05/compiler/enumdecl.mli0100644004340400512160000000226407147464730016747 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/file.ml0100644004340400512160000001705007460015215015704 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 !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-1.05/compiler/file.mli0100644004340400512160000000313207147464730016065 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/fixlabels.ml0100644004340400512160000001213507313105560016735 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/fixlabels.mli0100644004340400512160000000173107147464730017122 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/funct.ml0100644004340400512160000002761310073214337016112 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 (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-1.05/compiler/funct.mli0100644004340400512160000000310710073214337016253 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/idltypes.mli0100644004340400512160000000711607421323443016777 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/intf.ml0100644004340400512160000003540710073214431015726 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 intf.intf_name) (* Declare the class *) let ml_class_declaration oc intf = let mlintf = String.uncapitalize intf.intf_name in let mlsuper = String.uncapitalize 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 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 intf.intf_name in let supername = String.uncapitalize 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 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 meth.fun_name)) : int) in (* Do the callback *) iprintf pc "_vres = callbackN_exn(caml_get_public_method(_varg[0], Val_int(%d)), %d, _varg);\n" label (num_ins + 1); (* Check if exception occurred *) begin match meth.fun_res with Type_named(_, "HRESULT") -> 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 = let (ins, outs) = ml_view meth in (* 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-1.05/compiler/intf.mli0100644004340400512160000000307607147464731016116 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/lexer_midl.mli0100644004340400512160000000167607147464731017306 0ustar xleroycristal(***********************************************************************) (* *) (* 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.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-1.05/compiler/lexer_midl.mll0100644004340400512160000001260510050415510017255 0ustar xleroycristal(***********************************************************************) (* *) (* 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; "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; "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-1.05/compiler/lexer_simple.mli0100644004340400512160000000164307147464731017644 0ustar xleroycristal(***********************************************************************) (* *) (* 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_simple.mli,v 1.3 2000/08/19 11:04:57 xleroy Exp $ *) val token: Lexing.lexbuf -> Parser_simple.token camlidl-1.05/compiler/lexpr.ml0100644004340400512160000003726707421323444016136 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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) (* 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-1.05/compiler/lexpr.mli0100644004340400512160000000334007421323444016270 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 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-1.05/compiler/linenum.mli0100644004340400512160000000313307317101330016575 0ustar xleroycristal(***********************************************************************) (* *) (* 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.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-1.05/compiler/linenum.mll0100644004340400512160000000561207317101330016604 0ustar xleroycristal(***********************************************************************) (* *) (* 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-1.05/compiler/main.ml0100644004340400512160000000602407460015215015710 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 ^ ".ml"); 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-1.05/compiler/normalize.ml0100644004340400512160000002127407421323444016773 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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) let rec is_char_type = function Type_int((Char | UChar | Byte), _) -> true | Type_named(modname, tyname) -> is_char_type (expand_typedef tyname) | Type_const ty -> is_char_type ty | _ -> false (* 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) -> let norm_ty_elt = normalize_type ty_elt in if attr.is_string && not (is_char_type norm_ty_elt) then error "[string] argument applies only to \ char array or pointer to char"; Type_array(attr, norm_ty_elt) | 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-1.05/compiler/normalize.mli0100644004340400512160000000171607147464731017155 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/parse.ml0100644004340400512160000000467507460026314016112 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/parse.mli0100644004340400512160000000165307147464731016267 0ustar xleroycristal(***********************************************************************) (* *) (* 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: parse.mli,v 1.4 2000/08/19 11:04:57 xleroy Exp $ *) (* Source parsing *) val read_file: string -> File.components camlidl-1.05/compiler/parse_aux.ml0100644004340400512160000004713710073214360016761 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 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 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 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 (* 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_import name = if StringSet.mem name !imports then [] else begin imports := StringSet.add name !imports; [Comp_import(name, !read_file name)] end camlidl-1.05/compiler/parse_aux.mli0100644004340400512160000001041607421323445017130 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 read_file : (string -> components) ref (* Forward declaration of [Parse.read_file] *) val read_import : string -> components (* Read an import file *) camlidl-1.05/compiler/parser_midl.mly0100644004340400512160000004012107460026333017455 0ustar xleroycristal/***********************************************************************/ /* */ /* 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 INT64 %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 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 STRING SEMI { read_import $2 } | quote opt_semi { let (kind, txt) = make_diversion $1 in [Comp_diversion(kind, txt)] } ; /* 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 { make_int Hyper } | UNSIGNED INT64 { make_int UHyper } | SIGNED INT64 { make_int Hyper } | VOID { Type_void } | TYPEIDENT { Type_named("", $1) } | WCHAR_T { wchar_t_type() } | HANDLE_T { handle_t_type() } ; integer_size: LONG { Long } | SMALL { Small } | SHORT { Short } | HYPER { Hyper } | LONG LONG { Hyper } ; 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_case { [$1] } | union_body union_case { $2 :: $1 } ; union_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 } ; 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, []) } | 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 } | 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 } ; /* 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-1.05/compiler/predef.ml0100644004340400512160000000514507460015215016234 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/predef.mli0100644004340400512160000000173507147464732016424 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/prefix.ml0100644004340400512160000000276107421245353016272 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/prefix.mli0100644004340400512160000000203107421245353016431 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/struct.ml0100644004340400512160000001137710073214775016325 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/struct.mli0100644004340400512160000000244707421245353016473 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/structdecl.ml0100644004340400512160000000666407421245353017157 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 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 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-1.05/compiler/structdecl.mli0100644004340400512160000000220707147464732017326 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/typedef.ml0100644004340400512160000001660507464004143016434 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 td.td_name) s | {td_abstract = true} -> fprintf oc "%s\n" (String.uncapitalize td.td_name) | _ -> fprintf oc "%s = %a\n" (String.uncapitalize 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 = 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-1.05/compiler/typedef.mli0100644004340400512160000000274207460015216016601 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/union.ml0100644004340400512160000001373307421245354016127 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 " invalid_argument(\"%s: bad discriminant for union %s\");\n" !current_function ud.ud_name end; iprintf oc "}\n" camlidl-1.05/compiler/union.mli0100644004340400512160000000237707421245354016302 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/uniondecl.ml0100644004340400512160000001032207421245354016746 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 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 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-1.05/compiler/uniondecl.mli0100644004340400512160000000220107147464732017124 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/utils.ml0100644004340400512160000000612207421323446016130 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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 = String.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-1.05/compiler/utils.mli0100644004340400512160000000310507777614454016317 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/variables.ml0100644004340400512160000000537107460750631016750 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/compiler/variables.mli0100644004340400512160000000240307147464732017120 0ustar xleroycristal(***********************************************************************) (* *) (* 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: 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-1.05/config/0040755004340400512160000000000010074760723014074 5ustar xleroycristalcamlidl-1.05/config/.cvsignore0100644004340400512160000000001107251122512016050 0ustar xleroycristalMakefile camlidl-1.05/config/Makefile.unix0100644004340400512160000000313607460774426016530 0ustar xleroycristal#*********************************************************************** #* * #* 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=/lib/cpp # Alternatives: # CPP=cpp # CPP=/usr/ccs/lib/cpp # CPP=gcc -x c -E # How to invoke ranlib (only relevant for Unix) RANLIB=ranlib # If ranlib is not needed: #RANLIB=: # Location of the Objective Caml library in your installation OCAMLLIB=/usr/local/lib/ocaml # Where to install the binaries BINDIR=/usr/local/bin # The Objective Caml compilers (the defaults below should be OK) OCAMLC=ocamlc -g OCAMLOPT=ocamlopt OCAMLYACC=ocamlyacc -v OCAMLLEX=ocamllex OCAMLDEP=ocamldep # Extra flags to pass to the C compiler CFLAGS=-Wall -g # Suffixes for executables and libraries (do not change) EXE= LIBEXT=a OBJEXT=o camlidl-1.05/config/Makefile.win320100644004340400512160000000264510073236146016475 0ustar xleroycristal#*********************************************************************** #* * #* 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=C:/ocaml/lib # 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-1.05/lib/0040755004340400512160000000000010074760723013375 5ustar xleroycristalcamlidl-1.05/lib/.depend0100644004340400512160000000004406663265043014634 0ustar xleroycristalcom.cmo: com.cmi com.cmx: com.cmi camlidl-1.05/lib/Makefile0100644004340400512160000000305607460774427015051 0ustar xleroycristal#*********************************************************************** #* * #* 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) $(BYTEOBJS) $(NATIVELIB): $(NATIVEOBJS) $(OCAMLOPT) -a -o $(NATIVELIB) $(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 *~ # Dependencies depend: $(OCAMLDEP) *.mli *.ml > .depend include .depend camlidl-1.05/lib/com.ml0100644004340400512160000000402710073213610014470 0ustar xleroycristal(***********************************************************************) (* *) (* 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-1.05/lib/com.mli0100644004340400512160000001272207147464733014670 0ustar xleroycristal(***********************************************************************) (* *) (* 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-1.05/runtime/0040755004340400512160000000000010074760723014312 5ustar xleroycristalcamlidl-1.05/runtime/Makefile0100644004340400512160000000162407147464733015763 0ustar xleroycristal#*********************************************************************** #* * #* 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-1.05/runtime/Makefile.unix0100644004340400512160000000236007147464734016744 0ustar xleroycristal#*********************************************************************** #* * #* 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: libcamlidl.a libcamlidl.a: $(OBJS) - rm -f $@ ar rc $@ $(OBJS) $(RANLIB) $@ install: cp camlidlruntime.h $(OCAMLLIB)/caml/camlidlruntime.h cp libcamlidl.a $(OCAMLLIB)/libcamlidl.a cd $(OCAMLLIB); $(RANLIB) libcamlidl.a clean: rm -f *.a *.o .SUFFIXES: .c .o .c.o: $(OCAMLC) -ccopt "$(CFLAGS)" $< $(OBJS): camlidlruntime.h comstuff.h depend: camlidl-1.05/runtime/Makefile.win320100644004340400512160000000267107147464734016730 0ustar xleroycristal#*********************************************************************** #* * #* 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-1.05/runtime/camlidlruntime.h0100644004340400512160000001257710073214137017475 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/runtime/cfactory.cpp0100644004340400512160000001301710073214161016614 0ustar xleroycristal/***********************************************************************/ /* */ /* 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 "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 */ BOOL APIENTRY DllMain(HANDLE module, DWORD reason, void *reserved) { char * argv[2]; char dll_path[_MAX_PATH]; switch(reason) { case DLL_PROCESS_ATTACH: GetModuleFileName( (HMODULE) module, dll_path, _MAX_PATH ); argv[0] = dll_path; argv[1] = NULL; camlidl_module_handle = (HMODULE) module; #if 0 int fd = open("/tmp/camllog", O_RDWR|O_TRUNC|O_CREAT, _S_IWRITE|_S_IREAD); dup2(fd, 1); dup2(fd, 2); close(fd); #endif caml_startup(argv); break; /* TODO: free all memory when DLL detached */ } return TRUE; } camlidl-1.05/runtime/comerror.c0100644004340400512160000001231007313105654016276 0ustar xleroycristal/***********************************************************************/ /* */ /* 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 "camlidlruntime.h" #include "comstuff.h" static void camlidl_raise_error(HRESULT errcode, char * who, char * msg) { static 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) { char msg[1024]; 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-1.05/runtime/comintf.c0100644004340400512160000001766510073214261016117 0ustar xleroycristal/***********************************************************************/ /* */ /* 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; } } if (IsEqualIID(iid, &IID_IUnknown)) { *object = (void *) this; InterlockedIncrement(&(comp->refcount)); return S_OK; } #ifdef _WIN32 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 *) i1)->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-1.05/runtime/comstuff.h0100644004340400512160000000542307310433464016310 0ustar xleroycristal/***********************************************************************/ /* */ /* 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))) extern IID IID_IUnknown; #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-1.05/runtime/dispatch.c0100644004340400512160000001166607147464734016276 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/runtime/idlalloc.c0100644004340400512160000000735107147464734016256 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/runtime/oletypes.c0100644004340400512160000000341407147464734016333 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/runtime/registry.cpp0100644004340400512160000001411306663273113016664 0ustar xleroycristal// // 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-1.05/runtime/registry.h0100644004340400512160000000316707147464734016351 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/runtime/superror.cpp0100644004340400512160000000374407147464734016716 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/tests/0040755004340400512160000000000010074760744013774 5ustar xleroycristalcamlidl-1.05/tests/comp/0040755004340400512160000000000010074760723014727 5ustar xleroycristalcamlidl-1.05/tests/comp/CLIENT.CPP0100644004340400512160000000364106664313377016263 0ustar xleroycristal// // 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-1.05/tests/comp/CMPNT.CPP0100644004340400512160000001431606664313377016167 0ustar xleroycristal// // 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-1.05/tests/comp/CMPNT.DEF0100644004340400512160000000045706673222604016134 0ustar xleroycristalLIBRARY 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-1.05/tests/comp/GUIDS.CPP0100644004340400512160000000172206664313377016156 0ustar xleroycristal// // 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-1.05/tests/comp/IFACE.H0100644004340400512160000000111606664313377015654 0ustar xleroycristal// // 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-1.05/tests/comp/MAKEFILE0100644004340400512160000000435507460774427016046 0ustar xleroycristal# # 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-1.05/tests/comp/README0100644004340400512160000000027306664313377015617 0ustar xleroycristalThe 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-1.05/tests/comp/REGISTRY.CPP0100644004340400512160000001400506664313377016551 0ustar xleroycristal// // 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-1.05/tests/comp/REGISTRY.H0100644004340400512160000000141206664313377016314 0ustar xleroycristal#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-1.05/tests/comp/camlclient.ml0100644004340400512160000000256406664313377017411 0ustar xleroycristal(* 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-1.05/tests/comp/camlcomp.def0100644004340400512160000000041606664313377017211 0ustar xleroycristalLIBRARY Camlcomp.dll DESCRIPTION 'CAMLIDL, test component 1' EXPORTS DllGetClassObject @2 PRIVATE DllCanUnloadNow @3 PRIVATE DllRegisterServer @4 PRIVATE DllUnregisterServer @5 PRIVATE camlidl-1.05/tests/comp/camlcomp.ml0100644004340400512160000000151306664313377017062 0ustar xleroycristal(* 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-1.05/tests/comp/component.idl0100644004340400512160000000047606664313377017440 0ustar xleroycristal[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-1.05/tests/Makefile0100644004340400512160000000320407460774427015440 0ustar xleroycristalinclude ../config/Makefile CAMLIDL=../compiler/camlidl CAMLC=ocamlc -I ../lib INCLUDES=-I.. -I$(OCAMLLIB) CCPP=$(CC) CPPFLAGS=$(CFLAGS) TESTS=basics.idl arrays.idl structs.idl unions.idl typedefs.idl $(TESTS_$(OSTYPE)) 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-1.05/tests/arrays.idl0100644004340400512160000000210307334260353015754 0ustar xleroycristal[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-1.05/tests/basics.idl0100644004340400512160000000157007331267402015725 0ustar xleroycristal/* 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-1.05/tests/comcomp.c0100644004340400512160000001023706647671650015605 0ustar xleroycristal/* 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-1.05/tests/comcomp.cpp0100644004340400512160000001153207460775243016141 0ustar xleroycristal// 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-1.05/tests/comcomp.h0100644004340400512160000000173106650337051015575 0ustar xleroycristalextern 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-1.05/tests/component.idl0100644004340400512160000000067507312436700016466 0ustar xleroycristal[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-1.05/tests/imports.idl0100644004340400512160000000044306654027105016155 0ustar xleroycristal/* 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-1.05/tests/structs.idl0100644004340400512160000000175707421245355016202 0ustar xleroycristal/* 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-1.05/tests/testcomponent.ml0100644004340400512160000000347707313105714017230 0ustar xleroycristal(* 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-1.05/tests/typedefs.idl0100644004340400512160000000046207460015176016305 0ustar xleroycristal/* 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-1.05/tests/unix.idl0100644004340400512160000001114107331267424015443 0ustar xleroycristal/* 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) 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) 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-1.05/tests/dispatch/0040755004340400512160000000000010074760724015571 5ustar xleroycristalcamlidl-1.05/tests/dispatch/CFACTORY.CPP0100644004340400512160000001557006673222326017355 0ustar xleroycristal/////////////////////////////////////////////////////////// // // 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-1.05/tests/dispatch/CFACTORY.H0100644004340400512160000000627106673222326017120 0ustar xleroycristal#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-1.05/tests/dispatch/CLIENT.CPP0100644004340400512160000000312506673222326017112 0ustar xleroycristal// // 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-1.05/tests/dispatch/CMPNT.CPP0100644004340400512160000001545406673222326017025 0ustar xleroycristal// // 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-1.05/tests/dispatch/CMPNT.H0100644004340400512160000000340306673222327016562 0ustar xleroycristal// // 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-1.05/tests/dispatch/CUNKNOWN.CPP0100644004340400512160000000461006673222327017377 0ustar xleroycristal/////////////////////////////////////////////////////////// // // 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-1.05/tests/dispatch/CUNKNOWN.H0100644004340400512160000000523706673222327017152 0ustar xleroycristal#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-1.05/tests/dispatch/DCLIENT.CPP0100644004340400512160000001507206673222327017223 0ustar xleroycristal// // 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-1.05/tests/dispatch/IFACE.H0100644004340400512160000001705106673222327016514 0ustar xleroycristal/* 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-1.05/tests/dispatch/MAKEFILE0100644004340400512160000000655506673227335016707 0ustar xleroycristal# # 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-1.05/tests/dispatch/README0100644004340400512160000000027306673222671016454 0ustar xleroycristalThe 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-1.05/tests/dispatch/REGISTRY.CPP0100644004340400512160000001723606673222327017415 0ustar xleroycristal// // 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-1.05/tests/dispatch/REGISTRY.H0100644004340400512160000000146506673222327017157 0ustar xleroycristal#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-1.05/tests/dispatch/SERVER.CPP0100644004340400512160000000221306673222330017132 0ustar xleroycristal#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-1.05/tests/dispatch/SERVER.DEF0100644004340400512160000000045706673222330017116 0ustar xleroycristalLIBRARY 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-1.05/tests/dispatch/SERVER.IDL0100644004340400512160000000156506673222330017131 0ustar xleroycristal// // 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-1.05/tests/dispatch/UTIL.CPP0100644004340400512160000000333506673222330016707 0ustar xleroycristal// // // 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-1.05/tests/dispatch/camlclient.ml0100644004340400512160000000242006673222330020225 0ustar xleroycristal(* 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-1.05/tests/dispatch/camlcomp.ml0100644004340400512160000000151006673227335017716 0ustar xleroycristal(* 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-1.05/tests/dispatch/component.idl0100644004340400512160000000127006673222330020256 0ustar xleroycristal#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-1.05/tools/0040755004340400512160000000000010074760724013770 5ustar xleroycristalcamlidl-1.05/tools/.cvsignore0100644004340400512160000000001306664313400015752 0ustar xleroycristalcamlidldll camlidl-1.05/tools/Makefile0100644004340400512160000000162407147464734015441 0ustar xleroycristal#*********************************************************************** #* * #* 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-1.05/tools/Makefile.unix0100644004340400512160000000160207147464734016417 0ustar xleroycristal#*********************************************************************** #* * #* 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-1.05/tools/Makefile.win320100644004340400512160000000214707314371737016377 0ustar xleroycristal#*********************************************************************** #* * #* 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 sed -e 's|%%CAMLLIB%%|$(OCAMLLIB)|' -e '/^camllib=/s|/|\\|g' camlidldll.tpl > camlidldll install: cp camlidldll $(BINDIR) cp camlidlcompat.h $(OCAMLLIB)/caml clean: rm -f camlidldll depend: camlidl-1.05/tools/camlidlcompat.h0100644004340400512160000000416307460023157016750 0ustar xleroycristal/***********************************************************************/ /* */ /* 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-1.05/tools/camlidldll.tpl0100644004340400512160000000607507460774427016631 0ustar xleroycristal#!/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